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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (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 : parrello 1.15 In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
117 : parrello 1.2
118 :     =back
119 :    
120 :     =head3 Building a Search Form
121 :    
122 :     All search forms are three-column tables. In general, you want one form
123 :     variable per table row. The first column should contain the label and
124 :     the second should contain the form control for specifying the variable
125 :     value. If the control is wide, you should use C<colspan="2"> to give it
126 :     extra room. B<Do not> specify a width in any of your table cells, as
127 :     width management is handled by this class.
128 :    
129 :     The general code for creating the form should be
130 :    
131 :     sub Form {
132 :     my ($self) = @_;
133 :     # Get the CGI object.
134 :     my $cgi = @self->Q();
135 :     # Start the form.
136 :     my $retVal = $self->FormStart("form title");
137 :     # Assemble the table rows.
138 :     my @rows = ();
139 :     ... push table row Html into @rows ...
140 :     push @rows, $self->SubmitRow();
141 :     ... push more Html into @rows ...
142 :     # Build the table from the rows.
143 :     $retVal .= $self->MakeTable(\@rows);
144 :     # Close the form.
145 :     $retVal .= $self->FormEnd();
146 :     # Return the form Html.
147 :     return $retVal;
148 :     }
149 :    
150 :     Several helper methods are provided for particular purposes.
151 :    
152 :     =over 4
153 :    
154 :     =item 1
155 :    
156 : parrello 1.3 L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
157 :     L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
158 :     name. Note that as an assist to people working with GET-style links, if no
159 :     genomes are specified and the incoming request style is GET, all genomes will
160 :     be returned.
161 : parrello 1.2
162 :     =item 2
163 :    
164 :     L</FeatureFilterRow> formats several rows of controls for filtering features.
165 :     When you start building the code for the L</Find> method, you can use a
166 :     B<FeatureQuery> object to automatically filter each genome's features using
167 :     the values from the filter controls.
168 :    
169 :     =item 3
170 :    
171 :     L</QueueFormScript> allows you to queue JavaScript statements for execution
172 :     after the form is fully generated. If you are using very complicated
173 :     form controls, the L</QueueFormScript> method allows you to perform
174 :     JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
175 :     facility to display a list of the pre-selected genomes.
176 :    
177 :     =back
178 :    
179 : parrello 1.14 If you are doing a feature search, you can also change the list of feature
180 :     columns displayed and their display order by overriding
181 :     L</DefaultFeatureColumns>.
182 :    
183 : parrello 1.2 Finally, when generating the code for your controls, be sure to use any incoming
184 :     query parameters as default values so that the search request is persistent.
185 :    
186 :     =head3 Finding Search Results
187 :    
188 :     The L</Find> method is used to create the search results. For a search that
189 :     wants to return features (which is most of them), the basic code structure
190 :     would work as follows. It is assumed that the L</FeatureFilterRows> method
191 :     has been used to create feature filtering parameters.
192 :    
193 :     sub Find {
194 :     my ($self) = @_;
195 :     # Get the CGI and Sprout objects.
196 :     my $cgi = $self->Q();
197 :     my $sprout = $self->DB();
198 :     # Declare the return variable. If it remains undefined, the caller will
199 :     # know that an error occurred.
200 :     my $retVal;
201 :     ... validate the parameters ...
202 :     if (... invalid parameters...) {
203 :     $self->SetMessage(...appropriate message...);
204 :     } elsif (FeatureQuery::Valid($self)) {
205 :     # Initialize the session file.
206 :     $self->OpenSession();
207 :     # Initialize the result counter.
208 :     $retVal = 0;
209 :     ... get a list of genomes ...
210 :     for my $genomeID (... each genome ...) {
211 :     my $fq = FeatureQuery->new($self, $genomeID);
212 :     while (my $feature = $fq->Fetch()) {
213 :     ... examine the feature ...
214 :     if (... we want to keep it ...) {
215 :     $self->PutFeature($fq);
216 :     $retVal++;
217 :     }
218 :     }
219 :     }
220 : parrello 1.9 # Close the session file.
221 :     $self->CloseSession();
222 : parrello 1.2 }
223 :     # Return the result count.
224 :     return $retVal;
225 :     }
226 :    
227 :     A Find method is of course much more complicated than generating a form, and there
228 : parrello 1.14 are variations on the above theme. For example, you could eschew feature filtering
229 : parrello 1.2 entirely in favor of your own custom filtering, you could include extra columns
230 :     in the output, or you could search for something that's not a feature at all. The
231 :     above code is just a loose framework.
232 :    
233 :     If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
234 :     method of the feature query object.
235 :    
236 :     $fq->AddExtraColumns(score => $sc);
237 :    
238 :     The L</Find> method must return C<undef> if the search parameters are invalid. If this
239 :     is the case, then a message describing the problem should be passed to the framework
240 :     by calling L</SetMessage>. If the parameters are valid, then the method must return
241 :     the number of items found.
242 :    
243 : parrello 1.1 =cut
244 :    
245 :     # This counter is used to insure every form on the page has a unique name.
246 :     my $formCount = 0;
247 : parrello 1.16 # This counter is used to generate unique DIV IDs.
248 :     my $divCount = 0;
249 : parrello 1.1
250 :     =head2 Public Methods
251 :    
252 :     =head3 new
253 :    
254 :     C<< my $shelp = SearchHelper->new($query); >>
255 :    
256 :     Construct a new SearchHelper object.
257 :    
258 :     =over 4
259 :    
260 :     =item query
261 :    
262 :     The CGI query object for the current script.
263 :    
264 :     =back
265 :    
266 :     =cut
267 :    
268 :     sub new {
269 :     # Get the parameters.
270 :     my ($class, $query) = @_;
271 :     # Check for a session ID.
272 :     my $session_id = $query->param("SessionID");
273 :     my $type = "old";
274 :     if (! $session_id) {
275 :     # Here we're starting a new session. We create the session ID and
276 :     # store it in the query object.
277 :     $session_id = NewSessionID();
278 :     $type = "new";
279 :     $query->param(-name => 'SessionID', -value => $session_id);
280 :     }
281 :     # Compute the subclass name.
282 :     $class =~ /SH(.+)$/;
283 :     my $subClass = $1;
284 :     # Insure everybody knows we're in Sprout mode.
285 :     $query->param(-name => 'SPROUT', -value => 1);
286 :     # Generate the form name.
287 :     my $formName = "$class$formCount";
288 :     $formCount++;
289 :     # Create the shelp object. It contains the query object (with the session ID)
290 :     # as well as an indicator as to whether or not the session is new, plus the
291 : parrello 1.2 # class name and a placeholder for the Sprout object.
292 : parrello 1.1 my $retVal = {
293 :     query => $query,
294 :     type => $type,
295 :     class => $subClass,
296 : parrello 1.2 sprout => undef,
297 : parrello 1.1 orgs => {},
298 :     name => $formName,
299 :     scriptQueue => [],
300 : parrello 1.3 genomeList => undef,
301 :     genomeParms => [],
302 :     filtered => 0,
303 : parrello 1.1 };
304 :     # Bless and return it.
305 :     bless $retVal, $class;
306 :     return $retVal;
307 :     }
308 :    
309 :     =head3 Q
310 :    
311 :     C<< my $query = $shelp->Q(); >>
312 :    
313 :     Return the CGI query object.
314 :    
315 :     =cut
316 :    
317 :     sub Q {
318 :     # Get the parameters.
319 :     my ($self) = @_;
320 :     # Return the result.
321 :     return $self->{query};
322 :     }
323 :    
324 : parrello 1.9
325 :    
326 : parrello 1.1 =head3 DB
327 :    
328 :     C<< my $sprout = $shelp->DB(); >>
329 :    
330 :     Return the Sprout database object.
331 :    
332 :     =cut
333 :    
334 :     sub DB {
335 :     # Get the parameters.
336 :     my ($self) = @_;
337 : parrello 1.2 # Insure we have a database.
338 :     my $retVal = $self->{sprout};
339 :     if (! defined $retVal) {
340 :     $retVal = SFXlate->new_sprout_only();
341 :     $self->{sprout} = $retVal;
342 :     }
343 : parrello 1.1 # Return the result.
344 : parrello 1.2 return $retVal;
345 : parrello 1.1 }
346 :    
347 :     =head3 IsNew
348 :    
349 :     C<< my $flag = $shelp->IsNew(); >>
350 :    
351 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
352 :     session already has search results ready to process.
353 :    
354 :     =cut
355 :    
356 :     sub IsNew {
357 :     # Get the parameters.
358 :     my ($self) = @_;
359 :     # Return the result.
360 :     return ($self->{type} eq 'new');
361 :     }
362 :    
363 :     =head3 ID
364 :    
365 :     C<< my $sessionID = $shelp->ID(); >>
366 :    
367 :     Return the current session ID.
368 :    
369 :     =cut
370 :    
371 :     sub ID {
372 :     # Get the parameters.
373 :     my ($self) = @_;
374 :     # Return the result.
375 :     return $self->Q()->param("SessionID");
376 :     }
377 :    
378 :     =head3 FormName
379 :    
380 :     C<< my $name = $shelp->FormName(); >>
381 :    
382 :     Return the name of the form this helper object will generate.
383 :    
384 :     =cut
385 :    
386 :     sub FormName {
387 :     # Get the parameters.
388 :     my ($self) = @_;
389 :     # Return the result.
390 :     return $self->{name};
391 :     }
392 :    
393 :     =head3 QueueFormScript
394 :    
395 :     C<< $shelp->QueueFormScript($statement); >>
396 :    
397 :     Add the specified statement to the queue of JavaScript statements that are to be
398 :     executed when the form has been fully defined. This is necessary because until
399 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
400 :     name. When generating the statement, you can refer to the variable C<thisForm>
401 :     in order to reference the form in progress. Thus,
402 :    
403 :     thisForm.simLimit.value = 1e-10;
404 :    
405 :     would set the value of the form element C<simLimit> in the current form to
406 :     C<1e-10>.
407 :    
408 :     =over 4
409 :    
410 :     =item statement
411 :    
412 :     JavaScript statement to be queued for execution after the form is built.
413 :     The trailing semi-colon is required. Theoretically, you could include
414 :     multiple statements separated by semi-colons, but one at a time works
415 :     just as well.
416 :    
417 :     =back
418 :    
419 :     =cut
420 :    
421 :     sub QueueFormScript {
422 :     # Get the parameters.
423 :     my ($self, $statement) = @_;
424 :     # Push the statement onto the script queue.
425 :     push @{$self->{scriptQueue}}, $statement;
426 :     }
427 :    
428 :     =head3 FormStart
429 :    
430 :     C<< my $html = $shelp->FormStart($title); >>
431 :    
432 :     Return the initial section of a form designed to perform another search of the
433 :     same type. The form header is included along with hidden fields to persist the
434 :     tracing, sprout status, and search class.
435 :    
436 :     A call to L</FormEnd> is required to close the form.
437 :    
438 :     =over 4
439 :    
440 :     =item title
441 :    
442 :     Title to be used for the form.
443 :    
444 :     =item RETURN
445 :    
446 :     Returns the initial HTML for the search form.
447 :    
448 :     =back
449 :    
450 :     =cut
451 :    
452 :     sub FormStart {
453 :     # Get the parameters.
454 :     my ($self, $title) = @_;
455 :     # Get the CGI object.
456 :     my $cgi = $self->Q();
457 :     # Start the form.
458 :     my $retVal = "<div class=\"search\">\n" .
459 :     $cgi->start_form(-method => 'POST',
460 :     -action => $cgi->url(-relative => 1),
461 :     -name => $self->FormName()) .
462 :     $cgi->hidden(-name => 'Class',
463 :     -value => $self->{class}) .
464 :     $cgi->hidden(-name => 'SPROUT',
465 :     -value => 1) .
466 :     $cgi->h3($title);
467 :     # If tracing is on, add it to the form.
468 :     if ($cgi->param('Trace')) {
469 :     $retVal .= $cgi->hidden(-name => 'Trace',
470 :     -value => $cgi->param('Trace')) .
471 :     $cgi->hidden(-name => 'TF',
472 :     -value => ($cgi->param('TF') ? 1 : 0));
473 :     }
474 :     # Put in an anchor tag in case there's a table of contents.
475 :     my $anchorName = $self->FormName();
476 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
477 :     # Return the result.
478 :     return $retVal;
479 :     }
480 :    
481 :     =head3 FormEnd
482 :    
483 :     C<< my $htmlText = $shelp->FormEnd(); >>
484 :    
485 :     Return the HTML text for closing a search form. This closes both the C<form> and
486 :     C<div> tags.
487 :    
488 :     =cut
489 :    
490 :     sub FormEnd {
491 :     # Get the parameters.
492 :     my ($self) = @_;
493 :     # Declare the return variable, closing the form and the DIV block.
494 :     my $retVal = "</form></div>\n";
495 :     # Now we flush out the statement queue.
496 :     my @statements = @{$self->{scriptQueue}};
497 :     if (@statements > 0) {
498 :     # Switch to JavaScript and set the "thisForm" variable.
499 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
500 :     " thisForm = document.$self->{name};\n";
501 :     # Unroll the statements.
502 :     while (@statements > 0) {
503 :     my $statement = shift @statements;
504 :     $retVal .= " $statement\n";
505 :     }
506 :     # Close the JavaScript.
507 :     $retVal .= "</SCRIPT>\n";
508 :     }
509 :     # Return the result.
510 :     return $retVal;
511 :     }
512 :    
513 :     =head3 SetMessage
514 :    
515 :     C<< $shelp->SetMessage($msg); >>
516 :    
517 :     Store the specified text as the result message. The result message is displayed
518 :     if an invalid parameter value is specified.
519 :    
520 :     =over 4
521 :    
522 :     =item msg
523 :    
524 :     Text of the result message to be displayed.
525 :    
526 :     =back
527 :    
528 :     =cut
529 :    
530 :     sub SetMessage {
531 :     # Get the parameters.
532 :     my ($self, $msg) = @_;
533 :     # Store the message.
534 :     $self->{message} = $msg;
535 :     }
536 :    
537 :     =head3 Message
538 :    
539 :     C<< my $text = $shelp->Message(); >>
540 :    
541 :     Return the result message. The result message is displayed if an invalid parameter
542 :     value is specified.
543 :    
544 :     =cut
545 :    
546 :     sub Message {
547 :     # Get the parameters.
548 :     my ($self) = @_;
549 :     # Return the result.
550 :     return $self->{message};
551 :     }
552 :    
553 :     =head3 OpenSession
554 :    
555 :     C<< $shelp->OpenSession(); >>
556 :    
557 :     Set up to open the session cache file for writing. Note we don't actually
558 :     open the file until after we know the column headers.
559 :    
560 :     =cut
561 :    
562 :     sub OpenSession {
563 :     # Get the parameters.
564 :     my ($self) = @_;
565 :     # Denote we have not yet written out the column headers.
566 :     $self->{cols} = undef;
567 :     }
568 :    
569 :     =head3 GetCacheFileName
570 :    
571 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
572 :    
573 :     Return the name to be used for this session's cache file.
574 :    
575 :     =cut
576 :    
577 :     sub GetCacheFileName {
578 :     # Get the parameters.
579 :     my ($self) = @_;
580 :     # Return the result.
581 :     return $self->GetTempFileName('cache');
582 :     }
583 :    
584 :     =head3 GetTempFileName
585 :    
586 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
587 :    
588 :     Return the name to be used for a temporary file of the specified type. The
589 :     name is computed from the session name with the type as a suffix.
590 :    
591 :     =over 4
592 :    
593 :     =item type
594 :    
595 :     Type of temporary file to be generated.
596 :    
597 :     =item RETURN
598 :    
599 :     Returns a file name generated from the session name and the specified type.
600 :    
601 :     =back
602 :    
603 :     =cut
604 :    
605 :     sub GetTempFileName {
606 :     # Get the parameters.
607 :     my ($self, $type) = @_;
608 :     # Compute the file name. Note it gets stuffed in the FIG temporary
609 :     # directory.
610 :     my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";
611 :     # Return the result.
612 :     return $retVal;
613 :     }
614 :    
615 :     =head3 PutFeature
616 :    
617 : parrello 1.11 C<< $shelp->PutFeature($fdata); >>
618 : parrello 1.1
619 :     Store a feature in the result cache. This is the workhorse method for most
620 :     searches, since the primary data item in the database is features.
621 :    
622 :     For each feature, there are certain columns that are standard: the feature name, the
623 :     GBrowse and protein page links, the functional assignment, and so forth. If additional
624 : parrello 1.2 columns are required by a particular search subclass, they should be stored in
625 :     the feature query object using the B<AddExtraColumns> method. For example, the following
626 :     code adds columns for essentiality and virulence.
627 : parrello 1.1
628 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
629 :     $shelp->PutFeature($fd);
630 : parrello 1.1
631 :     For correct results, all values should be specified for all extra columns in all calls to
632 :     B<PutFeature>. (In particular, the column header names are computed on the first
633 :     call.) If a column is to be blank for the current feature, its value can be given
634 :     as C<undef>.
635 :    
636 :     if (! $essentialFlag) {
637 :     $essentialFlag = undef;
638 :     }
639 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
640 :     $shelp->PutFeature($fd);
641 : parrello 1.1
642 :     =over 4
643 :    
644 : parrello 1.11 =item fdata
645 : parrello 1.1
646 : parrello 1.11 B<FeatureData> object containing the current feature data.
647 : parrello 1.1
648 :     =back
649 :    
650 :     =cut
651 :    
652 :     sub PutFeature {
653 : parrello 1.2 # Get the parameters.
654 : parrello 1.11 my ($self, $fd) = @_;
655 : parrello 1.3 # Get the CGI query object.
656 :     my $cgi = $self->Q();
657 : parrello 1.2 # Get the feature data.
658 : parrello 1.11 my $record = $fd->Feature();
659 :     my $extraCols = $fd->ExtraCols();
660 : parrello 1.1 # Check for a first-call situation.
661 :     if (! defined $self->{cols}) {
662 : parrello 1.14 Trace("Setting up the columns.") if T(3);
663 :     # Here we need to set up the column information. Start with the extras,
664 :     # sorted by column name.
665 :     my @colNames = ();
666 : parrello 1.2 for my $col (sort keys %{$extraCols}) {
667 : parrello 1.14 push @colNames, "X=$col";
668 : parrello 1.1 }
669 : parrello 1.14 # Add the default columns.
670 :     push @colNames, $self->DefaultFeatureColumns();
671 :     # Add any additional columns requested by the feature filter.
672 :     push @colNames, FeatureQuery::AdditionalColumns($self);
673 :     # Save the full list.
674 :     $self->{cols} = \@colNames;
675 : parrello 1.1 # Write out the column headers. This also prepares the cache file to receive
676 :     # output.
677 :     $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
678 :     }
679 :     # Get the feature ID.
680 : parrello 1.11 my $fid = $fd->FID();
681 : parrello 1.1 # Loop through the column headers, producing the desired data.
682 :     my @output = ();
683 :     for my $colName (@{$self->{cols}}) {
684 : parrello 1.2 push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
685 : parrello 1.1 }
686 : parrello 1.9 # Compute the sort key. The sort key usually floats NMPDR organism features to the
687 : parrello 1.1 # top of the return list.
688 : parrello 1.11 my $key = $self->SortKey($fd);
689 : parrello 1.1 # Write the feature data.
690 :     $self->WriteColumnData($key, @output);
691 :     }
692 :    
693 :     =head3 WriteColumnHeaders
694 :    
695 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
696 :    
697 :     Write out the column headers for the current search session. The column headers
698 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
699 :     the handle saved.
700 :    
701 :     =over 4
702 :    
703 :     =item colNames
704 :    
705 :     A list of column names in the desired presentation order.
706 :    
707 :     =back
708 :    
709 :     =cut
710 :    
711 :     sub WriteColumnHeaders {
712 :     # Get the parameters.
713 :     my ($self, @colNames) = @_;
714 :     # Get the cache file name and open it for output.
715 :     my $fileName = $self->GetCacheFileName();
716 :     my $handle1 = Open(undef, ">$fileName");
717 :     # Write the column headers and close the file.
718 :     Tracer::PutLine($handle1, \@colNames);
719 :     close $handle1;
720 :     # Now open the sort pipe and save the file handle. Note how we append the
721 :     # sorted data to the column header row already in place. The output will
722 :     # contain a sort key followed by the real columns. The sort key is
723 :     # hacked off before going to the output file.
724 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
725 :     }
726 :    
727 :     =head3 WriteColumnData
728 :    
729 :     C<< $shelp->WriteColumnData($key, @colValues); >>
730 :    
731 :     Write a row of column values to the current search session. It is assumed that
732 :     the session file is already open for output.
733 :    
734 :     =over 4
735 :    
736 :     =item key
737 :    
738 :     Sort key.
739 :    
740 :     =item colValues
741 :    
742 :     List of column values to write to the search result cache file for this session.
743 :    
744 :     =back
745 :    
746 :     =cut
747 :    
748 :     sub WriteColumnData {
749 :     # Get the parameters.
750 :     my ($self, $key, @colValues) = @_;
751 :     # Write them to the cache file.
752 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
753 :     }
754 :    
755 :     =head3 CloseSession
756 :    
757 :     C<< $shelp->CloseSession(); >>
758 :    
759 :     Close the session file.
760 :    
761 :     =cut
762 :    
763 :     sub CloseSession {
764 :     # Get the parameters.
765 :     my ($self) = @_;
766 :     # Check for an open session file.
767 :     if (defined $self->{fileHandle}) {
768 :     # We found one, so close it.
769 : parrello 1.9 Trace("Closing session file.") if T(2);
770 : parrello 1.1 close $self->{fileHandle};
771 :     }
772 :     }
773 :    
774 :     =head3 NewSessionID
775 :    
776 :     C<< my $id = SearchHelpers::NewSessionID(); >>
777 :    
778 :     Generate a new session ID for the current user.
779 :    
780 :     =cut
781 :    
782 :     sub NewSessionID {
783 :     # Declare the return variable.
784 :     my $retVal;
785 :     # Get a digest encoder.
786 :     my $md5 = Digest::MD5->new();
787 : parrello 1.4 # Add the PID, the IP, and the time stamp. Note that the time stamp is
788 :     # actually two numbers, and we get them both because we're in list
789 :     # context.
790 :     $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
791 :     # Hash up all this identifying data.
792 :     $retVal = $md5->hexdigest();
793 :     # Return the result.
794 : parrello 1.1 return $retVal;
795 :     }
796 :    
797 :     =head3 OrganismData
798 :    
799 :     C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
800 :    
801 :     Return the name and status of the organism corresponding to the specified genome ID.
802 :     For performance reasons, this information is cached in a special hash table, so we
803 :     only compute it once per run.
804 :    
805 :     =over 4
806 :    
807 :     =item genomeID
808 :    
809 :     ID of the genome whose name is desired.
810 :    
811 :     =item RETURN
812 :    
813 :     Returns a list of two items. The first item in the list is the organism name,
814 :     and the second is the name of the NMPDR group, or an empty string if the
815 :     organism is not in an NMPDR group.
816 :    
817 :     =back
818 :    
819 :     =cut
820 :    
821 :     sub OrganismData {
822 :     # Get the parameters.
823 :     my ($self, $genomeID) = @_;
824 :     # Declare the return variables.
825 :     my ($orgName, $group);
826 :     # Check the cache.
827 :     my $cache = $self->{orgs};
828 :     if (exists $cache->{$genomeID}) {
829 :     ($orgName, $group) = @{$cache->{$genomeID}};
830 :     } else {
831 :     # Here we have to use the database.
832 :     my $sprout = $self->DB();
833 :     my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,
834 :     ['Genome(genus)', 'Genome(species)',
835 :     'Genome(unique-characterization)',
836 :     'Genome(primary-group)']);
837 : parrello 1.10 # Format and cache the name and display group.
838 :     ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
839 :     $strain);
840 : parrello 1.1 }
841 :     # Return the result.
842 :     return ($orgName, $group);
843 :     }
844 :    
845 :     =head3 Organism
846 :    
847 :     C<< my $orgName = $shelp->Organism($genomeID); >>
848 :    
849 :     Return the name of the relevant organism. The name is computed from the genus,
850 :     species, and unique characterization. A cache is used to improve performance.
851 :    
852 :     =over 4
853 :    
854 :     =item genomeID
855 :    
856 :     ID of the genome whose name is desired.
857 :    
858 :     =item RETURN
859 :    
860 :     Returns the display name of the specified organism.
861 :    
862 :     =back
863 :    
864 :     =cut
865 :    
866 :     sub Organism {
867 :     # Get the parameters.
868 :     my ($self, $genomeID) = @_;
869 :     # Get the organism data.
870 :     my ($retVal, $group) = $self->OrganismData($genomeID);
871 :     # Return the result.
872 :     return $retVal;
873 :     }
874 :    
875 :     =head3 FeatureGroup
876 :    
877 :     C<< my $groupName = $shelp->FeatureGroup($fid); >>
878 :    
879 :     Return the group name for the specified feature.
880 :    
881 :     =over 4
882 :    
883 :     =item fid
884 :    
885 :     ID of the relevant feature.
886 :    
887 :     =item RETURN
888 :    
889 :     Returns the name of the NMPDR group to which the feature belongs, or an empty
890 :     string if it is not part of an NMPDR group.
891 :    
892 :     =back
893 :    
894 :     =cut
895 :    
896 :     sub FeatureGroup {
897 :     # Get the parameters.
898 :     my ($self, $fid) = @_;
899 :     # Parse the feature ID to get the genome ID.
900 :     my ($genomeID) = FIGRules::ParseFeatureID($fid);
901 :     # Get the organism data.
902 :     my (undef, $retVal) = $self->OrganismData($genomeID);
903 :     # Return the result.
904 :     return $retVal;
905 :     }
906 :    
907 :     =head3 FeatureName
908 :    
909 :     C<< my $fidName = $shelp->FeatureName($fid); >>
910 :    
911 :     Return the display name of the specified feature.
912 :    
913 :     =over 4
914 :    
915 :     =item fid
916 :    
917 :     ID of the feature whose name is desired.
918 :    
919 :     =item RETURN
920 :    
921 :     A displayable feature name, consisting of the organism name plus some feature
922 :     type and location information.
923 :    
924 :     =back
925 :    
926 :     =cut
927 :    
928 :     sub FeatureName {
929 :     # Get the parameters.
930 :     my ($self, $fid) = @_;
931 :     # Declare the return variable
932 :     my $retVal;
933 :     # Parse the feature ID.
934 :     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);
935 :     if (! defined $genomeID) {
936 :     # Here the feature ID has an invalid format.
937 :     $retVal = "External: $fid";
938 :     } else {
939 :     # Here we can get its genome data.
940 :     $retVal = $self->Organism($genomeID);
941 : parrello 1.4 # Append the FIG ID.
942 :     $retVal .= " [$fid]";
943 : parrello 1.1 }
944 :     # Return the result.
945 :     return $retVal;
946 :     }
947 :    
948 :     =head3 ComputeFASTA
949 :    
950 :     C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>
951 :    
952 :     Parse a sequence input and convert it into a FASTA string of the desired type. Note
953 :     that it is possible to convert a DNA sequence into a protein sequence, but the reverse
954 :     is not possible.
955 :    
956 :     =over 4
957 :    
958 :     =item incomingType
959 :    
960 :     C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.
961 :    
962 :     =item desiredType
963 :    
964 :     C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the
965 :     I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.
966 :    
967 :     =item sequence
968 :    
969 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
970 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
971 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
972 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
973 :     line will be provided.
974 :    
975 :     =item RETURN
976 :    
977 :     Returns a string in FASTA format representing the content of the desired sequence with
978 :     an appropriate label. If the input is invalid, a message will be stored and we will
979 :     return C<undef>. Note that the output will include a trailing new-line.
980 :    
981 :     =back
982 :    
983 :     =cut
984 :    
985 :     sub ComputeFASTA {
986 :     # Get the parameters.
987 :     my ($self, $incomingType, $desiredType, $sequence) = @_;
988 :     # Declare the return variable. If an error occurs, it will remain undefined.
989 :     my $retVal;
990 : parrello 1.11 # This variable will be cleared if an error is detected.
991 :     my $okFlag = 1;
992 : parrello 1.1 # Create variables to hold the FASTA label and data.
993 :     my ($fastaLabel, $fastaData);
994 : parrello 1.11 Trace("FASTA incoming type is $incomingType, desired type is $desiredType.") if T(4);
995 : parrello 1.1 # Check for a feature specification.
996 :     if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
997 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
998 :     # it.
999 :     my $fid = $1;
1000 : parrello 1.11 Trace("Feature ID for fasta is $fid.") if T(3);
1001 : parrello 1.1 my $sprout = $self->DB();
1002 :     # Get the FIG ID. Note that we only use the first feature found. We are not
1003 :     # supposed to have redundant aliases, though we may have an ID that doesn't
1004 :     # exist.
1005 :     my ($figID) = $sprout->FeaturesByAlias($fid);
1006 :     if (! $figID) {
1007 : parrello 1.17 $self->SetMessage("No gene found with the ID \"$fid\".");
1008 : parrello 1.11 $okFlag = 0;
1009 : parrello 1.1 } else {
1010 :     # Set the FASTA label.
1011 :     my $fastaLabel = $fid;
1012 :     # Now proceed according to the sequence type.
1013 : parrello 1.11 if ($desiredType eq 'prot') {
1014 : parrello 1.1 # We want protein, so get the translation.
1015 :     $fastaData = $sprout->FeatureTranslation($figID);
1016 : parrello 1.11 Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1017 : parrello 1.1 } else {
1018 :     # We want DNA, so get the DNA sequence. This is a two-step process.
1019 :     my @locList = $sprout->FeatureLocation($figID);
1020 :     $fastaData = $sprout->DNASeq(\@locList);
1021 : parrello 1.11 Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1022 : parrello 1.1 }
1023 :     }
1024 : parrello 1.11 } elsif ($incomingType eq 'prot' && $desiredType eq 'dna') {
1025 : parrello 1.1 # Here we're being asked to do an impossible conversion.
1026 :     $self->SetMessage("Cannot convert a protein sequence to DNA.");
1027 : parrello 1.11 $okFlag = 0;
1028 : parrello 1.1 } else {
1029 : parrello 1.11 Trace("Analyzing FASTA sequence.") if T(4);
1030 : parrello 1.1 # Here we are expecting a FASTA. We need to see if there's a label.
1031 : parrello 1.11 if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1032 :     Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1033 : parrello 1.1 # Here we have a label, so we split it from the data.
1034 :     $fastaLabel = $1;
1035 :     $fastaData = $2;
1036 :     } else {
1037 : parrello 1.11 Trace("No label found in match to sequence:\n$sequence") if T(4);
1038 : parrello 1.1 # Here we have no label, so we create one and use the entire sequence
1039 :     # as data.
1040 :     $fastaLabel = "User-specified $incomingType sequence";
1041 :     $fastaData = $sequence;
1042 :     }
1043 :     # The next step is to clean the junk out of the sequence.
1044 :     $fastaData =~ s/\n//g;
1045 :     $fastaData =~ s/\s+//g;
1046 :     # Finally, if the user wants to convert to protein, we do it here. Note that
1047 :     # we've already prevented a conversion from protein to DNA.
1048 :     if ($incomingType ne $desiredType) {
1049 :     $fastaData = Sprout::Protein($fastaData);
1050 : parrello 1.11 # Check for bad characters.
1051 :     if ($fastaData =~ /X/) {
1052 :     $self->SetMessage("Invalid characters detected. Is the input really of type $incomingType?");
1053 :     $okFlag = 0;
1054 :     }
1055 :     } elsif ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {
1056 :     $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");
1057 :     $okFlag = 0;
1058 : parrello 1.1 }
1059 :     }
1060 : parrello 1.11 Trace("FASTA data sequence: $fastaData") if T(4);
1061 :     # Only proceed if no error was detected.
1062 :     if ($okFlag) {
1063 : parrello 1.1 # We need to format the sequence into 60-byte chunks. We use the infamous
1064 :     # grep-split trick. The split, because of the presence of the parentheses,
1065 :     # includes the matched delimiters in the output list. The grep strips out
1066 :     # the empty list items that appear between the so-called delimiters, since
1067 :     # the delimiters are what we want.
1068 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1069 : parrello 1.11 $retVal = join("\n", ">$fastaLabel", @chunks, "");
1070 : parrello 1.1 }
1071 :     # Return the result.
1072 :     return $retVal;
1073 :     }
1074 :    
1075 : parrello 1.16 =head3 SubsystemTree
1076 :    
1077 :     C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1078 :    
1079 :     This method creates a subsystem selection tree suitable for passing to
1080 :     L</SelectionTree>. Each leaf node in the tree will have a link to the
1081 :     subsystem display page. In addition, each node can have a radio button. The
1082 :     radio button alue is either C<classification=>I<string>, where I<string> is
1083 :     a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1084 :     Thus, it can either be used to filter by a group of related subsystems or a
1085 :     single subsystem.
1086 :    
1087 :     =over 4
1088 :    
1089 :     =item sprout
1090 :    
1091 :     Sprout database object used to get the list of subsystems.
1092 :    
1093 :     =item options
1094 :    
1095 :     Hash containing options for building the tree.
1096 :    
1097 :     =item RETURN
1098 :    
1099 :     Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1100 :    
1101 :     =back
1102 :    
1103 :     The supported options are as follows.
1104 :    
1105 :     =over 4
1106 :    
1107 :     =item radio
1108 :    
1109 :     TRUE if the tree should be configured for radio buttons. The default is FALSE.
1110 :    
1111 :     =item links
1112 :    
1113 :     TRUE if the tree should be configured for links. The default is TRUE.
1114 :    
1115 :     =back
1116 :    
1117 :     =cut
1118 :    
1119 :     sub SubsystemTree {
1120 :     # Get the parameters.
1121 :     my ($sprout, %options) = @_;
1122 :     # Process the options.
1123 :     my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1124 :     # Read in the subsystems.
1125 :     my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1126 :     ['Subsystem(classification)', 'Subsystem(id)']);
1127 :     # Declare the return variable.
1128 :     my @retVal = ();
1129 :     # Each element in @subs represents a leaf node, so as we loop through it we will be
1130 :     # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1131 :     # first element is a semi-colon-delimited list of the classifications for the
1132 :     # subsystem. There will be a stack of currently-active classifications, which we will
1133 :     # compare to the incoming classifications from the end backward. A new classification
1134 :     # requires starting a new branch. A different classification requires closing an old
1135 :     # branch and starting a new one. Each classification in the stack will also contain
1136 :     # that classification's current branch. We'll add a fake classification at the
1137 :     # beginning that we can use to represent the tree as a whole.
1138 :     my $rootName = '<root>';
1139 :     # Create the classification stack. Note the stack is a pair of parallel lists,
1140 :     # one containing names and the other containing content.
1141 :     my @stackNames = ($rootName);
1142 :     my @stackContents = (\@retVal);
1143 :     # Add a null entry at the end of the subsystem list to force an unrolling.
1144 :     push @subs, ['', undef];
1145 :     # Loop through the subsystems.
1146 :     for my $sub (@subs) {
1147 :     # Pull out the classification list and the subsystem ID.
1148 :     my ($classString, $id) = @{$sub};
1149 :     Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1150 :     # Convert the classification string to a list with the root classification in
1151 :     # the front.
1152 :     my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1153 :     # Find the leftmost point at which the class list differs from the stack.
1154 :     my $matchPoint = 0;
1155 :     while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1156 :     $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1157 :     $matchPoint++;
1158 :     }
1159 :     Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1160 :     ". Class List length is " . scalar(@classList) . ".") if T(4);
1161 :     # Unroll the stack to the matchpoint.
1162 :     while ($#stackNames >= $matchPoint) {
1163 :     my $popped = pop @stackNames;
1164 :     pop @stackContents;
1165 :     Trace("\"$popped\" popped from stack.") if T(4);
1166 :     }
1167 :     # Start branches for any new classifications.
1168 :     while ($#stackNames < $#classList) {
1169 :     # The branch for a new classification contains its radio button
1170 :     # data and then a list of children. So, at this point, if radio buttons
1171 :     # are desired, we put them into the content.
1172 :     my $newLevel = scalar(@stackNames);
1173 :     my @newClassContent = ();
1174 :     if ($optionThing->{radio}) {
1175 :     my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1176 :     push @newClassContent, { value => "classification=$newClassString%" };
1177 :     }
1178 :     # The new classification node is appended to its parent's content
1179 :     # and then pushed onto the stack. First, we need the node name.
1180 :     my $nodeName = $classList[$newLevel];
1181 :     # Add the classification to its parent. This makes it part of the
1182 :     # tree we'll be returning to the user.
1183 :     push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1184 :     # Push the classification onto the stack.
1185 :     push @stackContents, \@newClassContent;
1186 :     push @stackNames, $nodeName;
1187 :     Trace("\"$nodeName\" pushed onto stack.") if T(4);
1188 :     }
1189 :     # Now the stack contains all our parent branches. We add the subsystem to
1190 :     # the branch at the top of the stack, but only if it's NOT the dummy node.
1191 :     if (defined $id) {
1192 :     # Compute the node name from the ID.
1193 :     my $nodeName = $id;
1194 :     $nodeName =~ s/_/ /g;
1195 :     # Create the node's leaf hash. This depends on the value of the radio
1196 :     # and link options.
1197 :     my $nodeContent = {};
1198 :     if ($optionThing->{links}) {
1199 :     # Compute the link value.
1200 :     my $linkable = uri_escape($id);
1201 :     $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";
1202 :     }
1203 :     if ($optionThing->{radio}) {
1204 :     # Compute the radio value.
1205 :     $nodeContent->{value} = "id=$id";
1206 :     }
1207 :     # Push the node into its parent branch.
1208 :     Trace("\"$nodeName\" added to node list.") if T(4);
1209 :     push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1210 :     }
1211 :     }
1212 :     # Return the result.
1213 :     return \@retVal;
1214 :     }
1215 :    
1216 :    
1217 : parrello 1.1 =head3 NmpdrGenomeMenu
1218 :    
1219 : parrello 1.3 C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1220 : parrello 1.1
1221 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1222 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
1223 :     easier to select all genomes from a particular category.
1224 :    
1225 :     =over 4
1226 :    
1227 :     =item menuName
1228 :    
1229 :     Name to give to the menu.
1230 :    
1231 : parrello 1.3 =item multiple
1232 : parrello 1.1
1233 : parrello 1.3 TRUE if the user is allowed to select multiple genomes, else FALSE.
1234 : parrello 1.1
1235 :     =item selected
1236 :    
1237 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
1238 :     is not intended to allow multiple selections, the list should be a singleton. If the
1239 :     list is empty, nothing will be pre-selected.
1240 :    
1241 : parrello 1.3 =item rows (optional)
1242 :    
1243 :     Number of rows to display. If omitted, the default is 1 for a single-select list
1244 :     and 10 for a multi-select list.
1245 :    
1246 : parrello 1.8 =item crossMenu (optional)
1247 :    
1248 :     If specified, is presumed to be the name of another genome menu whose contents
1249 :     are to be mutually exclusive with the contents of this menu. As a result, instead
1250 :     of the standard onChange event, the onChange event will deselect any entries in
1251 :     the other menu.
1252 :    
1253 : parrello 1.1 =item RETURN
1254 :    
1255 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
1256 :    
1257 :     =back
1258 :    
1259 :     =cut
1260 :    
1261 :     sub NmpdrGenomeMenu {
1262 :     # Get the parameters.
1263 : parrello 1.8 my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1264 : parrello 1.1 # Get the Sprout and CGI objects.
1265 :     my $sprout = $self->DB();
1266 :     my $cgi = $self->Q();
1267 : parrello 1.3 # Compute the row count.
1268 :     if (! defined $rows) {
1269 :     $rows = ($multiple ? 10 : 1);
1270 :     }
1271 :     # Create the multiple tag.
1272 :     my $multipleTag = ($multiple ? " multiple" : "");
1273 : parrello 1.1 # Get the form name.
1274 :     my $formName = $self->FormName();
1275 : parrello 1.3 # Check to see if we already have a genome list in memory.
1276 :     my $genomes = $self->{genomeList};
1277 :     my $groupHash;
1278 :     if (defined $genomes) {
1279 :     # We have a list ready to use.
1280 :     $groupHash = $genomes;
1281 :     } else {
1282 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
1283 :     # by name (genus,species,strain), but putting primary-group in front enables us to
1284 :     # take advantage of an existing index.
1285 :     my @genomeList = $sprout->GetAll(['Genome'],
1286 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1287 :     [], ['Genome(primary-group)', 'Genome(id)',
1288 :     'Genome(genus)', 'Genome(species)',
1289 :     'Genome(unique-characterization)']);
1290 :     # Create a hash to organize the genomes by group. Each group will contain a list of
1291 :     # 2-tuples, the first element being the genome ID and the second being the genome
1292 :     # name.
1293 :     my %gHash = ();
1294 :     for my $genome (@genomeList) {
1295 :     # Get the genome data.
1296 :     my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1297 : parrello 1.10 # Compute and cache its name and display group.
1298 :     my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1299 :     $strain);
1300 :     # Push the genome into the group's list. Note that we use the real group
1301 :     # name here, not the display group name.
1302 : parrello 1.3 push @{$gHash{$group}}, [$genomeID, $name];
1303 : parrello 1.1 }
1304 : parrello 1.3 # Save the genome list for future use.
1305 :     $self->{genomeList} = \%gHash;
1306 :     $groupHash = \%gHash;
1307 : parrello 1.1 }
1308 :     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1309 :     # the supporting-genome group last.
1310 : parrello 1.3 my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1311 : parrello 1.1 push @groups, $FIG_Config::otherGroup;
1312 : parrello 1.3 # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1313 :     # with the possibility of undefined values in the incoming list.
1314 :     my %selectedHash = ();
1315 :     if (defined $selected) {
1316 :     %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1317 :     }
1318 : parrello 1.13 # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1319 :     # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1320 :     # and use that to make the selections.
1321 :     my $nmpdrCount = 0;
1322 : parrello 1.1 # Create the type counters.
1323 :     my $groupCount = 1;
1324 :     # Compute the ID for the status display.
1325 :     my $divID = "${formName}_${menuName}_status";
1326 :     # Compute the JavaScript call for updating the status.
1327 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
1328 :     # If multiple selection is supported, create an onChange event.
1329 :     my $onChange = "";
1330 : parrello 1.8 if ($cross) {
1331 : parrello 1.13 # Here we have a paired menu. Selecting something in our menu unselects it in the
1332 :     # other and redisplays the status of both.
1333 : parrello 1.8 $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1334 :     } elsif ($multiple) {
1335 : parrello 1.13 # This is an unpaired menu, so all we do is redisplay our status.
1336 : parrello 1.1 $onChange = " onChange=\"$showSelect\"";
1337 :     }
1338 :     # Create the SELECT tag and stuff it into the output array.
1339 : parrello 1.13 my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
1340 : parrello 1.1 # Loop through the groups.
1341 :     for my $group (@groups) {
1342 :     # Create the option group tag.
1343 :     my $tag = "<OPTGROUP label=\"$group\">";
1344 :     push @lines, " $tag";
1345 :     # Get the genomes in the group.
1346 : parrello 1.3 for my $genome (@{$groupHash->{$group}}) {
1347 : parrello 1.13 # Count this organism if it's NMPDR.
1348 :     if ($group ne $FIG_Config::otherGroup) {
1349 :     $nmpdrCount++;
1350 :     }
1351 :     # Get the organism ID and name.
1352 : parrello 1.1 my ($genomeID, $name) = @{$genome};
1353 :     # See if it's selected.
1354 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
1355 :     # Generate the option tag.
1356 : parrello 1.13 my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1357 : parrello 1.1 push @lines, " $optionTag";
1358 :     }
1359 :     # Close the option group.
1360 :     push @lines, " </OPTGROUP>";
1361 :     }
1362 :     # Close the SELECT tag.
1363 :     push @lines, "</SELECT>";
1364 :     # Check for multiple selection.
1365 : parrello 1.3 if ($multiple) {
1366 : parrello 1.15 # Multi-select is on, so we need to add some selection helpers. First is
1367 :     # the search box. This allows the user to type text and have all genomes containing
1368 :     # the text selected automatically.
1369 :     my $searchThingName = "${menuName}_SearchThing";
1370 :     push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" " .
1371 :     "size=\"30\" onBlur=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";
1372 :     # Next are the buttons to set and clear selections.
1373 : parrello 1.1 push @lines, "<br />";
1374 : parrello 1.15 push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1375 : parrello 1.1 push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1376 : parrello 1.13 push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1377 :     push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1378 : parrello 1.1 # Add the status display, too.
1379 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1380 :     # Queue to update the status display when the form loads. We need to modify the show statement
1381 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1382 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1383 :     # in case we decide to twiddle the parameters.
1384 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1385 :     $self->QueueFormScript($showSelect);
1386 : parrello 1.3 # Finally, add this parameter to the list of genome parameters. This enables us to
1387 :     # easily find all the parameters used to select one or more genomes.
1388 :     push @{$self->{genomeParms}}, $menuName;
1389 : parrello 1.1 }
1390 :     # Assemble all the lines into a string.
1391 :     my $retVal = join("\n", @lines, "");
1392 :     # Return the result.
1393 :     return $retVal;
1394 :     }
1395 :    
1396 : parrello 1.3 =head3 PropertyMenu
1397 :    
1398 :     C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1399 :    
1400 :     Generate a property name dropdown menu.
1401 :    
1402 :     =over 4
1403 :    
1404 :     =item menuName
1405 :    
1406 :     Name to give to the menu.
1407 :    
1408 :     =item selected
1409 :    
1410 :     Value of the property name to pre-select.
1411 :    
1412 :     =item force (optional)
1413 :    
1414 :     If TRUE, then the user will be forced to choose a property name. If FALSE,
1415 :     then an additional menu choice will be provided to select nothing.
1416 :    
1417 :     =item RETURN
1418 :    
1419 :     Returns a dropdown menu box that allows the user to select a property name. An additional
1420 :     selection entry will be provided for selecting no property name
1421 :    
1422 :     =back
1423 :    
1424 :     =cut
1425 :    
1426 :     sub PropertyMenu {
1427 :     # Get the parameters.
1428 :     my ($self, $menuName, $selected, $force) = @_;
1429 :     # Get the CGI and Sprout objects.
1430 :     my $sprout = $self->DB();
1431 :     my $cgi = $self->Q();
1432 :     # Create the property name list.
1433 :     my @propNames = ();
1434 :     if (! $force) {
1435 :     push @propNames, "";
1436 :     }
1437 :     # Get all the property names, putting them after the null choice if one exists.
1438 :     push @propNames, $sprout->GetChoices('Property', 'property-name');
1439 :     # Create a menu from them.
1440 :     my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1441 :     -default => $selected);
1442 :     # Return the result.
1443 :     return $retVal;
1444 :     }
1445 :    
1446 : parrello 1.1 =head3 MakeTable
1447 :    
1448 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1449 :    
1450 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1451 :     other words, each must have the TR and TD tags included.
1452 :    
1453 :     The purpose of this method is to provide a uniform look for search form tables. It is
1454 :     almost impossible to control a table using styles, so rather than have a table style,
1455 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1456 :     be updated with an explicit width so the forms look pretty when they are all on one
1457 :     page.
1458 :    
1459 :     =over 4
1460 :    
1461 :     =item rows
1462 :    
1463 :     Reference to a list of table rows. Each table row must be in HTML form with all
1464 :     the TR and TD tags set up. The first TD or TH tag in each row will be modified to
1465 :     set the width. Everything else will be left as is.
1466 :    
1467 :     =item RETURN
1468 :    
1469 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1470 :    
1471 :     =back
1472 :    
1473 :     =cut
1474 :    
1475 :     sub MakeTable {
1476 :     # Get the parameters.
1477 :     my ($self, $rows) = @_;
1478 :     # Get the CGI object.
1479 :     my $cgi = $self->Q();
1480 :     # Fix the widths on the first column. Note that we eschew the use of the "g"
1481 :     # modifier becase we only want to change the first tag. Also, if a width
1482 :     # is already specified on the first column bad things will happen.
1483 :     for my $row (@{$rows}) {
1484 :     $row =~ s/(<td|th)/$1 width="150"/i;
1485 :     }
1486 :     # Create the table.
1487 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1488 :     width => 700, class => 'search'},
1489 :     @{$rows});
1490 :     # Return the result.
1491 :     return $retVal;
1492 :     }
1493 :    
1494 :     =head3 SubmitRow
1495 :    
1496 :     C<< my $htmlText = $shelp->SubmitRow(); >>
1497 :    
1498 :     Returns the HTML text for the row containing the page size control
1499 :     and the submit button. All searches should have this row somewhere
1500 :     near the top of the form.
1501 :    
1502 :     =cut
1503 :    
1504 :     sub SubmitRow {
1505 :     # Get the parameters.
1506 :     my ($self) = @_;
1507 :     my $cgi = $self->Q();
1508 : parrello 1.3 # Get the current page size.
1509 :     my $pageSize = $cgi->param('PageSize');
1510 :     # Get the incoming external-link flag.
1511 :     my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1512 :     # Create the row.
1513 : parrello 1.1 my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1514 :     $cgi->td($cgi->popup_menu(-name => 'PageSize',
1515 : parrello 1.7 -values => [10, 25, 50, 100, 1000],
1516 : parrello 1.3 -default => $pageSize) . " " .
1517 :     $cgi->checkbox(-name => 'ShowURL',
1518 :     -value => 1,
1519 :     -label => 'Show URL')),
1520 : parrello 1.1 $cgi->td($cgi->submit(-class => 'goButton',
1521 :     -name => 'Search',
1522 :     -value => 'Go')));
1523 :     # Return the result.
1524 :     return $retVal;
1525 :     }
1526 : parrello 1.2
1527 :     =head3 FeatureFilterRows
1528 :    
1529 :     C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1530 :    
1531 : parrello 1.11 This method creates table rows that can be used to filter features. The form
1532 :     values can be used to select features by genome using the B<FeatureQuery>
1533 :     object.
1534 : parrello 1.2
1535 :     =cut
1536 :    
1537 :     sub FeatureFilterRows {
1538 :     # Get the parameters.
1539 :     my ($self) = @_;
1540 :     # Return the result.
1541 :     return FeatureQuery::FilterRows($self);
1542 :     }
1543 :    
1544 : parrello 1.1 =head3 GBrowseFeatureURL
1545 :    
1546 :     C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
1547 :    
1548 :     Compute the URL required to pull up a Gbrowse page for the the specified feature.
1549 :     In order to do this, we need to pull out the ID of the feature's Genome, its
1550 :     contig ID, and some rough starting and stopping offsets.
1551 :    
1552 :     =over 4
1553 :    
1554 :     =item sprout
1555 :    
1556 :     Sprout object for accessing the database.
1557 :    
1558 :     =item feat
1559 :    
1560 :     ID of the feature whose Gbrowse URL is desired.
1561 :    
1562 :     =item RETURN
1563 :    
1564 :     Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome
1565 :     ID, contig ID, starting offset, and stopping offset.
1566 :    
1567 :     =back
1568 :    
1569 :     =cut
1570 :    
1571 :     sub GBrowseFeatureURL {
1572 :     # Get the parameters.
1573 :     my ($sprout, $feat) = @_;
1574 :     # Declare the return variable.
1575 :     my $retVal;
1576 :     # Compute the genome ID.
1577 :     my ($genomeID) = FIGRules::ParseFeatureID($feat);
1578 :     # Only proceed if the feature ID produces a valid genome.
1579 :     if ($genomeID) {
1580 :     # Get the feature location string.
1581 :     my $loc = $sprout->FeatureLocation($feat);
1582 :     # Compute the contig, start, and stop points.
1583 : parrello 1.6 my($contig, $start, $stop) = BasicLocation::Parse($loc);
1584 : parrello 1.5 Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1585 : parrello 1.1 # Now we need to do some goofiness to insure that the location is not too
1586 :     # big and that we get some surrounding stuff.
1587 :     my $mid = int(($start + $stop) / 2);
1588 :     my $chunk_len = 20000;
1589 :     my $max_feature = 40000;
1590 :     my $feat_len = abs($stop - $start);
1591 :     if ($feat_len > $chunk_len) {
1592 :     if ($feat_len > $max_feature) {
1593 :     $chunk_len = $max_feature;
1594 :     } else {
1595 :     $chunk_len = $feat_len + 100;
1596 :     }
1597 :     }
1598 :     my($show_start, $show_stop);
1599 :     if ($chunk_len == $max_feature) {
1600 :     $show_start = $start - 300;
1601 :     } else {
1602 :     $show_start = $mid - int($chunk_len / 2);
1603 :     }
1604 :     if ($show_start < 1) {
1605 :     $show_start = 1;
1606 :     }
1607 :     $show_stop = $show_start + $chunk_len - 1;
1608 :     my $clen = $sprout->ContigLength($contig);
1609 :     if ($show_stop > $clen) {
1610 :     $show_stop = $clen;
1611 :     }
1612 :     my $seg_id = $contig;
1613 :     $seg_id =~ s/:/--/g;
1614 : parrello 1.5 Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1615 : parrello 1.1 # Assemble all the pieces.
1616 :     $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";
1617 :     }
1618 :     # Return the result.
1619 :     return $retVal;
1620 :     }
1621 :    
1622 : parrello 1.3 =head3 GetGenomes
1623 :    
1624 :     C<< my @genomeList = $shelp->GetGenomes($parmName); >>
1625 :    
1626 :     Return the list of genomes specified by the specified CGI query parameter.
1627 :     If the request method is POST, then the list of genome IDs is returned
1628 :     without preamble. If the request method is GET and the parameter is not
1629 :     specified, then it is treated as a request for all genomes. This makes it
1630 :     easier for web pages to link to a search that wants to specify all genomes.
1631 :    
1632 :     =over 4
1633 :    
1634 :     =item parmName
1635 :    
1636 :     Name of the parameter containing the list of genomes. This will be the
1637 :     first parameter passed to the L</NmpdrGenomeMenu> call that created the
1638 :     genome selection control on the form.
1639 :    
1640 :     =item RETURN
1641 :    
1642 :     Returns a list of the genomes to process.
1643 :    
1644 :     =back
1645 :    
1646 :     =cut
1647 :    
1648 :     sub GetGenomes {
1649 :     # Get the parameters.
1650 :     my ($self, $parmName) = @_;
1651 :     # Get the CGI query object.
1652 :     my $cgi = $self->Q();
1653 :     # Get the list of genome IDs in the request header.
1654 :     my @retVal = $cgi->param($parmName);
1655 :     Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1656 :     # Check for the special GET case.
1657 :     if ($cgi->request_method() eq "GET" && ! @retVal) {
1658 :     # Here the caller wants all the genomes.
1659 :     my $sprout = $self->DB();
1660 :     @retVal = $sprout->Genomes();
1661 :     }
1662 :     # Return the result.
1663 :     return @retVal;
1664 :     }
1665 :    
1666 :     =head3 GetHelpText
1667 :    
1668 :     C<< my $htmlText = $shelp->GetHelpText(); >>
1669 :    
1670 :     Get the help text for this search. The help text is stored in files on the template
1671 :     server. The help text for a specific search is taken from a file named
1672 :     C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1673 :     There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1674 :     feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1675 :     describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1676 :     describes the standard controls for a search, such as page size, URL display, and
1677 :     external alias display.
1678 :    
1679 :     =cut
1680 :    
1681 :     sub GetHelpText {
1682 :     # Get the parameters.
1683 :     my ($self) = @_;
1684 :     # Create a list to hold the pieces of the help.
1685 :     my @helps = ();
1686 :     # Get the template directory URL.
1687 :     my $urlBase = $FIG_Config::template_url;
1688 :     # Start with the specific help.
1689 :     my $class = $self->{class};
1690 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1691 :     # Add the genome control help if needed.
1692 :     if (scalar @{$self->{genomeParms}}) {
1693 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1694 :     }
1695 :     # Next the filter help.
1696 :     if ($self->{filtered}) {
1697 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1698 :     }
1699 :     # Finally, the standard help.
1700 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1701 :     # Assemble the pieces.
1702 :     my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1703 :     # Return the result.
1704 :     return $retVal;
1705 :     }
1706 :    
1707 :     =head3 ComputeSearchURL
1708 :    
1709 :     C<< my $url = $shelp->ComputeSearchURL(); >>
1710 :    
1711 :     Compute the GET-style URL for the current search. In order for this to work, there
1712 :     must be a copy of the search form on the current page. This will always be the
1713 :     case if the search is coming from C<SearchSkeleton.cgi>.
1714 :    
1715 :     A little expense is involved in order to make the URL as smart as possible. The
1716 :     main complication is that if the user specified all genomes, we'll want to
1717 :     remove the parameter entirely from a get-style URL.
1718 :    
1719 :     =cut
1720 :    
1721 :     sub ComputeSearchURL {
1722 :     # Get the parameters.
1723 :     my ($self) = @_;
1724 :     # Get the database and CGI query object.
1725 :     my $cgi = $self->Q();
1726 :     my $sprout = $self->DB();
1727 :     # Start with the full URL.
1728 :     my $retVal = $cgi->url(-full => 1);
1729 :     # Get all the query parameters in a hash.
1730 :     my %parms = $cgi->Vars();
1731 :     # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1732 :     # characters separating the individual values. We have to convert those to lists. In addition,
1733 :     # the multiple-selection genome parameters and the feature type parameter must be checked to
1734 :     # determine whether or not they can be removed from the URL. First, we get a list of the
1735 :     # genome parameters and a list of all genomes. Note that we only need the list if a
1736 :     # multiple-selection genome parameter has been found on the form.
1737 :     my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1738 :     my @genomeList;
1739 :     if (keys %genomeParms) {
1740 :     @genomeList = $sprout->Genomes();
1741 :     }
1742 :     # Create a list to hold the URL parameters we find.
1743 :     my @urlList = ();
1744 :     # Now loop through the parameters in the hash, putting them into the output URL.
1745 :     for my $parmKey (keys %parms) {
1746 :     # Get a list of the parameter values. If there's only one, we'll end up with
1747 :     # a singleton list, but that's okay.
1748 :     my @values = split (/\0/, $parms{$parmKey});
1749 :     # Check for special cases.
1750 : parrello 1.12 if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {
1751 : parrello 1.3 # These are bookkeeping parameters we don't need to start a search.
1752 :     @values = ();
1753 :     } elsif ($parmKey =~ /_SearchThing$/) {
1754 :     # Here the value coming in is from a genome control's search thing. It does
1755 :     # not affect the results of the search, so we clear it.
1756 :     @values = ();
1757 :     } elsif ($genomeParms{$parmKey}) {
1758 :     # Here we need to see if the user wants all the genomes. If he does,
1759 :     # we erase all the values just like with features.
1760 :     my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1761 :     if ($allFlag) {
1762 :     @values = ();
1763 :     }
1764 :     }
1765 :     # If we still have values, create the URL parameters.
1766 :     if (@values) {
1767 :     push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1768 :     }
1769 :     }
1770 :     # Add the parameters to the URL.
1771 :     $retVal .= "?" . join(";", @urlList);
1772 :     # Return the result.
1773 :     return $retVal;
1774 :     }
1775 :    
1776 :     =head3 GetRunTimeValue
1777 :    
1778 :     C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1779 :    
1780 :     Compute a run-time column value.
1781 :    
1782 :     =over 4
1783 :    
1784 :     =item text
1785 :    
1786 :     The run-time column text. It consists of 2 percent signs, a column type, an equal
1787 :     sign, and the data for the current row.
1788 :    
1789 :     =item RETURN
1790 :    
1791 :     Returns the fully-formatted HTML text to go into the current column of the current row.
1792 :    
1793 :     =back
1794 :    
1795 :     =cut
1796 :    
1797 :     sub GetRunTimeValue {
1798 :     # Get the parameters.
1799 :     my ($self, $text) = @_;
1800 :     # Declare the return variable.
1801 :     my $retVal;
1802 :     # Parse the incoming text.
1803 :     if ($text =~ /^%%([^=]+)=(.*)$/) {
1804 :     $retVal = $self->RunTimeColumns($1, $2);
1805 :     } else {
1806 :     Confess("Invalid run-time column string \"$text\" encountered in session file.");
1807 :     }
1808 :     # Return the result.
1809 :     return $retVal;
1810 :     }
1811 :    
1812 : parrello 1.9 =head3 AdvancedClassList
1813 :    
1814 :     C<< my @classes = SearchHelper::AdvancedClassList(); >>
1815 :    
1816 :     Return a list of advanced class names. This list is used to generate the directory
1817 :     of available searches on the search page.
1818 :    
1819 : parrello 1.15 We use the %INC variable to accomplish this.
1820 : parrello 1.9
1821 :     =cut
1822 :    
1823 :     sub AdvancedClassList {
1824 : parrello 1.15 my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1825 :     return @retVal;
1826 : parrello 1.9 }
1827 :    
1828 : parrello 1.16 =head3 SelectionTree
1829 :    
1830 :     C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1831 :    
1832 :     Display a selection tree.
1833 :    
1834 :     This method creates the HTML for a tree selection control. The tree is implemented as a set of
1835 :     nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1836 :     addition, some of the tree nodes can contain hyperlinks.
1837 :    
1838 :     The tree itself is passed in as a multi-level list containing node names followed by
1839 :     contents. Each content element is a reference to a similar list. The first element of
1840 :     each list may be a hash reference. If so, it should contain one or both of the following
1841 :     keys.
1842 :    
1843 :     =over 4
1844 :    
1845 :     =item link
1846 :    
1847 :     The navigation URL to be popped up if the user clicks on the node name.
1848 :    
1849 :     =item value
1850 :    
1851 :     The form value to be returned if the user selects the tree node.
1852 :    
1853 :     =back
1854 :    
1855 :     The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1856 :     a C<value> key indicates the node name will have a radio button. If a node has no children,
1857 :     you may pass it a hash reference instead of a list reference.
1858 :    
1859 :     The following example shows the hash for a three-level tree with links on the second level and
1860 :     radio buttons on the third.
1861 :    
1862 :     [ Objects => [
1863 :     Entities => [
1864 :     {link => "../docs/WhatIsAnEntity.html"},
1865 :     Genome => {value => 'GenomeData'},
1866 :     Feature => {value => 'FeatureData'},
1867 :     Contig => {value => 'ContigData'},
1868 :     ],
1869 :     Relationships => [
1870 :     {link => "../docs/WhatIsARelationShip.html"},
1871 :     HasFeature => {value => 'GenomeToFeature'},
1872 :     IsOnContig => {value => 'FeatureToContig'},
1873 :     ]
1874 :     ]
1875 :     ]
1876 :    
1877 :     Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1878 :     all have list references.
1879 :    
1880 :     This next example shows how to set up a taxonomy selection field. The value returned
1881 :     by the tree control will be the taxonomy string for the selected node ready for use
1882 :     in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1883 :     reasons of space.
1884 :    
1885 :     [ All => [
1886 :     {value => "%"},
1887 :     Bacteria => [
1888 :     {value => "Bacteria%"},
1889 :     Proteobacteria => [
1890 :     {value => "Bacteria; Proteobacteria%"},
1891 :     Epsilonproteobacteria => [
1892 :     {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1893 :     Campylobacterales => [
1894 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1895 :     Campylobacteraceae =>
1896 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1897 :     ...
1898 :     ]
1899 :     ...
1900 :     ]
1901 :     ...
1902 :     ]
1903 :     ...
1904 :     ]
1905 :     ...
1906 :     ]
1907 :     ]
1908 :    
1909 :    
1910 :     This method of tree storage allows the caller to control the order in which the tree nodes
1911 :     are displayed and to completely control value selection and use of hyperlinks. It is, however
1912 :     a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1913 :    
1914 :     The parameters to this method are as follows.
1915 :    
1916 :     =over 4
1917 :    
1918 :     =item cgi
1919 :    
1920 :     CGI object used to generate the HTML.
1921 :    
1922 :     =item tree
1923 :    
1924 :     Reference to a hash describing a tree. See the description above.
1925 :    
1926 :     =item options
1927 :    
1928 :     Hash containing options for the tree display.
1929 :    
1930 :     =back
1931 :    
1932 :     The allowable options are as follows
1933 :    
1934 :     =over 4
1935 :    
1936 :     =item nodeImageClosed
1937 :    
1938 :     URL of the image to display next to the tree nodes when they are collapsed. Clicking
1939 :     on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1940 :    
1941 :     =item nodeImageOpen
1942 :    
1943 :     URL of the image to display next to the tree nodes when they are expanded. Clicking
1944 :     on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1945 :    
1946 :     =item style
1947 :    
1948 :     Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1949 :     as nested lists, the key components of this style are the definitions for the C<ul> and
1950 :     C<li> tags. The default style file contains the following definitions.
1951 :    
1952 :     .tree ul {
1953 :     margin-left: 0; padding-left: 22px
1954 :     }
1955 :     .tree li {
1956 :     list-style-type: none;
1957 :     }
1958 :    
1959 :     The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1960 :     parent by the width of the node image. This use of styles limits the things we can do in formatting
1961 :     the tree, but it has the advantage of vastly simplifying the tree creation.
1962 :    
1963 :     =item name
1964 :    
1965 :     Field name to give to the radio buttons in the tree. The default is C<selection>.
1966 :    
1967 :     =item target
1968 :    
1969 :     Frame target for links. The default is C<_self>.
1970 :    
1971 :     =item selected
1972 :    
1973 :     If specified, the value of the radio button to be pre-selected.
1974 :    
1975 :     =back
1976 :    
1977 :     =cut
1978 :    
1979 :     sub SelectionTree {
1980 :     # Get the parameters.
1981 :     my ($cgi, $tree, %options) = @_;
1982 :     # Get the options.
1983 :     my $optionThing = Tracer::GetOptions({ name => 'selection',
1984 :     nodeImageClosed => '../FIG/Html/plus.gif',
1985 :     nodeImageOpen => '../FIG/Html/minus.gif',
1986 :     style => 'tree',
1987 :     target => '_self',
1988 :     selected => undef},
1989 :     \%options);
1990 :     # Declare the return variable. We'll do the standard thing with creating a list
1991 :     # of HTML lines and rolling them together at the end.
1992 :     my @retVal = ();
1993 :     # Only proceed if the tree is present.
1994 :     if (defined($tree)) {
1995 :     # Validate the tree.
1996 :     if (ref $tree ne 'ARRAY') {
1997 :     Confess("Selection tree is not a list reference.");
1998 :     } elsif (scalar @{$tree} == 0) {
1999 :     # The tree is empty, so we do nothing.
2000 :     } elsif ($tree->[0] eq 'HASH') {
2001 :     Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2002 :     } else {
2003 :     # Here we have a real tree. Apply the tree style.
2004 :     push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2005 :     # Give us a DIV ID.
2006 :     my $divID = GetDivID($optionThing->{name});
2007 :     # Show the tree.
2008 :     push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2009 :     # Close the DIV block.
2010 :     push @retVal, $cgi->end_div();
2011 :     }
2012 :     }
2013 :     # Return the result.
2014 :     return join("\n", @retVal, "");
2015 :     }
2016 :    
2017 :     =head3 ShowBranch
2018 :    
2019 :     C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2020 :    
2021 :     This is a recursive method that displays a branch of the tree.
2022 :    
2023 :     =over 4
2024 :    
2025 :     =item cgi
2026 :    
2027 :     CGI object used to format HTML.
2028 :    
2029 :     =item label
2030 :    
2031 :     Label of this tree branch. It is only used in error messages.
2032 :    
2033 :     =item id
2034 :    
2035 :     ID to be given to this tree branch. The ID is used in the code that expands and collapses
2036 :     tree nodes.
2037 :    
2038 :     =item branch
2039 :    
2040 :     Reference to a list containing the content of the tree branch. The list contains an optional
2041 :     hash reference that is ignored and the list of children, each child represented by a name
2042 :     and then its contents. The contents could by a hash reference (indicating the attributes
2043 :     of a leaf node), or another tree branch.
2044 :    
2045 :     =item options
2046 :    
2047 :     Options from the original call to L</SelectionTree>.
2048 :    
2049 :     =item displayType
2050 :    
2051 :     C<block> if the contents of this list are to be displayed, C<none> if they are to be
2052 :     hidden.
2053 :    
2054 :     =item RETURN
2055 :    
2056 :     Returns one or more HTML lines that can be used to display the tree branch.
2057 :    
2058 :     =back
2059 :    
2060 :     =cut
2061 :    
2062 :     sub ShowBranch {
2063 :     # Get the parameters.
2064 :     my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2065 :     # Declare the return variable.
2066 :     my @retVal = ();
2067 :     # Start the branch.
2068 :     push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2069 :     # Check for the hash and choose the start location accordingly.
2070 :     my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2071 :     # Get the list length.
2072 :     my $i1 = scalar(@{$branch});
2073 :     # Verify we have an even number of elements.
2074 :     if (($i1 - $i0) % 2 != 0) {
2075 :     Trace("Branch elements are from $i0 to $i1.") if T(3);
2076 :     Confess("Odd number of elements in tree branch $label.");
2077 :     } else {
2078 :     # Loop through the elements.
2079 :     for (my $i = $i0; $i < $i1; $i += 2) {
2080 :     # Get this node's label and contents.
2081 :     my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2082 :     # Get an ID for this node's children (if any).
2083 :     my $myID = GetDivID($options->{name});
2084 :     # Now we need to find the list of children and the options hash.
2085 :     # This is a bit ugly because we allow the shortcut of a hash without an
2086 :     # enclosing list. First, we need some variables.
2087 :     my $attrHash = {};
2088 :     my @childHtml = ();
2089 :     my $hasChildren = 0;
2090 :     if (! ref $myContent) {
2091 :     Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2092 :     } elsif (ref $myContent eq 'HASH') {
2093 :     # Here the node is a leaf and its content contains the link/value hash.
2094 :     $attrHash = $myContent;
2095 :     } elsif (ref $myContent eq 'ARRAY') {
2096 :     # Here the node may be a branch. Its content is a list.
2097 :     my $len = scalar @{$myContent};
2098 :     if ($len >= 1) {
2099 :     # Here the first element of the list could by the link/value hash.
2100 :     if (ref $myContent->[0] eq 'HASH') {
2101 :     $attrHash = $myContent->[0];
2102 :     # If there's data in the list besides the hash, it's our child list.
2103 :     # We can pass the entire thing as the child list, because the hash
2104 :     # is ignored.
2105 :     if ($len > 1) {
2106 :     $hasChildren = 1;
2107 :     }
2108 :     } else {
2109 :     $hasChildren = 1;
2110 :     }
2111 :     # If we have children, create the child list with a recursive call.
2112 :     if ($hasChildren) {
2113 :     Trace("Processing children of $myLabel.") if T(4);
2114 :     push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2115 :     }
2116 :     }
2117 :     }
2118 :     # Okay, it's time to pause and take stock. We have the label of the current node
2119 :     # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2120 :     # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2121 :     # Compute the image HTML. It's tricky, because we have to deal with the open and
2122 :     # closed images.
2123 :     my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2124 :     my $image = $images[$hasChildren];
2125 :     my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2126 :     if ($hasChildren) {
2127 :     # If there are children, we wrap the image in a toggle hyperlink.
2128 :     $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2129 :     $prefixHtml);
2130 :     }
2131 :     # Now the radio button, if any. Note we use "defined" in case the user wants the
2132 :     # value to be 0.
2133 :     if (defined $attrHash->{value}) {
2134 :     # Due to a glitchiness in the CGI stuff, we have to build the attribute
2135 :     # hash for the "input" method. If the item is pre-selected, we add
2136 :     # "checked => undef" to the hash. Otherwise, we can't have "checked"
2137 :     # at all.
2138 :     my $radioParms = { type => 'radio',
2139 :     name => $options->{name},
2140 :     value => $attrHash->{value},
2141 :     };
2142 :     if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2143 :     $radioParms->{checked} = undef;
2144 :     }
2145 :     $prefixHtml .= $cgi->input($radioParms);
2146 :     }
2147 :     # Next, we format the label.
2148 :     my $labelHtml = $myLabel;
2149 :     Trace("Formatting tree node for $myLabel.") if T(4);
2150 :     # Apply a hyperlink if necessary.
2151 :     if (defined $attrHash->{link}) {
2152 :     $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2153 :     $labelHtml);
2154 :     }
2155 :     # Finally, roll up the child HTML. If there are no children, we'll get a null string
2156 :     # here.
2157 :     my $childHtml = join("\n", @childHtml);
2158 :     # Now we have all the pieces, so we can put them together.
2159 :     push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2160 :     }
2161 :     }
2162 :     # Close the tree branch.
2163 :     push @retVal, $cgi->end_ul();
2164 :     # Return the result.
2165 :     return @retVal;
2166 :     }
2167 :    
2168 :     =head3 GetDivID
2169 :    
2170 :     C<< my $idString = SearchHelper::GetDivID($name); >>
2171 :    
2172 :     Return a new HTML ID string.
2173 :    
2174 :     =over 4
2175 :    
2176 :     =item name
2177 :    
2178 :     Name to be prefixed to the ID string.
2179 :    
2180 :     =item RETURN
2181 :    
2182 :     Returns a hopefully-unique ID string.
2183 :    
2184 :     =back
2185 :    
2186 :     =cut
2187 :    
2188 :     sub GetDivID {
2189 :     # Get the parameters.
2190 :     my ($name) = @_;
2191 :     # Compute the ID.
2192 :     my $retVal = "elt_$name$divCount";
2193 :     # Increment the counter to make sure this ID is not re-used.
2194 :     $divCount++;
2195 :     # Return the result.
2196 :     return $retVal;
2197 :     }
2198 :    
2199 : parrello 1.1 =head2 Feature Column Methods
2200 :    
2201 :     The methods in this column manage feature column data. If you want to provide the
2202 :     capability to include new types of data in feature columns, then all the changes
2203 :     are made to this section of the source file. Technically, this should be implemented
2204 :     using object-oriented methods, but this is simpler for non-programmers to maintain.
2205 :     To add a new column of feature data, you must first give it a name. For example,
2206 :     the name for the protein page link column is C<protlink>. If the column is to appear
2207 :     in the default list of feature columns, add it to the list returned by
2208 :     L</DefaultFeatureColumns>. Then add code to produce the column title to
2209 :     L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
2210 :     everything else will happen automatically.
2211 :    
2212 :     There is one special column name syntax for extra columns (that is, nonstandard
2213 :     feature columns). If the column name begins with C<X=>, then it is presumed to be
2214 :     an extra column. The column title is the text after the C<X=>, and its value is
2215 :     pulled from the extra column hash.
2216 :    
2217 :     =head3 DefaultFeatureColumns
2218 :    
2219 : parrello 1.14 C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2220 : parrello 1.1
2221 : parrello 1.14 Return a list of the default feature column identifiers. These identifiers can
2222 :     be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2223 :     produce the column titles and row values.
2224 : parrello 1.1
2225 :     =cut
2226 :    
2227 :     sub DefaultFeatureColumns {
2228 :     # Get the parameters.
2229 :     my ($self) = @_;
2230 :     # Return the result.
2231 : parrello 1.14 return qw(orgName function gblink protlink);
2232 : parrello 1.1 }
2233 :    
2234 :     =head3 FeatureColumnTitle
2235 :    
2236 :     C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2237 :    
2238 :     Return the column heading title to be used for the specified feature column.
2239 :    
2240 :     =over 4
2241 :    
2242 :     =item name
2243 :    
2244 :     Name of the desired feature column.
2245 :    
2246 :     =item RETURN
2247 :    
2248 :     Returns the title to be used as the column header for the named feature column.
2249 :    
2250 :     =back
2251 :    
2252 :     =cut
2253 :    
2254 :     sub FeatureColumnTitle {
2255 :     # Get the parameters.
2256 :     my ($self, $colName) = @_;
2257 :     # Declare the return variable. We default to a blank column name.
2258 :     my $retVal = "&nbsp;";
2259 :     # Process the column name.
2260 :     if ($colName =~ /^X=(.+)$/) {
2261 :     # Here we have an extra column.
2262 :     $retVal = $1;
2263 : parrello 1.13 } elsif ($colName eq 'alias') {
2264 :     $retVal = "External Aliases";
2265 : parrello 1.1 } elsif ($colName eq 'fid') {
2266 :     $retVal = "FIG ID";
2267 :     } elsif ($colName eq 'function') {
2268 :     $retVal = "Functional Assignment";
2269 :     } elsif ($colName eq 'gblink') {
2270 :     $retVal = "GBrowse";
2271 : parrello 1.13 } elsif ($colName eq 'group') {
2272 :     $retVal = "NMDPR Group";
2273 :     } elsif ($colName =~ /^keyword:(.+)$/) {
2274 :     $retVal = ucfirst $1;
2275 :     } elsif ($colName eq 'orgName') {
2276 : parrello 1.17 $retVal = "Gene Name";
2277 : parrello 1.1 } elsif ($colName eq 'protlink') {
2278 :     $retVal = "NMPDR Protein Page";
2279 : parrello 1.13 } elsif ($colName eq 'subsystem') {
2280 :     $retVal = "Subsystems";
2281 : parrello 1.1 }
2282 :     # Return the result.
2283 :     return $retVal;
2284 :     }
2285 :    
2286 : parrello 1.13
2287 : parrello 1.1 =head3 FeatureColumnValue
2288 :    
2289 :     C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
2290 :    
2291 :     Return the value to be displayed in the specified feature column.
2292 :    
2293 :     =over 4
2294 :    
2295 :     =item colName
2296 :    
2297 :     Name of the column to be displayed.
2298 :    
2299 :     =item record
2300 :    
2301 :     DBObject record for the feature being displayed in the current row.
2302 :    
2303 :     =item extraCols
2304 :    
2305 :     Reference to a hash of extra column names to values. If the incoming column name
2306 :     begins with C<X=>, its value will be taken from this hash.
2307 :    
2308 :     =item RETURN
2309 :    
2310 :     Returns the HTML to be displayed in the named column for the specified feature.
2311 :    
2312 :     =back
2313 :    
2314 :     =cut
2315 :    
2316 :     sub FeatureColumnValue {
2317 :     # Get the parameters.
2318 :     my ($self, $colName, $record, $extraCols) = @_;
2319 :     # Get the sprout and CGI objects.
2320 :     my $cgi = $self->Q();
2321 :     my $sprout = $self->DB();
2322 :     # Get the feature ID.
2323 :     my ($fid) = $record->Value('Feature(id)');
2324 :     # Declare the return variable. Denote that we default to a non-breaking space,
2325 :     # which will translate to an empty table cell (rather than a table cell with no
2326 :     # interior, which is what you get for a null string).
2327 :     my $retVal = "&nbsp;";
2328 :     # Process according to the column name.
2329 :     if ($colName =~ /^X=(.+)$/) {
2330 :     # Here we have an extra column. Only update if the value exists. Note that
2331 :     # a value of C<undef> is treated as a non-existent value, because the
2332 :     # caller may have put "colName => undef" in the "PutFeature" call in order
2333 :     # to insure we know the extra column exists.
2334 :     if (defined $extraCols->{$1}) {
2335 :     $retVal = $extraCols->{$1};
2336 :     }
2337 : parrello 1.13 } elsif ($colName eq 'alias') {
2338 :     # In this case, the user wants a list of external aliases for the feature.
2339 :     # These are very expensive, so we compute them when the row is displayed.
2340 :     $retVal = "%%alias=$fid";
2341 : parrello 1.1 } elsif ($colName eq 'fid') {
2342 :     # Here we have the raw feature ID. We hyperlink it to the protein page.
2343 :     $retVal = HTML::set_prot_links($fid);
2344 :     } elsif ($colName eq 'function') {
2345 :     # The functional assignment is just a matter of getting some text.
2346 :     ($retVal) = $record->Value('Feature(assignment)');
2347 :     } elsif ($colName eq 'gblink') {
2348 :     # Here we want a link to the GBrowse page using the official GBrowse button.
2349 :     my $gurl = "GetGBrowse.cgi?fid=$fid";
2350 :     $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },
2351 :     $cgi->img({ src => "../images/button-gbrowse.png",
2352 :     border => 0 })
2353 :     );
2354 : parrello 1.13 } elsif ($colName eq 'group') {
2355 :     # Get the NMPDR group name.
2356 :     my (undef, $group) = $self->OrganismData($fid);
2357 :     # Dress it with a URL to the group's main page.
2358 :     my $nurl = $sprout->GroupPageName($group);
2359 :     $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2360 :     $group);
2361 :     } elsif ($colName =~ /^keyword:(.+)$/) {
2362 :     # Here we want keyword-related values. This is also expensive, so
2363 :     # we compute them when the row is displayed.
2364 : parrello 1.14 $retVal = "%%$colName=$fid";
2365 : parrello 1.13 } elsif ($colName eq 'orgName') {
2366 :     # Here we want the formatted organism name and feature number.
2367 :     $retVal = $self->FeatureName($fid);
2368 : parrello 1.1 } elsif ($colName eq 'protlink') {
2369 :     # Here we want a link to the protein page using the official NMPDR button.
2370 :     my $hurl = HTML::fid_link($cgi, $fid, 0, 1);
2371 :     $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },
2372 :     $cgi->img({ src => "../images/button-nmpdr.png",
2373 :     border => 0 })
2374 :     );
2375 : parrello 1.13 }elsif ($colName eq 'subsystem') {
2376 :     # Another run-time column: subsystem list.
2377 :     $retVal = "%%subsystem=$fid";
2378 : parrello 1.1 }
2379 :     # Return the result.
2380 :     return $retVal;
2381 :     }
2382 :    
2383 : parrello 1.3 =head3 RunTimeColumns
2384 :    
2385 :     C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2386 :    
2387 :     Return the HTML text for a run-time column. Run-time columns are evaluated when the
2388 :     list is displayed, rather than when it is generated.
2389 :    
2390 :     =over 4
2391 :    
2392 :     =item type
2393 :    
2394 :     Type of column.
2395 :    
2396 :     =item text
2397 :    
2398 :     Data relevant to this row of the column.
2399 :    
2400 :     =item RETURN
2401 :    
2402 :     Returns the fully-formatted HTML text to go in the specified column.
2403 :    
2404 :     =back
2405 :    
2406 :     =cut
2407 :    
2408 :     sub RunTimeColumns {
2409 :     # Get the parameters.
2410 :     my ($self, $type, $text) = @_;
2411 :     # Declare the return variable.
2412 :     my $retVal = "";
2413 :     # Get the Sprout and CGI objects.
2414 :     my $sprout = $self->DB();
2415 :     my $cgi = $self->Q();
2416 : parrello 1.14 Trace("Runtime column $type with text \"$text\" found.") if T(4);
2417 : parrello 1.3 # Separate the text into a type and data.
2418 : parrello 1.13 if ($type eq 'alias') {
2419 : parrello 1.3 # Here the caller wants external alias links for a feature. The text
2420 :     # is the feature ID.
2421 :     my $fid = $text;
2422 :     # The complicated part is we have to hyperlink them. First, get the
2423 :     # aliases.
2424 :     Trace("Generating aliases for feature $fid.") if T(4);
2425 :     my @aliases = $sprout->FeatureAliases($fid);
2426 :     # Only proceed if we found some.
2427 :     if (@aliases) {
2428 :     # Join the aliases into a comma-delimited list.
2429 :     my $aliasList = join(", ", @aliases);
2430 :     # Ask the HTML processor to hyperlink them.
2431 :     $retVal = HTML::set_prot_links($cgi, $aliasList);
2432 :     }
2433 : parrello 1.13 } elsif ($type eq 'subsystem') {
2434 :     # Here the caller wants the subsystems in which this feature participates.
2435 :     # The text is the feature ID. We will list the subsystem names with links
2436 :     # to the subsystem's summary page.
2437 :     my $fid = $text;
2438 :     # Get the subsystems.
2439 :     Trace("Generating subsystems for feature $fid.") if T(4);
2440 :     my %subs = $sprout->SubsystemsOf($fid);
2441 :     # Convert them to links.
2442 :     my @links = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2443 :     # String them into a list.
2444 :     $retVal = join(", ", @links);
2445 :     } elsif ($type =~ /^keyword:(.+)$/) {
2446 :     # Here the caller wants the value of the named keyword. The text is the
2447 :     # feature ID.
2448 :     my $keywordName = $1;
2449 :     my $fid = $text;
2450 :     # Get the attribute values.
2451 :     Trace("Getting $keywordName values for feature $fid.") if T(4);
2452 :     my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2453 :     "Feature($keywordName)");
2454 :     # String them into a list.
2455 :     $retVal = join(", ", @values);
2456 : parrello 1.3 }
2457 :     # Return the result.
2458 :     return $retVal;
2459 :     }
2460 :    
2461 : parrello 1.10 =head3 SaveOrganismData
2462 :    
2463 :     C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2464 :    
2465 :     Format the name of an organism and the display version of its group name. The incoming
2466 :     data should be the relevant fields from the B<Genome> record in the database. The
2467 :     data will also be stored in the genome cache for later use in posting search results.
2468 :    
2469 :     =over 4
2470 :    
2471 :     =item group
2472 :    
2473 :     Name of the genome's group as it appears in the database.
2474 :    
2475 :     =item genomeID
2476 :    
2477 :     ID of the relevant genome.
2478 :    
2479 :     =item genus
2480 :    
2481 :     Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2482 :     in the database. In this case, the organism name is derived from the genomeID and the group
2483 :     is automatically the supporting-genomes group.
2484 :    
2485 :     =item species
2486 :    
2487 :     Species of the genome's organism.
2488 :    
2489 :     =item strain
2490 :    
2491 :     Strain of the species represented by the genome.
2492 :    
2493 :     =item RETURN
2494 :    
2495 :     Returns a two-element list. The first element is the formatted genome name. The second
2496 :     element is the display name of the genome's group.
2497 :    
2498 :     =back
2499 :    
2500 :     =cut
2501 :    
2502 :     sub SaveOrganismData {
2503 :     # Get the parameters.
2504 :     my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2505 :     # Declare the return values.
2506 :     my ($name, $displayGroup);
2507 :     # If the organism does not exist, format an unknown name and a blank group.
2508 :     if (! defined($genus)) {
2509 :     $name = "Unknown Genome $genomeID";
2510 :     $displayGroup = "";
2511 :     } else {
2512 :     # It does exist, so format the organism name.
2513 :     $name = "$genus $species";
2514 :     if ($strain) {
2515 :     $name .= " $strain";
2516 :     }
2517 :     # Compute the display group. This is currently the same as the incoming group
2518 :     # name unless it's the supporting group, which is nulled out.
2519 :     $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2520 :     }
2521 :     # Cache the group and organism data.
2522 :     my $cache = $self->{orgs};
2523 :     $cache->{$genomeID} = [$name, $displayGroup];
2524 :     # Return the result.
2525 :     return ($name, $displayGroup);
2526 :     }
2527 :    
2528 : parrello 1.16 =head3 ValidateKeywords
2529 :    
2530 :     C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2531 :    
2532 :     Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2533 :     set.
2534 :    
2535 :     =over 4
2536 :    
2537 :     =item keywordString
2538 :    
2539 :     Keyword string specified as a parameter to the current search.
2540 :    
2541 :     =item required
2542 :    
2543 :     TRUE if there must be at least one keyword specified, else FALSE.
2544 :    
2545 :     =item RETURN
2546 :    
2547 :     Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2548 :     is acceptable if the I<$required> parameter is not specified.
2549 :    
2550 :     =back
2551 :    
2552 :     =cut
2553 :    
2554 :     sub ValidateKeywords {
2555 :     # Get the parameters.
2556 :     my ($self, $keywordString, $required) = @_;
2557 :     # Declare the return variable.
2558 :     my $retVal = 0;
2559 :     my @wordList = split /\s+/, $keywordString;
2560 :     # Right now our only real worry is a list of all minus words. The problem with it is that
2561 :     # it will return an incorrect result.
2562 :     my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2563 :     if (! @wordList) {
2564 :     if ($required) {
2565 :     $self->SetMessage("No search words specified.");
2566 :     }
2567 :     } elsif (! @plusWords) {
2568 :     $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2569 :     } else {
2570 :     $retVal = 1;
2571 :     }
2572 :     # Return the result.
2573 :     return $retVal;
2574 :     }
2575 :    
2576 : parrello 1.4 =head2 Virtual Methods
2577 :    
2578 :     =head3 Form
2579 :    
2580 :     C<< my $html = $shelp->Form(); >>
2581 :    
2582 :     Generate the HTML for a form to request a new search.
2583 :    
2584 :     =head3 Find
2585 :    
2586 :     C<< my $resultCount = $shelp->Find(); >>
2587 :    
2588 :     Conduct a search based on the current CGI query parameters. The search results will
2589 :     be written to the session cache file and the number of results will be
2590 :     returned. If the search parameters are invalid, a result count of C<undef> will be
2591 :     returned and a result message will be stored in this object describing the problem.
2592 :    
2593 :     =head3 Description
2594 :    
2595 :     C<< my $htmlText = $shelp->Description(); >>
2596 :    
2597 :     Return a description of this search. The description is used for the table of contents
2598 :     on the main search tools page. It may contain HTML, but it should be character-level,
2599 :     not block-level, since the description is going to appear in a list.
2600 :    
2601 :     =head3 SortKey
2602 :    
2603 : parrello 1.11 C<< my $key = $shelp->SortKey($fdata); >>
2604 : parrello 1.4
2605 : parrello 1.11 Return the sort key for the specified feature data. The default is to sort by feature name,
2606 : parrello 1.10 floating NMPDR organisms to the top. If a full-text search is used, then the default
2607 :     sort is by relevance followed by feature name. This sort may be overridden by the
2608 :     search class to provide fancier functionality. This method is called by
2609 :     B<PutFeature>, so it is only used for feature searches. A non-feature search
2610 :     would presumably have its own sort logic.
2611 : parrello 1.4
2612 :     =over 4
2613 :    
2614 :     =item record
2615 :    
2616 : parrello 1.11 The C<FeatureData> containing the current feature.
2617 : parrello 1.4
2618 :     =item RETURN
2619 :    
2620 :     Returns a key field that can be used to sort this row in among the results.
2621 :    
2622 :     =back
2623 :    
2624 :     =cut
2625 :    
2626 :     sub SortKey {
2627 :     # Get the parameters.
2628 : parrello 1.11 my ($self, $fdata) = @_;
2629 : parrello 1.4 # Get the feature ID from the record.
2630 : parrello 1.11 my $fid = $fdata->FID();
2631 : parrello 1.4 # Get the group from the feature ID.
2632 :     my $group = $self->FeatureGroup($fid);
2633 :     # Ask the feature query object to form the sort key.
2634 : parrello 1.11 my $retVal = $fdata->SortKey($self, $group);
2635 : parrello 1.4 # Return the result.
2636 :     return $retVal;
2637 :     }
2638 : parrello 1.9
2639 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3