[Bio] / Sprout / SearchHelper.pm Repository:
ViewVC logotype

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (view) (download) (as text)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package SearchHelper;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use PageBuilder;
8 :     use Digest::MD5;
9 :     use File::Basename;
10 :     use File::Path;
11 :     use File::stat;
12 :     use LWP::UserAgent;
13 :     use Time::HiRes 'gettimeofday';
14 :     use Sprout;
15 :     use SFXlate;
16 :     use FIGRules;
17 :     use HTML;
18 :     use BasicLocation;
19 : parrello 1.2 use FeatureQuery;
20 : parrello 1.3 use URI::Escape;
21 :     use PageBuilder;
22 : parrello 1.1
23 :     =head1 Search Helper Base Class
24 :    
25 :     =head2 Introduction
26 :    
27 :     The search helper is a base class for all search objects. It has methods for performing
28 :     all the common tasks required to build and manage a search cache. The subclass must
29 :     provide methods for generating and processing search forms. The base class has the
30 :     following object fields.
31 :    
32 :     =over 4
33 :    
34 :     =item cols
35 :    
36 :     Reference to a list of column header descriptions. If undefined, then the session cache
37 :     file has been opened but nothing has been written to it.
38 :    
39 :     =item fileHandle
40 :    
41 :     File handle for the session cache file.
42 :    
43 :     =item query
44 :    
45 :     CGI query object, which includes the search parameters and the various
46 :     session status variables kept between requests from the user.
47 :    
48 :     =item type
49 :    
50 :     Session type: C<old> if there is an existing cache file from which we are
51 :     displaying search results, or C<new> if the cache file needs to be built.
52 :    
53 :     =item class
54 :    
55 :     Name of the search helper class as it would appear in the CGI query object
56 :     (i.e. without the C<SH> prefix.
57 :    
58 :     =item sprout
59 :    
60 :     Sprout object for accessing the database.
61 :    
62 :     =item message
63 :    
64 :     Message to display if an error has been detected.
65 :    
66 :     =item orgs
67 :    
68 :     Reference to a hash mapping genome IDs to organism names.
69 :    
70 :     =item name
71 :    
72 :     Name to use for this object's form.
73 :    
74 :     =item scriptQueue
75 :    
76 :     List of JavaScript statements to be executed after the form is closed.
77 :    
78 : parrello 1.3 =item genomeHash
79 :    
80 :     Cache of the genome group hash used to build genome selection controls.
81 :    
82 :     =item genomeParms
83 :    
84 :     List of the parameters that are used to select multiple genomes.
85 :    
86 :     =item filtered
87 :    
88 :     TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89 :     field is updated by the B<FeatureQuery> object.
90 :    
91 : parrello 1.1 =back
92 :    
93 : parrello 1.2 =head2 Adding a new Search Tool
94 :    
95 :     To add a new search tool to the system, you must
96 :    
97 :     =over 4
98 :    
99 :     =item 1
100 :    
101 :     Choose a class name for your search tool.
102 :    
103 :     =item 2
104 :    
105 :     Create a new subclass of this object and implement each of the virtual methods. The
106 :     name of the subclass must be C<SH>I<className>.
107 :    
108 :     =item 3
109 :    
110 :     Create an include file among the web server pages that describes how to use
111 :     the search tool. The include file must be in the B<includes> directory, and
112 :     its name must be C<SearchHelp_>I<className>C<.inc>.
113 :    
114 :     =item 4
115 :    
116 :     In the C<SearchSkeleton.cgi> script, add a C<use> statement for your search tool
117 :     and then put the class name in the C<@advancedClasses> list.
118 :    
119 :     =back
120 :    
121 :     =head3 Building a Search Form
122 :    
123 :     All search forms are three-column tables. In general, you want one form
124 :     variable per table row. The first column should contain the label and
125 :     the second should contain the form control for specifying the variable
126 :     value. If the control is wide, you should use C<colspan="2"> to give it
127 :     extra room. B<Do not> specify a width in any of your table cells, as
128 :     width management is handled by this class.
129 :    
130 :     The general code for creating the form should be
131 :    
132 :     sub Form {
133 :     my ($self) = @_;
134 :     # Get the CGI object.
135 :     my $cgi = @self->Q();
136 :     # Start the form.
137 :     my $retVal = $self->FormStart("form title");
138 :     # Assemble the table rows.
139 :     my @rows = ();
140 :     ... push table row Html into @rows ...
141 :     push @rows, $self->SubmitRow();
142 :     ... push more Html into @rows ...
143 :     # Build the table from the rows.
144 :     $retVal .= $self->MakeTable(\@rows);
145 :     # Close the form.
146 :     $retVal .= $self->FormEnd();
147 :     # Return the form Html.
148 :     return $retVal;
149 :     }
150 :    
151 :     Several helper methods are provided for particular purposes.
152 :    
153 :     =over 4
154 :    
155 :     =item 1
156 :    
157 : parrello 1.3 L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
158 :     L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
159 :     name. Note that as an assist to people working with GET-style links, if no
160 :     genomes are specified and the incoming request style is GET, all genomes will
161 :     be returned.
162 : parrello 1.2
163 :     =item 2
164 :    
165 :     L</FeatureFilterRow> formats several rows of controls for filtering features.
166 :     When you start building the code for the L</Find> method, you can use a
167 :     B<FeatureQuery> object to automatically filter each genome's features using
168 :     the values from the filter controls.
169 :    
170 :     =item 3
171 :    
172 :     L</QueueFormScript> allows you to queue JavaScript statements for execution
173 :     after the form is fully generated. If you are using very complicated
174 :     form controls, the L</QueueFormScript> method allows you to perform
175 :     JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
176 :     facility to display a list of the pre-selected genomes.
177 :    
178 :     =back
179 :    
180 :     Finally, when generating the code for your controls, be sure to use any incoming
181 :     query parameters as default values so that the search request is persistent.
182 :    
183 :     =head3 Finding Search Results
184 :    
185 :     The L</Find> method is used to create the search results. For a search that
186 :     wants to return features (which is most of them), the basic code structure
187 :     would work as follows. It is assumed that the L</FeatureFilterRows> method
188 :     has been used to create feature filtering parameters.
189 :    
190 :     sub Find {
191 :     my ($self) = @_;
192 :     # Get the CGI and Sprout objects.
193 :     my $cgi = $self->Q();
194 :     my $sprout = $self->DB();
195 :     # Declare the return variable. If it remains undefined, the caller will
196 :     # know that an error occurred.
197 :     my $retVal;
198 :     ... validate the parameters ...
199 :     if (... invalid parameters...) {
200 :     $self->SetMessage(...appropriate message...);
201 :     } elsif (FeatureQuery::Valid($self)) {
202 :     # Initialize the session file.
203 :     $self->OpenSession();
204 :     # Initialize the result counter.
205 :     $retVal = 0;
206 :     ... get a list of genomes ...
207 :     for my $genomeID (... each genome ...) {
208 :     my $fq = FeatureQuery->new($self, $genomeID);
209 :     while (my $feature = $fq->Fetch()) {
210 :     ... examine the feature ...
211 :     if (... we want to keep it ...) {
212 :     $self->PutFeature($fq);
213 :     $retVal++;
214 :     }
215 :     }
216 :     }
217 : parrello 1.9 # Close the session file.
218 :     $self->CloseSession();
219 : parrello 1.2 }
220 :     # Return the result count.
221 :     return $retVal;
222 :     }
223 :    
224 :     A Find method is of course much more complicated than generating a form, and there
225 :     are variations on the above them. For example, you could eschew feature filtering
226 :     entirely in favor of your own custom filtering, you could include extra columns
227 :     in the output, or you could search for something that's not a feature at all. The
228 :     above code is just a loose framework.
229 :    
230 :     If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
231 :     method of the feature query object.
232 :    
233 :     $fq->AddExtraColumns(score => $sc);
234 :    
235 :     The L</Find> method must return C<undef> if the search parameters are invalid. If this
236 :     is the case, then a message describing the problem should be passed to the framework
237 :     by calling L</SetMessage>. If the parameters are valid, then the method must return
238 :     the number of items found.
239 :    
240 : parrello 1.1 =cut
241 :    
242 :     # This counter is used to insure every form on the page has a unique name.
243 :     my $formCount = 0;
244 :    
245 :     =head2 Public Methods
246 :    
247 :     =head3 new
248 :    
249 :     C<< my $shelp = SearchHelper->new($query); >>
250 :    
251 :     Construct a new SearchHelper object.
252 :    
253 :     =over 4
254 :    
255 :     =item query
256 :    
257 :     The CGI query object for the current script.
258 :    
259 :     =back
260 :    
261 :     =cut
262 :    
263 :     sub new {
264 :     # Get the parameters.
265 :     my ($class, $query) = @_;
266 :     # Check for a session ID.
267 :     my $session_id = $query->param("SessionID");
268 :     my $type = "old";
269 :     if (! $session_id) {
270 :     # Here we're starting a new session. We create the session ID and
271 :     # store it in the query object.
272 :     $session_id = NewSessionID();
273 :     $type = "new";
274 :     $query->param(-name => 'SessionID', -value => $session_id);
275 :     }
276 :     # Compute the subclass name.
277 :     $class =~ /SH(.+)$/;
278 :     my $subClass = $1;
279 :     # Insure everybody knows we're in Sprout mode.
280 :     $query->param(-name => 'SPROUT', -value => 1);
281 :     # Generate the form name.
282 :     my $formName = "$class$formCount";
283 :     $formCount++;
284 :     # Create the shelp object. It contains the query object (with the session ID)
285 :     # as well as an indicator as to whether or not the session is new, plus the
286 : parrello 1.2 # class name and a placeholder for the Sprout object.
287 : parrello 1.1 my $retVal = {
288 :     query => $query,
289 :     type => $type,
290 :     class => $subClass,
291 : parrello 1.2 sprout => undef,
292 : parrello 1.1 orgs => {},
293 :     name => $formName,
294 :     scriptQueue => [],
295 : parrello 1.3 genomeList => undef,
296 :     genomeParms => [],
297 :     filtered => 0,
298 : parrello 1.1 };
299 :     # Bless and return it.
300 :     bless $retVal, $class;
301 :     return $retVal;
302 :     }
303 :    
304 :     =head3 Q
305 :    
306 :     C<< my $query = $shelp->Q(); >>
307 :    
308 :     Return the CGI query object.
309 :    
310 :     =cut
311 :    
312 :     sub Q {
313 :     # Get the parameters.
314 :     my ($self) = @_;
315 :     # Return the result.
316 :     return $self->{query};
317 :     }
318 :    
319 : parrello 1.9
320 :    
321 : parrello 1.1 =head3 DB
322 :    
323 :     C<< my $sprout = $shelp->DB(); >>
324 :    
325 :     Return the Sprout database object.
326 :    
327 :     =cut
328 :    
329 :     sub DB {
330 :     # Get the parameters.
331 :     my ($self) = @_;
332 : parrello 1.2 # Insure we have a database.
333 :     my $retVal = $self->{sprout};
334 :     if (! defined $retVal) {
335 :     $retVal = SFXlate->new_sprout_only();
336 :     $self->{sprout} = $retVal;
337 :     }
338 : parrello 1.1 # Return the result.
339 : parrello 1.2 return $retVal;
340 : parrello 1.1 }
341 :    
342 :     =head3 IsNew
343 :    
344 :     C<< my $flag = $shelp->IsNew(); >>
345 :    
346 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
347 :     session already has search results ready to process.
348 :    
349 :     =cut
350 :    
351 :     sub IsNew {
352 :     # Get the parameters.
353 :     my ($self) = @_;
354 :     # Return the result.
355 :     return ($self->{type} eq 'new');
356 :     }
357 :    
358 :     =head3 ID
359 :    
360 :     C<< my $sessionID = $shelp->ID(); >>
361 :    
362 :     Return the current session ID.
363 :    
364 :     =cut
365 :    
366 :     sub ID {
367 :     # Get the parameters.
368 :     my ($self) = @_;
369 :     # Return the result.
370 :     return $self->Q()->param("SessionID");
371 :     }
372 :    
373 :     =head3 FormName
374 :    
375 :     C<< my $name = $shelp->FormName(); >>
376 :    
377 :     Return the name of the form this helper object will generate.
378 :    
379 :     =cut
380 :    
381 :     sub FormName {
382 :     # Get the parameters.
383 :     my ($self) = @_;
384 :     # Return the result.
385 :     return $self->{name};
386 :     }
387 :    
388 :     =head3 QueueFormScript
389 :    
390 :     C<< $shelp->QueueFormScript($statement); >>
391 :    
392 :     Add the specified statement to the queue of JavaScript statements that are to be
393 :     executed when the form has been fully defined. This is necessary because until
394 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
395 :     name. When generating the statement, you can refer to the variable C<thisForm>
396 :     in order to reference the form in progress. Thus,
397 :    
398 :     thisForm.simLimit.value = 1e-10;
399 :    
400 :     would set the value of the form element C<simLimit> in the current form to
401 :     C<1e-10>.
402 :    
403 :     =over 4
404 :    
405 :     =item statement
406 :    
407 :     JavaScript statement to be queued for execution after the form is built.
408 :     The trailing semi-colon is required. Theoretically, you could include
409 :     multiple statements separated by semi-colons, but one at a time works
410 :     just as well.
411 :    
412 :     =back
413 :    
414 :     =cut
415 :    
416 :     sub QueueFormScript {
417 :     # Get the parameters.
418 :     my ($self, $statement) = @_;
419 :     # Push the statement onto the script queue.
420 :     push @{$self->{scriptQueue}}, $statement;
421 :     }
422 :    
423 :     =head3 FormStart
424 :    
425 :     C<< my $html = $shelp->FormStart($title); >>
426 :    
427 :     Return the initial section of a form designed to perform another search of the
428 :     same type. The form header is included along with hidden fields to persist the
429 :     tracing, sprout status, and search class.
430 :    
431 :     A call to L</FormEnd> is required to close the form.
432 :    
433 :     =over 4
434 :    
435 :     =item title
436 :    
437 :     Title to be used for the form.
438 :    
439 :     =item RETURN
440 :    
441 :     Returns the initial HTML for the search form.
442 :    
443 :     =back
444 :    
445 :     =cut
446 :    
447 :     sub FormStart {
448 :     # Get the parameters.
449 :     my ($self, $title) = @_;
450 :     # Get the CGI object.
451 :     my $cgi = $self->Q();
452 :     # Start the form.
453 :     my $retVal = "<div class=\"search\">\n" .
454 :     $cgi->start_form(-method => 'POST',
455 :     -action => $cgi->url(-relative => 1),
456 :     -name => $self->FormName()) .
457 :     $cgi->hidden(-name => 'Class',
458 :     -value => $self->{class}) .
459 :     $cgi->hidden(-name => 'SPROUT',
460 :     -value => 1) .
461 :     $cgi->h3($title);
462 :     # If tracing is on, add it to the form.
463 :     if ($cgi->param('Trace')) {
464 :     $retVal .= $cgi->hidden(-name => 'Trace',
465 :     -value => $cgi->param('Trace')) .
466 :     $cgi->hidden(-name => 'TF',
467 :     -value => ($cgi->param('TF') ? 1 : 0));
468 :     }
469 :     # Put in an anchor tag in case there's a table of contents.
470 :     my $anchorName = $self->FormName();
471 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
472 :     # Return the result.
473 :     return $retVal;
474 :     }
475 :    
476 :     =head3 FormEnd
477 :    
478 :     C<< my $htmlText = $shelp->FormEnd(); >>
479 :    
480 :     Return the HTML text for closing a search form. This closes both the C<form> and
481 :     C<div> tags.
482 :    
483 :     =cut
484 :    
485 :     sub FormEnd {
486 :     # Get the parameters.
487 :     my ($self) = @_;
488 :     # Declare the return variable, closing the form and the DIV block.
489 :     my $retVal = "</form></div>\n";
490 :     # Now we flush out the statement queue.
491 :     my @statements = @{$self->{scriptQueue}};
492 :     if (@statements > 0) {
493 :     # Switch to JavaScript and set the "thisForm" variable.
494 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
495 :     " thisForm = document.$self->{name};\n";
496 :     # Unroll the statements.
497 :     while (@statements > 0) {
498 :     my $statement = shift @statements;
499 :     $retVal .= " $statement\n";
500 :     }
501 :     # Close the JavaScript.
502 :     $retVal .= "</SCRIPT>\n";
503 :     }
504 :     # Return the result.
505 :     return $retVal;
506 :     }
507 :    
508 :     =head3 SetMessage
509 :    
510 :     C<< $shelp->SetMessage($msg); >>
511 :    
512 :     Store the specified text as the result message. The result message is displayed
513 :     if an invalid parameter value is specified.
514 :    
515 :     =over 4
516 :    
517 :     =item msg
518 :    
519 :     Text of the result message to be displayed.
520 :    
521 :     =back
522 :    
523 :     =cut
524 :    
525 :     sub SetMessage {
526 :     # Get the parameters.
527 :     my ($self, $msg) = @_;
528 :     # Store the message.
529 :     $self->{message} = $msg;
530 :     }
531 :    
532 :     =head3 Message
533 :    
534 :     C<< my $text = $shelp->Message(); >>
535 :    
536 :     Return the result message. The result message is displayed if an invalid parameter
537 :     value is specified.
538 :    
539 :     =cut
540 :    
541 :     sub Message {
542 :     # Get the parameters.
543 :     my ($self) = @_;
544 :     # Return the result.
545 :     return $self->{message};
546 :     }
547 :    
548 :     =head3 OpenSession
549 :    
550 :     C<< $shelp->OpenSession(); >>
551 :    
552 :     Set up to open the session cache file for writing. Note we don't actually
553 :     open the file until after we know the column headers.
554 :    
555 :     =cut
556 :    
557 :     sub OpenSession {
558 :     # Get the parameters.
559 :     my ($self) = @_;
560 :     # Denote we have not yet written out the column headers.
561 :     $self->{cols} = undef;
562 :     }
563 :    
564 :     =head3 GetCacheFileName
565 :    
566 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
567 :    
568 :     Return the name to be used for this session's cache file.
569 :    
570 :     =cut
571 :    
572 :     sub GetCacheFileName {
573 :     # Get the parameters.
574 :     my ($self) = @_;
575 :     # Return the result.
576 :     return $self->GetTempFileName('cache');
577 :     }
578 :    
579 :     =head3 GetTempFileName
580 :    
581 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
582 :    
583 :     Return the name to be used for a temporary file of the specified type. The
584 :     name is computed from the session name with the type as a suffix.
585 :    
586 :     =over 4
587 :    
588 :     =item type
589 :    
590 :     Type of temporary file to be generated.
591 :    
592 :     =item RETURN
593 :    
594 :     Returns a file name generated from the session name and the specified type.
595 :    
596 :     =back
597 :    
598 :     =cut
599 :    
600 :     sub GetTempFileName {
601 :     # Get the parameters.
602 :     my ($self, $type) = @_;
603 :     # Compute the file name. Note it gets stuffed in the FIG temporary
604 :     # directory.
605 :     my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";
606 :     # Return the result.
607 :     return $retVal;
608 :     }
609 :    
610 :     =head3 PutFeature
611 :    
612 : parrello 1.11 C<< $shelp->PutFeature($fdata); >>
613 : parrello 1.1
614 :     Store a feature in the result cache. This is the workhorse method for most
615 :     searches, since the primary data item in the database is features.
616 :    
617 :     For each feature, there are certain columns that are standard: the feature name, the
618 :     GBrowse and protein page links, the functional assignment, and so forth. If additional
619 : parrello 1.2 columns are required by a particular search subclass, they should be stored in
620 :     the feature query object using the B<AddExtraColumns> method. For example, the following
621 :     code adds columns for essentiality and virulence.
622 : parrello 1.1
623 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
624 :     $shelp->PutFeature($fd);
625 : parrello 1.1
626 :     For correct results, all values should be specified for all extra columns in all calls to
627 :     B<PutFeature>. (In particular, the column header names are computed on the first
628 :     call.) If a column is to be blank for the current feature, its value can be given
629 :     as C<undef>.
630 :    
631 :     if (! $essentialFlag) {
632 :     $essentialFlag = undef;
633 :     }
634 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
635 :     $shelp->PutFeature($fd);
636 : parrello 1.1
637 :     =over 4
638 :    
639 : parrello 1.11 =item fdata
640 : parrello 1.1
641 : parrello 1.11 B<FeatureData> object containing the current feature data.
642 : parrello 1.1
643 :     =back
644 :    
645 :     =cut
646 :    
647 :     sub PutFeature {
648 : parrello 1.2 # Get the parameters.
649 : parrello 1.11 my ($self, $fd) = @_;
650 : parrello 1.3 # Get the CGI query object.
651 :     my $cgi = $self->Q();
652 : parrello 1.2 # Get the feature data.
653 : parrello 1.11 my $record = $fd->Feature();
654 :     my $extraCols = $fd->ExtraCols();
655 : parrello 1.1 # Check for a first-call situation.
656 :     if (! defined $self->{cols}) {
657 :     # Here we need to set up the column information. Start with the defaults.
658 :     $self->{cols} = $self->DefaultFeatureColumns();
659 : parrello 1.11 # Add any additional columns requested by the feature filter.
660 :     push @{$self->{cols}}, FeatureQuery::AdditionalColumns($self);
661 : parrello 1.2 # Append the extras, sorted by column name.
662 :     for my $col (sort keys %{$extraCols}) {
663 :     push @{$self->{cols}}, "X=$col";
664 : parrello 1.1 }
665 :     # Write out the column headers. This also prepares the cache file to receive
666 :     # output.
667 :     $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
668 :     }
669 :     # Get the feature ID.
670 : parrello 1.11 my $fid = $fd->FID();
671 : parrello 1.1 # Loop through the column headers, producing the desired data.
672 :     my @output = ();
673 :     for my $colName (@{$self->{cols}}) {
674 : parrello 1.2 push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
675 : parrello 1.1 }
676 : parrello 1.9 # Compute the sort key. The sort key usually floats NMPDR organism features to the
677 : parrello 1.1 # top of the return list.
678 : parrello 1.11 my $key = $self->SortKey($fd);
679 : parrello 1.1 # Write the feature data.
680 :     $self->WriteColumnData($key, @output);
681 :     }
682 :    
683 :     =head3 WriteColumnHeaders
684 :    
685 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
686 :    
687 :     Write out the column headers for the current search session. The column headers
688 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
689 :     the handle saved.
690 :    
691 :     =over 4
692 :    
693 :     =item colNames
694 :    
695 :     A list of column names in the desired presentation order.
696 :    
697 :     =back
698 :    
699 :     =cut
700 :    
701 :     sub WriteColumnHeaders {
702 :     # Get the parameters.
703 :     my ($self, @colNames) = @_;
704 :     # Get the cache file name and open it for output.
705 :     my $fileName = $self->GetCacheFileName();
706 :     my $handle1 = Open(undef, ">$fileName");
707 :     # Write the column headers and close the file.
708 :     Tracer::PutLine($handle1, \@colNames);
709 :     close $handle1;
710 :     # Now open the sort pipe and save the file handle. Note how we append the
711 :     # sorted data to the column header row already in place. The output will
712 :     # contain a sort key followed by the real columns. The sort key is
713 :     # hacked off before going to the output file.
714 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
715 :     }
716 :    
717 :     =head3 WriteColumnData
718 :    
719 :     C<< $shelp->WriteColumnData($key, @colValues); >>
720 :    
721 :     Write a row of column values to the current search session. It is assumed that
722 :     the session file is already open for output.
723 :    
724 :     =over 4
725 :    
726 :     =item key
727 :    
728 :     Sort key.
729 :    
730 :     =item colValues
731 :    
732 :     List of column values to write to the search result cache file for this session.
733 :    
734 :     =back
735 :    
736 :     =cut
737 :    
738 :     sub WriteColumnData {
739 :     # Get the parameters.
740 :     my ($self, $key, @colValues) = @_;
741 :     # Write them to the cache file.
742 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
743 :     }
744 :    
745 :     =head3 CloseSession
746 :    
747 :     C<< $shelp->CloseSession(); >>
748 :    
749 :     Close the session file.
750 :    
751 :     =cut
752 :    
753 :     sub CloseSession {
754 :     # Get the parameters.
755 :     my ($self) = @_;
756 :     # Check for an open session file.
757 :     if (defined $self->{fileHandle}) {
758 :     # We found one, so close it.
759 : parrello 1.9 Trace("Closing session file.") if T(2);
760 : parrello 1.1 close $self->{fileHandle};
761 :     }
762 :     }
763 :    
764 :     =head3 NewSessionID
765 :    
766 :     C<< my $id = SearchHelpers::NewSessionID(); >>
767 :    
768 :     Generate a new session ID for the current user.
769 :    
770 :     =cut
771 :    
772 :     sub NewSessionID {
773 :     # Declare the return variable.
774 :     my $retVal;
775 :     # Get a digest encoder.
776 :     my $md5 = Digest::MD5->new();
777 : parrello 1.4 # Add the PID, the IP, and the time stamp. Note that the time stamp is
778 :     # actually two numbers, and we get them both because we're in list
779 :     # context.
780 :     $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
781 :     # Hash up all this identifying data.
782 :     $retVal = $md5->hexdigest();
783 :     # Return the result.
784 : parrello 1.1 return $retVal;
785 :     }
786 :    
787 :     =head3 OrganismData
788 :    
789 :     C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
790 :    
791 :     Return the name and status of the organism corresponding to the specified genome ID.
792 :     For performance reasons, this information is cached in a special hash table, so we
793 :     only compute it once per run.
794 :    
795 :     =over 4
796 :    
797 :     =item genomeID
798 :    
799 :     ID of the genome whose name is desired.
800 :    
801 :     =item RETURN
802 :    
803 :     Returns a list of two items. The first item in the list is the organism name,
804 :     and the second is the name of the NMPDR group, or an empty string if the
805 :     organism is not in an NMPDR group.
806 :    
807 :     =back
808 :    
809 :     =cut
810 :    
811 :     sub OrganismData {
812 :     # Get the parameters.
813 :     my ($self, $genomeID) = @_;
814 :     # Declare the return variables.
815 :     my ($orgName, $group);
816 :     # Check the cache.
817 :     my $cache = $self->{orgs};
818 :     if (exists $cache->{$genomeID}) {
819 :     ($orgName, $group) = @{$cache->{$genomeID}};
820 :     } else {
821 :     # Here we have to use the database.
822 :     my $sprout = $self->DB();
823 :     my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,
824 :     ['Genome(genus)', 'Genome(species)',
825 :     'Genome(unique-characterization)',
826 :     'Genome(primary-group)']);
827 : parrello 1.10 # Format and cache the name and display group.
828 :     ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
829 :     $strain);
830 : parrello 1.1 }
831 :     # Return the result.
832 :     return ($orgName, $group);
833 :     }
834 :    
835 :     =head3 Organism
836 :    
837 :     C<< my $orgName = $shelp->Organism($genomeID); >>
838 :    
839 :     Return the name of the relevant organism. The name is computed from the genus,
840 :     species, and unique characterization. A cache is used to improve performance.
841 :    
842 :     =over 4
843 :    
844 :     =item genomeID
845 :    
846 :     ID of the genome whose name is desired.
847 :    
848 :     =item RETURN
849 :    
850 :     Returns the display name of the specified organism.
851 :    
852 :     =back
853 :    
854 :     =cut
855 :    
856 :     sub Organism {
857 :     # Get the parameters.
858 :     my ($self, $genomeID) = @_;
859 :     # Get the organism data.
860 :     my ($retVal, $group) = $self->OrganismData($genomeID);
861 :     # Return the result.
862 :     return $retVal;
863 :     }
864 :    
865 :     =head3 FeatureGroup
866 :    
867 :     C<< my $groupName = $shelp->FeatureGroup($fid); >>
868 :    
869 :     Return the group name for the specified feature.
870 :    
871 :     =over 4
872 :    
873 :     =item fid
874 :    
875 :     ID of the relevant feature.
876 :    
877 :     =item RETURN
878 :    
879 :     Returns the name of the NMPDR group to which the feature belongs, or an empty
880 :     string if it is not part of an NMPDR group.
881 :    
882 :     =back
883 :    
884 :     =cut
885 :    
886 :     sub FeatureGroup {
887 :     # Get the parameters.
888 :     my ($self, $fid) = @_;
889 :     # Parse the feature ID to get the genome ID.
890 :     my ($genomeID) = FIGRules::ParseFeatureID($fid);
891 :     # Get the organism data.
892 :     my (undef, $retVal) = $self->OrganismData($genomeID);
893 :     # Return the result.
894 :     return $retVal;
895 :     }
896 :    
897 :     =head3 FeatureName
898 :    
899 :     C<< my $fidName = $shelp->FeatureName($fid); >>
900 :    
901 :     Return the display name of the specified feature.
902 :    
903 :     =over 4
904 :    
905 :     =item fid
906 :    
907 :     ID of the feature whose name is desired.
908 :    
909 :     =item RETURN
910 :    
911 :     A displayable feature name, consisting of the organism name plus some feature
912 :     type and location information.
913 :    
914 :     =back
915 :    
916 :     =cut
917 :    
918 :     sub FeatureName {
919 :     # Get the parameters.
920 :     my ($self, $fid) = @_;
921 :     # Declare the return variable
922 :     my $retVal;
923 :     # Parse the feature ID.
924 :     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);
925 :     if (! defined $genomeID) {
926 :     # Here the feature ID has an invalid format.
927 :     $retVal = "External: $fid";
928 :     } else {
929 :     # Here we can get its genome data.
930 :     $retVal = $self->Organism($genomeID);
931 : parrello 1.4 # Append the FIG ID.
932 :     $retVal .= " [$fid]";
933 : parrello 1.1 }
934 :     # Return the result.
935 :     return $retVal;
936 :     }
937 :    
938 :     =head3 ComputeFASTA
939 :    
940 :     C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>
941 :    
942 :     Parse a sequence input and convert it into a FASTA string of the desired type. Note
943 :     that it is possible to convert a DNA sequence into a protein sequence, but the reverse
944 :     is not possible.
945 :    
946 :     =over 4
947 :    
948 :     =item incomingType
949 :    
950 :     C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.
951 :    
952 :     =item desiredType
953 :    
954 :     C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the
955 :     I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.
956 :    
957 :     =item sequence
958 :    
959 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
960 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
961 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
962 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
963 :     line will be provided.
964 :    
965 :     =item RETURN
966 :    
967 :     Returns a string in FASTA format representing the content of the desired sequence with
968 :     an appropriate label. If the input is invalid, a message will be stored and we will
969 :     return C<undef>. Note that the output will include a trailing new-line.
970 :    
971 :     =back
972 :    
973 :     =cut
974 :    
975 :     sub ComputeFASTA {
976 :     # Get the parameters.
977 :     my ($self, $incomingType, $desiredType, $sequence) = @_;
978 :     # Declare the return variable. If an error occurs, it will remain undefined.
979 :     my $retVal;
980 : parrello 1.11 # This variable will be cleared if an error is detected.
981 :     my $okFlag = 1;
982 : parrello 1.1 # Create variables to hold the FASTA label and data.
983 :     my ($fastaLabel, $fastaData);
984 : parrello 1.11 Trace("FASTA incoming type is $incomingType, desired type is $desiredType.") if T(4);
985 : parrello 1.1 # Check for a feature specification.
986 :     if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
987 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
988 :     # it.
989 :     my $fid = $1;
990 : parrello 1.11 Trace("Feature ID for fasta is $fid.") if T(3);
991 : parrello 1.1 my $sprout = $self->DB();
992 :     # Get the FIG ID. Note that we only use the first feature found. We are not
993 :     # supposed to have redundant aliases, though we may have an ID that doesn't
994 :     # exist.
995 :     my ($figID) = $sprout->FeaturesByAlias($fid);
996 :     if (! $figID) {
997 :     $self->SetMessage("No feature found with the ID \"$fid\".");
998 : parrello 1.11 $okFlag = 0;
999 : parrello 1.1 } else {
1000 :     # Set the FASTA label.
1001 :     my $fastaLabel = $fid;
1002 :     # Now proceed according to the sequence type.
1003 : parrello 1.11 if ($desiredType eq 'prot') {
1004 : parrello 1.1 # We want protein, so get the translation.
1005 :     $fastaData = $sprout->FeatureTranslation($figID);
1006 : parrello 1.11 Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1007 : parrello 1.1 } else {
1008 :     # We want DNA, so get the DNA sequence. This is a two-step process.
1009 :     my @locList = $sprout->FeatureLocation($figID);
1010 :     $fastaData = $sprout->DNASeq(\@locList);
1011 : parrello 1.11 Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1012 : parrello 1.1 }
1013 :     }
1014 : parrello 1.11 } elsif ($incomingType eq 'prot' && $desiredType eq 'dna') {
1015 : parrello 1.1 # Here we're being asked to do an impossible conversion.
1016 :     $self->SetMessage("Cannot convert a protein sequence to DNA.");
1017 : parrello 1.11 $okFlag = 0;
1018 : parrello 1.1 } else {
1019 : parrello 1.11 Trace("Analyzing FASTA sequence.") if T(4);
1020 : parrello 1.1 # Here we are expecting a FASTA. We need to see if there's a label.
1021 : parrello 1.11 if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1022 :     Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1023 : parrello 1.1 # Here we have a label, so we split it from the data.
1024 :     $fastaLabel = $1;
1025 :     $fastaData = $2;
1026 :     } else {
1027 : parrello 1.11 Trace("No label found in match to sequence:\n$sequence") if T(4);
1028 : parrello 1.1 # Here we have no label, so we create one and use the entire sequence
1029 :     # as data.
1030 :     $fastaLabel = "User-specified $incomingType sequence";
1031 :     $fastaData = $sequence;
1032 :     }
1033 :     # The next step is to clean the junk out of the sequence.
1034 :     $fastaData =~ s/\n//g;
1035 :     $fastaData =~ s/\s+//g;
1036 :     # Finally, if the user wants to convert to protein, we do it here. Note that
1037 :     # we've already prevented a conversion from protein to DNA.
1038 :     if ($incomingType ne $desiredType) {
1039 :     $fastaData = Sprout::Protein($fastaData);
1040 : parrello 1.11 # Check for bad characters.
1041 :     if ($fastaData =~ /X/) {
1042 :     $self->SetMessage("Invalid characters detected. Is the input really of type $incomingType?");
1043 :     $okFlag = 0;
1044 :     }
1045 :     } elsif ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {
1046 :     $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");
1047 :     $okFlag = 0;
1048 : parrello 1.1 }
1049 :     }
1050 : parrello 1.11 Trace("FASTA data sequence: $fastaData") if T(4);
1051 :     # Only proceed if no error was detected.
1052 :     if ($okFlag) {
1053 : parrello 1.1 # We need to format the sequence into 60-byte chunks. We use the infamous
1054 :     # grep-split trick. The split, because of the presence of the parentheses,
1055 :     # includes the matched delimiters in the output list. The grep strips out
1056 :     # the empty list items that appear between the so-called delimiters, since
1057 :     # the delimiters are what we want.
1058 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1059 : parrello 1.11 $retVal = join("\n", ">$fastaLabel", @chunks, "");
1060 : parrello 1.1 }
1061 :     # Return the result.
1062 :     return $retVal;
1063 :     }
1064 :    
1065 :     =head3 NmpdrGenomeMenu
1066 :    
1067 : parrello 1.3 C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1068 : parrello 1.1
1069 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1070 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
1071 :     easier to select all genomes from a particular category.
1072 :    
1073 :     =over 4
1074 :    
1075 :     =item menuName
1076 :    
1077 :     Name to give to the menu.
1078 :    
1079 : parrello 1.3 =item multiple
1080 : parrello 1.1
1081 : parrello 1.3 TRUE if the user is allowed to select multiple genomes, else FALSE.
1082 : parrello 1.1
1083 :     =item selected
1084 :    
1085 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
1086 :     is not intended to allow multiple selections, the list should be a singleton. If the
1087 :     list is empty, nothing will be pre-selected.
1088 :    
1089 : parrello 1.3 =item rows (optional)
1090 :    
1091 :     Number of rows to display. If omitted, the default is 1 for a single-select list
1092 :     and 10 for a multi-select list.
1093 :    
1094 : parrello 1.8 =item crossMenu (optional)
1095 :    
1096 :     If specified, is presumed to be the name of another genome menu whose contents
1097 :     are to be mutually exclusive with the contents of this menu. As a result, instead
1098 :     of the standard onChange event, the onChange event will deselect any entries in
1099 :     the other menu.
1100 :    
1101 : parrello 1.1 =item RETURN
1102 :    
1103 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
1104 :    
1105 :     =back
1106 :    
1107 :     =cut
1108 :    
1109 :     sub NmpdrGenomeMenu {
1110 :     # Get the parameters.
1111 : parrello 1.8 my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1112 : parrello 1.1 # Get the Sprout and CGI objects.
1113 :     my $sprout = $self->DB();
1114 :     my $cgi = $self->Q();
1115 : parrello 1.3 # Compute the row count.
1116 :     if (! defined $rows) {
1117 :     $rows = ($multiple ? 10 : 1);
1118 :     }
1119 :     # Create the multiple tag.
1120 :     my $multipleTag = ($multiple ? " multiple" : "");
1121 : parrello 1.1 # Get the form name.
1122 :     my $formName = $self->FormName();
1123 : parrello 1.3 # Check to see if we already have a genome list in memory.
1124 :     my $genomes = $self->{genomeList};
1125 :     my $groupHash;
1126 :     if (defined $genomes) {
1127 :     # We have a list ready to use.
1128 :     $groupHash = $genomes;
1129 :     } else {
1130 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
1131 :     # by name (genus,species,strain), but putting primary-group in front enables us to
1132 :     # take advantage of an existing index.
1133 :     my @genomeList = $sprout->GetAll(['Genome'],
1134 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1135 :     [], ['Genome(primary-group)', 'Genome(id)',
1136 :     'Genome(genus)', 'Genome(species)',
1137 :     'Genome(unique-characterization)']);
1138 :     # Create a hash to organize the genomes by group. Each group will contain a list of
1139 :     # 2-tuples, the first element being the genome ID and the second being the genome
1140 :     # name.
1141 :     my %gHash = ();
1142 :     for my $genome (@genomeList) {
1143 :     # Get the genome data.
1144 :     my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1145 : parrello 1.10 # Compute and cache its name and display group.
1146 :     my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1147 :     $strain);
1148 :     # Push the genome into the group's list. Note that we use the real group
1149 :     # name here, not the display group name.
1150 : parrello 1.3 push @{$gHash{$group}}, [$genomeID, $name];
1151 : parrello 1.1 }
1152 : parrello 1.3 # Save the genome list for future use.
1153 :     $self->{genomeList} = \%gHash;
1154 :     $groupHash = \%gHash;
1155 : parrello 1.1 }
1156 :     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1157 :     # the supporting-genome group last.
1158 : parrello 1.3 my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1159 : parrello 1.1 push @groups, $FIG_Config::otherGroup;
1160 : parrello 1.3 # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1161 :     # with the possibility of undefined values in the incoming list.
1162 :     my %selectedHash = ();
1163 :     if (defined $selected) {
1164 :     %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1165 :     }
1166 : parrello 1.1 # Now it gets complicated. We need a way to mark all the NMPDR genomes.
1167 :     # Create the type counters.
1168 :     my $groupCount = 1;
1169 :     # Compute the ID for the status display.
1170 :     my $divID = "${formName}_${menuName}_status";
1171 :     # Compute the JavaScript call for updating the status.
1172 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
1173 :     # If multiple selection is supported, create an onChange event.
1174 :     my $onChange = "";
1175 : parrello 1.8 if ($cross) {
1176 :     $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1177 :     } elsif ($multiple) {
1178 : parrello 1.1 $onChange = " onChange=\"$showSelect\"";
1179 :     }
1180 :     # Create the SELECT tag and stuff it into the output array.
1181 : parrello 1.3 my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";
1182 : parrello 1.1 my @lines = ($select);
1183 :     # Loop through the groups.
1184 :     for my $group (@groups) {
1185 :     # Create the option group tag.
1186 :     my $tag = "<OPTGROUP label=\"$group\">";
1187 :     push @lines, " $tag";
1188 :     # Compute the label for this group's options. This is seriously dirty stuff, as the
1189 :     # label option may have functionality in future browsers. If that happens, we'll need
1190 :     # to modify the genome text so that the "selectSome" method can tell which are NMPDR
1191 :     # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript
1192 : parrello 1.3 # hierarchy, so we can't use it.
1193 : parrello 1.1 my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");
1194 :     # Get the genomes in the group.
1195 : parrello 1.3 for my $genome (@{$groupHash->{$group}}) {
1196 : parrello 1.1 my ($genomeID, $name) = @{$genome};
1197 :     # See if it's selected.
1198 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
1199 :     # Generate the option tag.
1200 :     my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";
1201 :     push @lines, " $optionTag";
1202 :     }
1203 :     # Close the option group.
1204 :     push @lines, " </OPTGROUP>";
1205 :     }
1206 :     # Close the SELECT tag.
1207 :     push @lines, "</SELECT>";
1208 :     # Check for multiple selection.
1209 : parrello 1.3 if ($multiple) {
1210 :     # Since multi-select is on, we set up some buttons to set and clear selections.
1211 : parrello 1.1 push @lines, "<br />";
1212 :     push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1213 :     push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1214 :     push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";
1215 :     push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";
1216 : parrello 1.3 # Now add the search box. This allows the user to type text and have all genomes containing
1217 :     # the text selected automatically.
1218 :     my $searchThingName = "${menuName}_SearchThing";
1219 :     push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .
1220 :     "<INPUT type=\"button\" name=\"Select\" class=\"button\" value=\"Search\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";
1221 : parrello 1.1 # Add the status display, too.
1222 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1223 :     # Queue to update the status display when the form loads. We need to modify the show statement
1224 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1225 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1226 :     # in case we decide to twiddle the parameters.
1227 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1228 :     $self->QueueFormScript($showSelect);
1229 : parrello 1.3 # Finally, add this parameter to the list of genome parameters. This enables us to
1230 :     # easily find all the parameters used to select one or more genomes.
1231 :     push @{$self->{genomeParms}}, $menuName;
1232 : parrello 1.1 }
1233 :     # Assemble all the lines into a string.
1234 :     my $retVal = join("\n", @lines, "");
1235 :     # Return the result.
1236 :     return $retVal;
1237 :     }
1238 :    
1239 : parrello 1.3 =head3 PropertyMenu
1240 :    
1241 :     C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1242 :    
1243 :     Generate a property name dropdown menu.
1244 :    
1245 :     =over 4
1246 :    
1247 :     =item menuName
1248 :    
1249 :     Name to give to the menu.
1250 :    
1251 :     =item selected
1252 :    
1253 :     Value of the property name to pre-select.
1254 :    
1255 :     =item force (optional)
1256 :    
1257 :     If TRUE, then the user will be forced to choose a property name. If FALSE,
1258 :     then an additional menu choice will be provided to select nothing.
1259 :    
1260 :     =item RETURN
1261 :    
1262 :     Returns a dropdown menu box that allows the user to select a property name. An additional
1263 :     selection entry will be provided for selecting no property name
1264 :    
1265 :     =back
1266 :    
1267 :     =cut
1268 :    
1269 :     sub PropertyMenu {
1270 :     # Get the parameters.
1271 :     my ($self, $menuName, $selected, $force) = @_;
1272 :     # Get the CGI and Sprout objects.
1273 :     my $sprout = $self->DB();
1274 :     my $cgi = $self->Q();
1275 :     # Create the property name list.
1276 :     my @propNames = ();
1277 :     if (! $force) {
1278 :     push @propNames, "";
1279 :     }
1280 :     # Get all the property names, putting them after the null choice if one exists.
1281 :     push @propNames, $sprout->GetChoices('Property', 'property-name');
1282 :     # Create a menu from them.
1283 :     my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1284 :     -default => $selected);
1285 :     # Return the result.
1286 :     return $retVal;
1287 :     }
1288 :    
1289 : parrello 1.1 =head3 MakeTable
1290 :    
1291 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1292 :    
1293 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1294 :     other words, each must have the TR and TD tags included.
1295 :    
1296 :     The purpose of this method is to provide a uniform look for search form tables. It is
1297 :     almost impossible to control a table using styles, so rather than have a table style,
1298 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1299 :     be updated with an explicit width so the forms look pretty when they are all on one
1300 :     page.
1301 :    
1302 :     =over 4
1303 :    
1304 :     =item rows
1305 :    
1306 :     Reference to a list of table rows. Each table row must be in HTML form with all
1307 :     the TR and TD tags set up. The first TD or TH tag in each row will be modified to
1308 :     set the width. Everything else will be left as is.
1309 :    
1310 :     =item RETURN
1311 :    
1312 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1313 :    
1314 :     =back
1315 :    
1316 :     =cut
1317 :    
1318 :     sub MakeTable {
1319 :     # Get the parameters.
1320 :     my ($self, $rows) = @_;
1321 :     # Get the CGI object.
1322 :     my $cgi = $self->Q();
1323 :     # Fix the widths on the first column. Note that we eschew the use of the "g"
1324 :     # modifier becase we only want to change the first tag. Also, if a width
1325 :     # is already specified on the first column bad things will happen.
1326 :     for my $row (@{$rows}) {
1327 :     $row =~ s/(<td|th)/$1 width="150"/i;
1328 :     }
1329 :     # Create the table.
1330 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1331 :     width => 700, class => 'search'},
1332 :     @{$rows});
1333 :     # Return the result.
1334 :     return $retVal;
1335 :     }
1336 :    
1337 :     =head3 SubmitRow
1338 :    
1339 :     C<< my $htmlText = $shelp->SubmitRow(); >>
1340 :    
1341 :     Returns the HTML text for the row containing the page size control
1342 :     and the submit button. All searches should have this row somewhere
1343 :     near the top of the form.
1344 :    
1345 :     =cut
1346 :    
1347 :     sub SubmitRow {
1348 :     # Get the parameters.
1349 :     my ($self) = @_;
1350 :     my $cgi = $self->Q();
1351 : parrello 1.3 # Get the current page size.
1352 :     my $pageSize = $cgi->param('PageSize');
1353 :     # Get the incoming external-link flag.
1354 :     my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1355 :     # Create the row.
1356 : parrello 1.1 my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1357 :     $cgi->td($cgi->popup_menu(-name => 'PageSize',
1358 : parrello 1.7 -values => [10, 25, 50, 100, 1000],
1359 : parrello 1.3 -default => $pageSize) . " " .
1360 :     $cgi->checkbox(-name => 'ShowURL',
1361 :     -value => 1,
1362 :     -label => 'Show URL')),
1363 : parrello 1.1 $cgi->td($cgi->submit(-class => 'goButton',
1364 :     -name => 'Search',
1365 :     -value => 'Go')));
1366 :     # Return the result.
1367 :     return $retVal;
1368 :     }
1369 : parrello 1.2
1370 :     =head3 FeatureFilterRows
1371 :    
1372 :     C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1373 :    
1374 : parrello 1.11 This method creates table rows that can be used to filter features. The form
1375 :     values can be used to select features by genome using the B<FeatureQuery>
1376 :     object.
1377 : parrello 1.2
1378 :     =cut
1379 :    
1380 :     sub FeatureFilterRows {
1381 :     # Get the parameters.
1382 :     my ($self) = @_;
1383 :     # Return the result.
1384 :     return FeatureQuery::FilterRows($self);
1385 :     }
1386 :    
1387 : parrello 1.1 =head3 GBrowseFeatureURL
1388 :    
1389 :     C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
1390 :    
1391 :     Compute the URL required to pull up a Gbrowse page for the the specified feature.
1392 :     In order to do this, we need to pull out the ID of the feature's Genome, its
1393 :     contig ID, and some rough starting and stopping offsets.
1394 :    
1395 :     =over 4
1396 :    
1397 :     =item sprout
1398 :    
1399 :     Sprout object for accessing the database.
1400 :    
1401 :     =item feat
1402 :    
1403 :     ID of the feature whose Gbrowse URL is desired.
1404 :    
1405 :     =item RETURN
1406 :    
1407 :     Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome
1408 :     ID, contig ID, starting offset, and stopping offset.
1409 :    
1410 :     =back
1411 :    
1412 :     =cut
1413 :    
1414 :     sub GBrowseFeatureURL {
1415 :     # Get the parameters.
1416 :     my ($sprout, $feat) = @_;
1417 :     # Declare the return variable.
1418 :     my $retVal;
1419 :     # Compute the genome ID.
1420 :     my ($genomeID) = FIGRules::ParseFeatureID($feat);
1421 :     # Only proceed if the feature ID produces a valid genome.
1422 :     if ($genomeID) {
1423 :     # Get the feature location string.
1424 :     my $loc = $sprout->FeatureLocation($feat);
1425 :     # Compute the contig, start, and stop points.
1426 : parrello 1.6 my($contig, $start, $stop) = BasicLocation::Parse($loc);
1427 : parrello 1.5 Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1428 : parrello 1.1 # Now we need to do some goofiness to insure that the location is not too
1429 :     # big and that we get some surrounding stuff.
1430 :     my $mid = int(($start + $stop) / 2);
1431 :     my $chunk_len = 20000;
1432 :     my $max_feature = 40000;
1433 :     my $feat_len = abs($stop - $start);
1434 :     if ($feat_len > $chunk_len) {
1435 :     if ($feat_len > $max_feature) {
1436 :     $chunk_len = $max_feature;
1437 :     } else {
1438 :     $chunk_len = $feat_len + 100;
1439 :     }
1440 :     }
1441 :     my($show_start, $show_stop);
1442 :     if ($chunk_len == $max_feature) {
1443 :     $show_start = $start - 300;
1444 :     } else {
1445 :     $show_start = $mid - int($chunk_len / 2);
1446 :     }
1447 :     if ($show_start < 1) {
1448 :     $show_start = 1;
1449 :     }
1450 :     $show_stop = $show_start + $chunk_len - 1;
1451 :     my $clen = $sprout->ContigLength($contig);
1452 :     if ($show_stop > $clen) {
1453 :     $show_stop = $clen;
1454 :     }
1455 :     my $seg_id = $contig;
1456 :     $seg_id =~ s/:/--/g;
1457 : parrello 1.5 Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1458 : parrello 1.1 # Assemble all the pieces.
1459 :     $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";
1460 :     }
1461 :     # Return the result.
1462 :     return $retVal;
1463 :     }
1464 :    
1465 : parrello 1.3 =head3 GetGenomes
1466 :    
1467 :     C<< my @genomeList = $shelp->GetGenomes($parmName); >>
1468 :    
1469 :     Return the list of genomes specified by the specified CGI query parameter.
1470 :     If the request method is POST, then the list of genome IDs is returned
1471 :     without preamble. If the request method is GET and the parameter is not
1472 :     specified, then it is treated as a request for all genomes. This makes it
1473 :     easier for web pages to link to a search that wants to specify all genomes.
1474 :    
1475 :     =over 4
1476 :    
1477 :     =item parmName
1478 :    
1479 :     Name of the parameter containing the list of genomes. This will be the
1480 :     first parameter passed to the L</NmpdrGenomeMenu> call that created the
1481 :     genome selection control on the form.
1482 :    
1483 :     =item RETURN
1484 :    
1485 :     Returns a list of the genomes to process.
1486 :    
1487 :     =back
1488 :    
1489 :     =cut
1490 :    
1491 :     sub GetGenomes {
1492 :     # Get the parameters.
1493 :     my ($self, $parmName) = @_;
1494 :     # Get the CGI query object.
1495 :     my $cgi = $self->Q();
1496 :     # Get the list of genome IDs in the request header.
1497 :     my @retVal = $cgi->param($parmName);
1498 :     Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1499 :     # Check for the special GET case.
1500 :     if ($cgi->request_method() eq "GET" && ! @retVal) {
1501 :     # Here the caller wants all the genomes.
1502 :     my $sprout = $self->DB();
1503 :     @retVal = $sprout->Genomes();
1504 :     }
1505 :     # Return the result.
1506 :     return @retVal;
1507 :     }
1508 :    
1509 :     =head3 GetHelpText
1510 :    
1511 :     C<< my $htmlText = $shelp->GetHelpText(); >>
1512 :    
1513 :     Get the help text for this search. The help text is stored in files on the template
1514 :     server. The help text for a specific search is taken from a file named
1515 :     C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1516 :     There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1517 :     feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1518 :     describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1519 :     describes the standard controls for a search, such as page size, URL display, and
1520 :     external alias display.
1521 :    
1522 :     =cut
1523 :    
1524 :     sub GetHelpText {
1525 :     # Get the parameters.
1526 :     my ($self) = @_;
1527 :     # Create a list to hold the pieces of the help.
1528 :     my @helps = ();
1529 :     # Get the template directory URL.
1530 :     my $urlBase = $FIG_Config::template_url;
1531 :     # Start with the specific help.
1532 :     my $class = $self->{class};
1533 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1534 :     # Add the genome control help if needed.
1535 :     if (scalar @{$self->{genomeParms}}) {
1536 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1537 :     }
1538 :     # Next the filter help.
1539 :     if ($self->{filtered}) {
1540 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1541 :     }
1542 :     # Finally, the standard help.
1543 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1544 :     # Assemble the pieces.
1545 :     my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1546 :     # Return the result.
1547 :     return $retVal;
1548 :     }
1549 :    
1550 :     =head3 ComputeSearchURL
1551 :    
1552 :     C<< my $url = $shelp->ComputeSearchURL(); >>
1553 :    
1554 :     Compute the GET-style URL for the current search. In order for this to work, there
1555 :     must be a copy of the search form on the current page. This will always be the
1556 :     case if the search is coming from C<SearchSkeleton.cgi>.
1557 :    
1558 :     A little expense is involved in order to make the URL as smart as possible. The
1559 :     main complication is that if the user specified all genomes, we'll want to
1560 :     remove the parameter entirely from a get-style URL.
1561 :    
1562 :     =cut
1563 :    
1564 :     sub ComputeSearchURL {
1565 :     # Get the parameters.
1566 :     my ($self) = @_;
1567 :     # Get the database and CGI query object.
1568 :     my $cgi = $self->Q();
1569 :     my $sprout = $self->DB();
1570 :     # Start with the full URL.
1571 :     my $retVal = $cgi->url(-full => 1);
1572 :     # Get all the query parameters in a hash.
1573 :     my %parms = $cgi->Vars();
1574 :     # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1575 :     # characters separating the individual values. We have to convert those to lists. In addition,
1576 :     # the multiple-selection genome parameters and the feature type parameter must be checked to
1577 :     # determine whether or not they can be removed from the URL. First, we get a list of the
1578 :     # genome parameters and a list of all genomes. Note that we only need the list if a
1579 :     # multiple-selection genome parameter has been found on the form.
1580 :     my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1581 :     my @genomeList;
1582 :     if (keys %genomeParms) {
1583 :     @genomeList = $sprout->Genomes();
1584 :     }
1585 :     # Create a list to hold the URL parameters we find.
1586 :     my @urlList = ();
1587 :     # Now loop through the parameters in the hash, putting them into the output URL.
1588 :     for my $parmKey (keys %parms) {
1589 :     # Get a list of the parameter values. If there's only one, we'll end up with
1590 :     # a singleton list, but that's okay.
1591 :     my @values = split (/\0/, $parms{$parmKey});
1592 :     # Check for special cases.
1593 : parrello 1.12 if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {
1594 : parrello 1.3 # These are bookkeeping parameters we don't need to start a search.
1595 :     @values = ();
1596 :     } elsif ($parmKey =~ /_SearchThing$/) {
1597 :     # Here the value coming in is from a genome control's search thing. It does
1598 :     # not affect the results of the search, so we clear it.
1599 :     @values = ();
1600 :     } elsif ($genomeParms{$parmKey}) {
1601 :     # Here we need to see if the user wants all the genomes. If he does,
1602 :     # we erase all the values just like with features.
1603 :     my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1604 :     if ($allFlag) {
1605 :     @values = ();
1606 :     }
1607 :     }
1608 :     # If we still have values, create the URL parameters.
1609 :     if (@values) {
1610 :     push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1611 :     }
1612 :     }
1613 :     # Add the parameters to the URL.
1614 :     $retVal .= "?" . join(";", @urlList);
1615 :     # Return the result.
1616 :     return $retVal;
1617 :     }
1618 :    
1619 :     =head3 GetRunTimeValue
1620 :    
1621 :     C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1622 :    
1623 :     Compute a run-time column value.
1624 :    
1625 :     =over 4
1626 :    
1627 :     =item text
1628 :    
1629 :     The run-time column text. It consists of 2 percent signs, a column type, an equal
1630 :     sign, and the data for the current row.
1631 :    
1632 :     =item RETURN
1633 :    
1634 :     Returns the fully-formatted HTML text to go into the current column of the current row.
1635 :    
1636 :     =back
1637 :    
1638 :     =cut
1639 :    
1640 :     sub GetRunTimeValue {
1641 :     # Get the parameters.
1642 :     my ($self, $text) = @_;
1643 :     # Declare the return variable.
1644 :     my $retVal;
1645 :     # Parse the incoming text.
1646 :     if ($text =~ /^%%([^=]+)=(.*)$/) {
1647 :     $retVal = $self->RunTimeColumns($1, $2);
1648 :     } else {
1649 :     Confess("Invalid run-time column string \"$text\" encountered in session file.");
1650 :     }
1651 :     # Return the result.
1652 :     return $retVal;
1653 :     }
1654 :    
1655 : parrello 1.9 =head3 AdvancedClassList
1656 :    
1657 :     C<< my @classes = SearchHelper::AdvancedClassList(); >>
1658 :    
1659 :     Return a list of advanced class names. This list is used to generate the directory
1660 :     of available searches on the search page.
1661 :    
1662 :     The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>
1663 :     script is only able to insert strings into the generated B<FIG_Config> file.
1664 :    
1665 :     =cut
1666 :    
1667 :     sub AdvancedClassList {
1668 :     return split /\s+/, $FIG_Config::advanced_classes;
1669 :     }
1670 :    
1671 : parrello 1.1 =head2 Feature Column Methods
1672 :    
1673 :     The methods in this column manage feature column data. If you want to provide the
1674 :     capability to include new types of data in feature columns, then all the changes
1675 :     are made to this section of the source file. Technically, this should be implemented
1676 :     using object-oriented methods, but this is simpler for non-programmers to maintain.
1677 :     To add a new column of feature data, you must first give it a name. For example,
1678 :     the name for the protein page link column is C<protlink>. If the column is to appear
1679 :     in the default list of feature columns, add it to the list returned by
1680 :     L</DefaultFeatureColumns>. Then add code to produce the column title to
1681 :     L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
1682 :     everything else will happen automatically.
1683 :    
1684 :     There is one special column name syntax for extra columns (that is, nonstandard
1685 :     feature columns). If the column name begins with C<X=>, then it is presumed to be
1686 :     an extra column. The column title is the text after the C<X=>, and its value is
1687 :     pulled from the extra column hash.
1688 :    
1689 :     =head3 DefaultFeatureColumns
1690 :    
1691 :     C<< my $colNames = $shelp->DefaultFeatureColumns(); >>
1692 :    
1693 :     Return a reference to a list of the default feature column identifiers. These
1694 :     identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in
1695 :     order to produce the column titles and row values.
1696 :    
1697 :     =cut
1698 :    
1699 :     sub DefaultFeatureColumns {
1700 :     # Get the parameters.
1701 :     my ($self) = @_;
1702 :     # Return the result.
1703 : parrello 1.4 return ['orgName', 'function', 'gblink', 'protlink',
1704 :     FeatureQuery::AdditionalColumns($self)];
1705 : parrello 1.1 }
1706 :    
1707 :     =head3 FeatureColumnTitle
1708 :    
1709 :     C<< my $title = $shelp->FeatureColumnTitle($colName); >>
1710 :    
1711 :     Return the column heading title to be used for the specified feature column.
1712 :    
1713 :     =over 4
1714 :    
1715 :     =item name
1716 :    
1717 :     Name of the desired feature column.
1718 :    
1719 :     =item RETURN
1720 :    
1721 :     Returns the title to be used as the column header for the named feature column.
1722 :    
1723 :     =back
1724 :    
1725 :     =cut
1726 :    
1727 :     sub FeatureColumnTitle {
1728 :     # Get the parameters.
1729 :     my ($self, $colName) = @_;
1730 :     # Declare the return variable. We default to a blank column name.
1731 :     my $retVal = "&nbsp;";
1732 :     # Process the column name.
1733 :     if ($colName =~ /^X=(.+)$/) {
1734 :     # Here we have an extra column.
1735 :     $retVal = $1;
1736 :     } elsif ($colName eq 'orgName') {
1737 :     $retVal = "Name";
1738 :     } elsif ($colName eq 'fid') {
1739 :     $retVal = "FIG ID";
1740 :     } elsif ($colName eq 'alias') {
1741 :     $retVal = "External Aliases";
1742 :     } elsif ($colName eq 'function') {
1743 :     $retVal = "Functional Assignment";
1744 :     } elsif ($colName eq 'gblink') {
1745 :     $retVal = "GBrowse";
1746 :     } elsif ($colName eq 'protlink') {
1747 :     $retVal = "NMPDR Protein Page";
1748 :     } elsif ($colName eq 'group') {
1749 :     $retVal = "NMDPR Group";
1750 :     }
1751 :     # Return the result.
1752 :     return $retVal;
1753 :     }
1754 :    
1755 :     =head3 FeatureColumnValue
1756 :    
1757 :     C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
1758 :    
1759 :     Return the value to be displayed in the specified feature column.
1760 :    
1761 :     =over 4
1762 :    
1763 :     =item colName
1764 :    
1765 :     Name of the column to be displayed.
1766 :    
1767 :     =item record
1768 :    
1769 :     DBObject record for the feature being displayed in the current row.
1770 :    
1771 :     =item extraCols
1772 :    
1773 :     Reference to a hash of extra column names to values. If the incoming column name
1774 :     begins with C<X=>, its value will be taken from this hash.
1775 :    
1776 :     =item RETURN
1777 :    
1778 :     Returns the HTML to be displayed in the named column for the specified feature.
1779 :    
1780 :     =back
1781 :    
1782 :     =cut
1783 :    
1784 :     sub FeatureColumnValue {
1785 :     # Get the parameters.
1786 :     my ($self, $colName, $record, $extraCols) = @_;
1787 :     # Get the sprout and CGI objects.
1788 :     my $cgi = $self->Q();
1789 :     my $sprout = $self->DB();
1790 :     # Get the feature ID.
1791 :     my ($fid) = $record->Value('Feature(id)');
1792 :     # Declare the return variable. Denote that we default to a non-breaking space,
1793 :     # which will translate to an empty table cell (rather than a table cell with no
1794 :     # interior, which is what you get for a null string).
1795 :     my $retVal = "&nbsp;";
1796 :     # Process according to the column name.
1797 :     if ($colName =~ /^X=(.+)$/) {
1798 :     # Here we have an extra column. Only update if the value exists. Note that
1799 :     # a value of C<undef> is treated as a non-existent value, because the
1800 :     # caller may have put "colName => undef" in the "PutFeature" call in order
1801 :     # to insure we know the extra column exists.
1802 :     if (defined $extraCols->{$1}) {
1803 :     $retVal = $extraCols->{$1};
1804 :     }
1805 :     } elsif ($colName eq 'orgName') {
1806 :     # Here we want the formatted organism name and feature number.
1807 :     $retVal = $self->FeatureName($fid);
1808 :     } elsif ($colName eq 'fid') {
1809 :     # Here we have the raw feature ID. We hyperlink it to the protein page.
1810 :     $retVal = HTML::set_prot_links($fid);
1811 :     } elsif ($colName eq 'alias') {
1812 :     # In this case, the user wants a list of external aliases for the feature.
1813 : parrello 1.3 # These are very expensive, so we compute them when the row is displayed.
1814 :     $retVal = "%%aliases=$fid";
1815 : parrello 1.1 } elsif ($colName eq 'function') {
1816 :     # The functional assignment is just a matter of getting some text.
1817 :     ($retVal) = $record->Value('Feature(assignment)');
1818 :     } elsif ($colName eq 'gblink') {
1819 :     # Here we want a link to the GBrowse page using the official GBrowse button.
1820 :     my $gurl = "GetGBrowse.cgi?fid=$fid";
1821 :     $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },
1822 :     $cgi->img({ src => "../images/button-gbrowse.png",
1823 :     border => 0 })
1824 :     );
1825 :     } elsif ($colName eq 'protlink') {
1826 :     # Here we want a link to the protein page using the official NMPDR button.
1827 :     my $hurl = HTML::fid_link($cgi, $fid, 0, 1);
1828 :     $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },
1829 :     $cgi->img({ src => "../images/button-nmpdr.png",
1830 :     border => 0 })
1831 :     );
1832 :     } elsif ($colName eq 'group') {
1833 :     # Get the NMPDR group name.
1834 :     my (undef, $group) = $self->OrganismData($fid);
1835 :     # Dress it with a URL to the group's main page.
1836 :     my $nurl = $sprout->GroupPageName($group);
1837 :     $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
1838 :     $group);
1839 :     }
1840 :     # Return the result.
1841 :     return $retVal;
1842 :     }
1843 :    
1844 : parrello 1.3 =head3 RunTimeColumns
1845 :    
1846 :     C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
1847 :    
1848 :     Return the HTML text for a run-time column. Run-time columns are evaluated when the
1849 :     list is displayed, rather than when it is generated.
1850 :    
1851 :     =over 4
1852 :    
1853 :     =item type
1854 :    
1855 :     Type of column.
1856 :    
1857 :     =item text
1858 :    
1859 :     Data relevant to this row of the column.
1860 :    
1861 :     =item RETURN
1862 :    
1863 :     Returns the fully-formatted HTML text to go in the specified column.
1864 :    
1865 :     =back
1866 :    
1867 :     =cut
1868 :    
1869 :     sub RunTimeColumns {
1870 :     # Get the parameters.
1871 :     my ($self, $type, $text) = @_;
1872 :     # Declare the return variable.
1873 :     my $retVal = "";
1874 :     # Get the Sprout and CGI objects.
1875 :     my $sprout = $self->DB();
1876 :     my $cgi = $self->Q();
1877 :     # Separate the text into a type and data.
1878 :     if ($type eq 'aliases') {
1879 :     # Here the caller wants external alias links for a feature. The text
1880 :     # is the feature ID.
1881 :     my $fid = $text;
1882 :     # The complicated part is we have to hyperlink them. First, get the
1883 :     # aliases.
1884 :     Trace("Generating aliases for feature $fid.") if T(4);
1885 :     my @aliases = $sprout->FeatureAliases($fid);
1886 :     # Only proceed if we found some.
1887 :     if (@aliases) {
1888 :     # Join the aliases into a comma-delimited list.
1889 :     my $aliasList = join(", ", @aliases);
1890 :     # Ask the HTML processor to hyperlink them.
1891 :     $retVal = HTML::set_prot_links($cgi, $aliasList);
1892 :     }
1893 :     }
1894 :     # Return the result.
1895 :     return $retVal;
1896 :     }
1897 :    
1898 : parrello 1.10 =head3 SaveOrganismData
1899 :    
1900 :     C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
1901 :    
1902 :     Format the name of an organism and the display version of its group name. The incoming
1903 :     data should be the relevant fields from the B<Genome> record in the database. The
1904 :     data will also be stored in the genome cache for later use in posting search results.
1905 :    
1906 :     =over 4
1907 :    
1908 :     =item group
1909 :    
1910 :     Name of the genome's group as it appears in the database.
1911 :    
1912 :     =item genomeID
1913 :    
1914 :     ID of the relevant genome.
1915 :    
1916 :     =item genus
1917 :    
1918 :     Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
1919 :     in the database. In this case, the organism name is derived from the genomeID and the group
1920 :     is automatically the supporting-genomes group.
1921 :    
1922 :     =item species
1923 :    
1924 :     Species of the genome's organism.
1925 :    
1926 :     =item strain
1927 :    
1928 :     Strain of the species represented by the genome.
1929 :    
1930 :     =item RETURN
1931 :    
1932 :     Returns a two-element list. The first element is the formatted genome name. The second
1933 :     element is the display name of the genome's group.
1934 :    
1935 :     =back
1936 :    
1937 :     =cut
1938 :    
1939 :     sub SaveOrganismData {
1940 :     # Get the parameters.
1941 :     my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
1942 :     # Declare the return values.
1943 :     my ($name, $displayGroup);
1944 :     # If the organism does not exist, format an unknown name and a blank group.
1945 :     if (! defined($genus)) {
1946 :     $name = "Unknown Genome $genomeID";
1947 :     $displayGroup = "";
1948 :     } else {
1949 :     # It does exist, so format the organism name.
1950 :     $name = "$genus $species";
1951 :     if ($strain) {
1952 :     $name .= " $strain";
1953 :     }
1954 :     # Compute the display group. This is currently the same as the incoming group
1955 :     # name unless it's the supporting group, which is nulled out.
1956 :     $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
1957 :     }
1958 :     # Cache the group and organism data.
1959 :     my $cache = $self->{orgs};
1960 :     $cache->{$genomeID} = [$name, $displayGroup];
1961 :     # Return the result.
1962 :     return ($name, $displayGroup);
1963 :     }
1964 :    
1965 : parrello 1.4 =head2 Virtual Methods
1966 :    
1967 :     =head3 Form
1968 :    
1969 :     C<< my $html = $shelp->Form(); >>
1970 :    
1971 :     Generate the HTML for a form to request a new search.
1972 :    
1973 :     =head3 Find
1974 :    
1975 :     C<< my $resultCount = $shelp->Find(); >>
1976 :    
1977 :     Conduct a search based on the current CGI query parameters. The search results will
1978 :     be written to the session cache file and the number of results will be
1979 :     returned. If the search parameters are invalid, a result count of C<undef> will be
1980 :     returned and a result message will be stored in this object describing the problem.
1981 :    
1982 :     =head3 Description
1983 :    
1984 :     C<< my $htmlText = $shelp->Description(); >>
1985 :    
1986 :     Return a description of this search. The description is used for the table of contents
1987 :     on the main search tools page. It may contain HTML, but it should be character-level,
1988 :     not block-level, since the description is going to appear in a list.
1989 :    
1990 :     =head3 SortKey
1991 :    
1992 : parrello 1.11 C<< my $key = $shelp->SortKey($fdata); >>
1993 : parrello 1.4
1994 : parrello 1.11 Return the sort key for the specified feature data. The default is to sort by feature name,
1995 : parrello 1.10 floating NMPDR organisms to the top. If a full-text search is used, then the default
1996 :     sort is by relevance followed by feature name. This sort may be overridden by the
1997 :     search class to provide fancier functionality. This method is called by
1998 :     B<PutFeature>, so it is only used for feature searches. A non-feature search
1999 :     would presumably have its own sort logic.
2000 : parrello 1.4
2001 :     =over 4
2002 :    
2003 :     =item record
2004 :    
2005 : parrello 1.11 The C<FeatureData> containing the current feature.
2006 : parrello 1.4
2007 :     =item RETURN
2008 :    
2009 :     Returns a key field that can be used to sort this row in among the results.
2010 :    
2011 :     =back
2012 :    
2013 :     =cut
2014 :    
2015 :     sub SortKey {
2016 :     # Get the parameters.
2017 : parrello 1.11 my ($self, $fdata) = @_;
2018 : parrello 1.4 # Get the feature ID from the record.
2019 : parrello 1.11 my $fid = $fdata->FID();
2020 : parrello 1.4 # Get the group from the feature ID.
2021 :     my $group = $self->FeatureGroup($fid);
2022 :     # Ask the feature query object to form the sort key.
2023 : parrello 1.11 my $retVal = $fdata->SortKey($self, $group);
2024 : parrello 1.4 # Return the result.
2025 :     return $retVal;
2026 :     }
2027 : parrello 1.9
2028 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3