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

Diff of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13, Fri Nov 3 00:40:16 2006 UTC revision 1.42, Fri Oct 17 16:41:47 2008 UTC
# Line 10  Line 10 
10      use File::Path;      use File::Path;
11      use File::stat;      use File::stat;
12      use LWP::UserAgent;      use LWP::UserAgent;
13      use Time::HiRes 'gettimeofday';      use FIGRules;
14      use Sprout;      use Sprout;
15      use SFXlate;      use SFXlate;
16      use FIGRules;      use FIGRules;
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
     use FeatureQuery;  
19      use URI::Escape;      use URI::Escape;
20      use PageBuilder;      use PageBuilder;
21        use AliasAnalysis;
22        use FreezeThaw qw(freeze thaw);
23    
24  =head1 Search Helper Base Class  =head1 Search Helper Base Class
25    
# Line 65  Line 66 
66    
67  =item orgs  =item orgs
68    
69  Reference to a hash mapping genome IDs to organism names.  Reference to a hash mapping genome IDs to organism data. (Used to
70    improve performance.)
71    
72  =item name  =item name
73    
# Line 83  Line 85 
85    
86  List of the parameters that are used to select multiple genomes.  List of the parameters that are used to select multiple genomes.
87    
 =item filtered  
   
 TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  
 field is updated by the B<FeatureQuery> object.  
   
88  =back  =back
89    
90  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 103  Line 100 
100  =item 2  =item 2
101    
102  Create a new subclass of this object and implement each of the virtual methods. The  Create a new subclass of this object and implement each of the virtual methods. The
103  name of the subclass must be C<SH>I<className>.  name of the subclass must be C<SH>I<className>, where I<className> is the
104    type of search.
105    
106  =item 3  =item 3
107    
# Line 113  Line 111 
111    
112  =item 4  =item 4
113    
114  In the C<SearchSkeleton.cgi> script, add a C<use> statement for your search tool  If your search produces a result for which a helper does not exist, you
115  and then put the class name in the C<@advancedClasses> list.  must create a new subclass of B<ResultHelper>. Its name must be
116    C<RH>I<className>, where I<className> is the type of result.
117    
118  =back  =back
119    
# Line 150  Line 149 
149    
150  Several helper methods are provided for particular purposes.  Several helper methods are provided for particular purposes.
151    
 =over 4  
   
 =item 1  
   
152  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
153  L</GetGenomes> to retrieve all the genomes passed in for a specified parameter  L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
154  name. Note that as an assist to people working with GET-style links, if no  name. Note that as an assist to people working with GET-style links, if no
155  genomes are specified and the incoming request style is GET, all genomes will  genomes are specified and the incoming request style is GET, all genomes will
156  be returned.  be returned.
157    
 =item 2  
   
 L</FeatureFilterRow> formats several rows of controls for filtering features.  
 When you start building the code for the L</Find> method, you can use a  
 B<FeatureQuery> object to automatically filter each genome's features using  
 the values from the filter controls.  
   
 =item 3  
   
158  L</QueueFormScript> allows you to queue JavaScript statements for execution  L</QueueFormScript> allows you to queue JavaScript statements for execution
159  after the form is fully generated. If you are using very complicated  after the form is fully generated. If you are using very complicated
160  form controls, the L</QueueFormScript> method allows you to perform  form controls, the L</QueueFormScript> method allows you to perform
161  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
162  facility to display a list of the pre-selected genomes.  facility to display a list of the pre-selected genomes.
163    
 =back  
   
164  Finally, when generating the code for your controls, be sure to use any incoming  Finally, when generating the code for your controls, be sure to use any incoming
165  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
166    
167  =head3 Finding Search Results  =head3 Finding Search Results
168    
169  The L</Find> method is used to create the search results. For a search that  The L</Find> method is used to create the search results. The basic code
170  wants to return features (which is most of them), the basic code structure  structure would work as follows.
 would work as follows. It is assumed that the L</FeatureFilterRows> method  
 has been used to create feature filtering parameters.  
171    
172      sub Find {      sub Find {
173          my ($self) = @_;          my ($self) = @_;
# Line 198  Line 180 
180          ... validate the parameters ...          ... validate the parameters ...
181          if (... invalid parameters...) {          if (... invalid parameters...) {
182              $self->SetMessage(...appropriate message...);              $self->SetMessage(...appropriate message...);
183          } elsif (FeatureQuery::Valid($self)) {          } else {
184                # Determine the result type.
185                my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
186                # Specify the columns.
187                $self->DefaultColumns($rhelp);
188                # You may want to add extra columns. $name is the column name and
189                # $loc is its location. The other parameters take their names from the
190                # corresponding column methods.
191                $rhelp->AddExtraColumn($name => $loc, style => $style, download => $flag,
192                    title => $title);
193                # Some searches require optional columns that are configured by the
194                # user or by the search query itself. There are some special methods
195                # for this in the result helpers, but there's also the direct approach
196                # shown below.
197                $rhelp->AddOptionalColumn($name => $loc);
198              # Initialize the session file.              # Initialize the session file.
199              $self->OpenSession();              $self->OpenSession($rhelp);
200              # Initialize the result counter.              # Initialize the result counter.
201              $retVal = 0;              $retVal = 0;
202              ... get a list of genomes ...              ... set up to loop through the results ...
203              for my $genomeID (... each genome ...) {              while (...more results...) {
204                  my $fq = FeatureQuery->new($self, $genomeID);                  ...compute extra columns and call PutExtraColumns...
205                  while (my $feature = $fq->Fetch()) {                  $rhelp->PutData($sortKey, $objectID, $record);
                     ... examine the feature ...  
                     if (... we want to keep it ...) {  
                         $self->PutFeature($fq);  
206                          $retVal++;                          $retVal++;
207                      }                      }
                 }  
             }  
208              # Close the session file.              # Close the session file.
209              $self->CloseSession();              $self->CloseSession();
210          }          }
# Line 222  Line 213 
213      }      }
214    
215  A Find method is of course much more complicated than generating a form, and there  A Find method is of course much more complicated than generating a form, and there
216  are variations on the above them. For example, you could eschew feature filtering  are variations on the above theme.
 entirely in favor of your own custom filtering, you could include extra columns  
 in the output, or you could search for something that's not a feature at all. The  
 above code is just a loose framework.  
217    
218  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>  In addition to the finding and filtering, it is necessary to send status messages
219  method of the feature query object.  to the output so that the user does not get bored waiting for results. The L</PrintLine>
220    method performs this function. The single parameter should be text to be
221    output to the browser. In general, you'll invoke it as follows.
222    
223      $fq->AddExtraColumns(score => $sc);      $self->PrintLine("...my message text...<br />");
224    
225    The break tag is optional. When the Find method gets control, a paragraph will
226    have been started so that everything is XHTML-compliant.
227    
228  The L</Find> method must return C<undef> if the search parameters are invalid. If this  The L</Find> method must return C<undef> if the search parameters are invalid. If this
229  is the case, then a message describing the problem should be passed to the framework  is the case, then a message describing the problem should be passed to the framework
# Line 241  Line 234 
234    
235  # This counter is used to insure every form on the page has a unique name.  # This counter is used to insure every form on the page has a unique name.
236  my $formCount = 0;  my $formCount = 0;
237    # This counter is used to generate unique DIV IDs.
238    my $divCount = 0;
239    
240  =head2 Public Methods  =head2 Public Methods
241    
242  =head3 new  =head3 new
243    
244  C<< my $shelp = SearchHelper->new($query); >>      my $shelp = SearchHelper->new($cgi);
245    
246  Construct a new SearchHelper object.  Construct a new SearchHelper object.
247    
248  =over 4  =over 4
249    
250  =item query  =item cgi
251    
252  The CGI query object for the current script.  The CGI query object for the current script.
253    
# Line 262  Line 257 
257    
258  sub new {  sub new {
259      # Get the parameters.      # Get the parameters.
260      my ($class, $query) = @_;      my ($class, $cgi) = @_;
261      # Check for a session ID.      # Check for a session ID.
262      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
263      my $type = "old";      my $type = "old";
264      if (! $session_id) {      if (! $session_id) {
265            Trace("No session ID found.") if T(3);
266          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
267          # store it in the query object.          # store it in the query object.
268          $session_id = NewSessionID();          $session_id = FIGRules::NewSessionID();
269            Trace("New session ID is $session_id.") if T(3);
270          $type = "new";          $type = "new";
271          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
272        } else {
273            Trace("Session ID is $session_id.") if T(3);
274      }      }
275        Trace("Computing subclass.") if T(3);
276      # Compute the subclass name.      # Compute the subclass name.
277      $class =~ /SH(.+)$/;      my $subClass;
278      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
279            # Here we have a real search class.
280            $subClass = $1;
281        } else {
282            # Here we have a bare class. The bare class cannot search, but it can
283            # process search results.
284            $subClass = 'SearchHelper';
285        }
286        Trace("Subclass name is $subClass.") if T(3);
287      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
288      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
289      # Generate the form name.      # Generate the form name.
290      my $formName = "$class$formCount";      my $formName = "$class$formCount";
291      $formCount++;      $formCount++;
292        Trace("Creating helper.") if T(3);
293      # Create the shelp object. It contains the query object (with the session ID)      # Create the shelp object. It contains the query object (with the session ID)
294      # as well as an indicator as to whether or not the session is new, plus the      # as well as an indicator as to whether or not the session is new, plus the
295      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
296      my $retVal = {      my $retVal = {
297                    query => $query,                    query => $cgi,
298                    type => $type,                    type => $type,
299                    class => $subClass,                    class => $subClass,
300                    sprout => undef,                    sprout => undef,
# Line 294  Line 303 
303                    scriptQueue => [],                    scriptQueue => [],
304                    genomeList => undef,                    genomeList => undef,
305                    genomeParms => [],                    genomeParms => [],
                   filtered => 0,  
306                   };                   };
307      # Bless and return it.      # Bless and return it.
308      bless $retVal, $class;      bless $retVal, $class;
# Line 303  Line 311 
311    
312  =head3 Q  =head3 Q
313    
314  C<< my $query = $shelp->Q(); >>      my $query = $shelp->Q();
315    
316  Return the CGI query object.  Return the CGI query object.
317    
# Line 320  Line 328 
328    
329  =head3 DB  =head3 DB
330    
331  C<< my $sprout = $shelp->DB(); >>      my $sprout = $shelp->DB();
332    
333  Return the Sprout database object.  Return the Sprout database object.
334    
# Line 341  Line 349 
349    
350  =head3 IsNew  =head3 IsNew
351    
352  C<< my $flag = $shelp->IsNew(); >>      my $flag = $shelp->IsNew();
353    
354  Return TRUE if this is a new session, FALSE if this is an old session. An old  Return TRUE if this is a new session, FALSE if this is an old session. An old
355  session already has search results ready to process.  session already has search results ready to process.
# Line 357  Line 365 
365    
366  =head3 ID  =head3 ID
367    
368  C<< my $sessionID = $shelp->ID(); >>      my $sessionID = $shelp->ID();
369    
370  Return the current session ID.  Return the current session ID.
371    
# Line 372  Line 380 
380    
381  =head3 FormName  =head3 FormName
382    
383  C<< my $name = $shelp->FormName(); >>      my $name = $shelp->FormName();
384    
385  Return the name of the form this helper object will generate.  Return the name of the form this helper object will generate.
386    
# Line 387  Line 395 
395    
396  =head3 QueueFormScript  =head3 QueueFormScript
397    
398  C<< $shelp->QueueFormScript($statement); >>      $shelp->QueueFormScript($statement);
399    
400  Add the specified statement to the queue of JavaScript statements that are to be  Add the specified statement to the queue of JavaScript statements that are to be
401  executed when the form has been fully defined. This is necessary because until  executed when the form has been fully defined. This is necessary because until
# Line 422  Line 430 
430    
431  =head3 FormStart  =head3 FormStart
432    
433  C<< my $html = $shelp->FormStart($title); >>      my $html = $shelp->FormStart($title);
434    
435  Return the initial section of a form designed to perform another search of the  Return the initial section of a form designed to perform another search of the
436  same type. The form header is included along with hidden fields to persist the  same type. The form header is included along with hidden fields to persist the
# Line 449  Line 457 
457      my ($self, $title) = @_;      my ($self, $title) = @_;
458      # Get the CGI object.      # Get the CGI object.
459      my $cgi = $self->Q();      my $cgi = $self->Q();
460      # Start the form.      # Start the form. Note we use the override option on the Class value, in
461        # case the Advanced button was used.
462      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
463                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
464                                    -action => $cgi->url(-relative => 1),                                    -action => "$FIG_Config::cgi_url/SearchSkeleton.cgi",
465                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
466                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
467                                -value => $self->{class}) .                                -value => $self->{class},
468                                  -override => 1) .
469                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
470                                -value => 1) .                                -value => 1) .
471                   $cgi->h3($title);                   $cgi->h3("$title" . Hint($self->{class}, "Click here for more information."));
     # If tracing is on, add it to the form.  
     if ($cgi->param('Trace')) {  
         $retVal .= $cgi->hidden(-name => 'Trace',  
                                 -value => $cgi->param('Trace')) .  
                    $cgi->hidden(-name => 'TF',  
                                 -value => ($cgi->param('TF') ? 1 : 0));  
     }  
472      # Put in an anchor tag in case there's a table of contents.      # Put in an anchor tag in case there's a table of contents.
473      my $anchorName = $self->FormName();      my $anchorName = $self->FormName();
474      $retVal .= "<a name=\"$anchorName\"></a>\n";      $retVal .= "<a name=\"$anchorName\"></a>\n";
# Line 475  Line 478 
478    
479  =head3 FormEnd  =head3 FormEnd
480    
481  C<< my $htmlText = $shelp->FormEnd(); >>      my $htmlText = $shelp->FormEnd();
482    
483  Return the HTML text for closing a search form. This closes both the C<form> and  Return the HTML text for closing a search form. This closes both the C<form> and
484  C<div> tags.  C<div> tags.
# Line 507  Line 510 
510    
511  =head3 SetMessage  =head3 SetMessage
512    
513  C<< $shelp->SetMessage($msg); >>      $shelp->SetMessage($msg);
514    
515  Store the specified text as the result message. The result message is displayed  Store the specified text as the result message. The result message is displayed
516  if an invalid parameter value is specified.  if an invalid parameter value is specified.
# Line 531  Line 534 
534    
535  =head3 Message  =head3 Message
536    
537  C<< my $text = $shelp->Message(); >>      my $text = $shelp->Message();
538    
539  Return the result message. The result message is displayed if an invalid parameter  Return the result message. The result message is displayed if an invalid parameter
540  value is specified.  value is specified.
# Line 547  Line 550 
550    
551  =head3 OpenSession  =head3 OpenSession
552    
553  C<< $shelp->OpenSession(); >>      $shelp->OpenSession($rhelp);
554    
555    Set up the session cache file and write out the column headers.
556    This method should not be called until all the columns have
557    been configured, including the extra columns.
558    
559    =over 4
560    
561  Set up to open the session cache file for writing. Note we don't actually  =item rhelp
562  open the file until after we know the column headers.  
563    Result helper for formatting the output. This has the column
564    headers stored in it.
565    
566    =back
567    
568  =cut  =cut
569    
570  sub OpenSession {  sub OpenSession {
571      # Get the parameters.      # Get the parameters.
572      my ($self) = @_;      my ($self, $rhelp) = @_;
573      # Denote we have not yet written out the column headers.      # Insure the result helper is valid.
574      $self->{cols} = undef;      if (! defined($rhelp)) {
575            Confess("No result type specified for $self->{class}.");
576        } elsif(! $rhelp->isa('ResultHelper')) {
577            Confess("Invalid result type specified for $self->{class}.");
578        } else {
579            # Get the column headers and write them out.
580            my $colHdrs = $rhelp->GetColumnHeaders();
581            Trace(scalar(@{$colHdrs}) . " column headers written to output.") if T(3);
582            $self->WriteColumnHeaders(@{$colHdrs});
583        }
584  }  }
585    
586  =head3 GetCacheFileName  =head3 GetCacheFileName
587    
588  C<< my $fileName = $shelp->GetCacheFileName(); >>      my $fileName = $shelp->GetCacheFileName();
589    
590  Return the name to be used for this session's cache file.  Return the name to be used for this session's cache file.
591    
# Line 578  Line 600 
600    
601  =head3 GetTempFileName  =head3 GetTempFileName
602    
603  C<< my $fileName = $shelp->GetTempFileName($type); >>      my $fileName = $shelp->GetTempFileName($type);
604    
605  Return the name to be used for a temporary file of the specified type. The  Return the name to be used for a temporary file of the specified type. The
606  name is computed from the session name with the type as a suffix.  name is computed from the session name with the type as a suffix.
# Line 602  Line 624 
624      my ($self, $type) = @_;      my ($self, $type) = @_;
625      # Compute the file name. Note it gets stuffed in the FIG temporary      # Compute the file name. Note it gets stuffed in the FIG temporary
626      # directory.      # directory.
627      my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";      my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
628      # Return the result.      # Return the result.
629      return $retVal;      return $retVal;
630  }  }
631    
 =head3 PutFeature  
   
 C<< $shelp->PutFeature($fdata); >>  
   
 Store a feature in the result cache. This is the workhorse method for most  
 searches, since the primary data item in the database is features.  
   
 For each feature, there are certain columns that are standard: the feature name, the  
 GBrowse and protein page links, the functional assignment, and so forth. If additional  
 columns are required by a particular search subclass, they should be stored in  
 the feature query object using the B<AddExtraColumns> method. For example, the following  
 code adds columns for essentiality and virulence.  
   
     $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  
     $shelp->PutFeature($fd);  
   
 For correct results, all values should be specified for all extra columns in all calls to  
 B<PutFeature>. (In particular, the column header names are computed on the first  
 call.) If a column is to be blank for the current feature, its value can be given  
 as C<undef>.  
   
     if (! $essentialFlag) {  
         $essentialFlag = undef;  
     }  
     $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  
     $shelp->PutFeature($fd);  
   
 =over 4  
   
 =item fdata  
   
 B<FeatureData> object containing the current feature data.  
   
 =back  
   
 =cut  
   
 sub PutFeature {  
     # Get the parameters.  
     my ($self, $fd) = @_;  
     # Get the CGI query object.  
     my $cgi = $self->Q();  
     # Get the feature data.  
     my $record = $fd->Feature();  
     my $extraCols = $fd->ExtraCols();  
     # Check for a first-call situation.  
     if (! defined $self->{cols}) {  
         # Here we need to set up the column information. Start with the defaults.  
         $self->{cols} = $self->DefaultFeatureColumns();  
         # Add any additional columns requested by the feature filter.  
         push @{$self->{cols}}, FeatureQuery::AdditionalColumns($self);  
         # Append the extras, sorted by column name.  
         for my $col (sort keys %{$extraCols}) {  
             push @{$self->{cols}}, "X=$col";  
         }  
         # Write out the column headers. This also prepares the cache file to receive  
         # output.  
         $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});  
     }  
     # Get the feature ID.  
     my $fid = $fd->FID();  
     # Loop through the column headers, producing the desired data.  
     my @output = ();  
     for my $colName (@{$self->{cols}}) {  
         push @output, $self->FeatureColumnValue($colName, $record, $extraCols);  
     }  
     # Compute the sort key. The sort key usually floats NMPDR organism features to the  
     # top of the return list.  
     my $key = $self->SortKey($fd);  
     # Write the feature data.  
     $self->WriteColumnData($key, @output);  
 }  
   
632  =head3 WriteColumnHeaders  =head3 WriteColumnHeaders
633    
634  C<< $shelp->WriteColumnHeaders(@colNames); >>      $shelp->WriteColumnHeaders(@colNames);
635    
636  Write out the column headers for the current search session. The column headers  Write out the column headers for the current search session. The column headers
637  are sent to the cache file, and then the cache is re-opened as a sort pipe and  are sent to the cache file, and then the cache is re-opened as a sort pipe and
# Line 692  Line 641 
641    
642  =item colNames  =item colNames
643    
644  A list of column names in the desired presentation order.  A list of column names in the desired presentation order. For extra columns,
645    the column name is the hash supplied as the column definition.
646    
647  =back  =back
648    
# Line 704  Line 654 
654      # Get the cache file name and open it for output.      # Get the cache file name and open it for output.
655      my $fileName = $self->GetCacheFileName();      my $fileName = $self->GetCacheFileName();
656      my $handle1 = Open(undef, ">$fileName");      my $handle1 = Open(undef, ">$fileName");
657        # Freeze the column headers.
658        my @colHdrs = map { freeze($_) } @colNames;
659      # Write the column headers and close the file.      # Write the column headers and close the file.
660      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colHdrs);
661      close $handle1;      close $handle1;
662      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
663      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
# Line 714  Line 666 
666      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
667  }  }
668    
669    =head3 ReadColumnHeaders
670    
671        my @colHdrs = $shelp->ReadColumnHeaders($fh);
672    
673    Read the column headers from the specified file handle. The column headers are
674    frozen strings intermixed with frozen hash references. The strings represent
675    column names defined in the result helper. The hash references represent the
676    definitions of the extra columns.
677    
678    =over 4
679    
680    =item fh
681    
682    File handle from which the column headers are to be read.
683    
684    =item RETURN
685    
686    Returns a list of the column headers pulled from the specified file's first line.
687    
688    =back
689    
690    =cut
691    
692    sub ReadColumnHeaders {
693        # Get the parameters.
694        my ($self, $fh) = @_;
695        # Read and thaw the columns.
696        my @retVal = map { thaw($_) } Tracer::GetLine($fh);
697        # Return them to the caller.
698        return @retVal;
699    }
700    
701  =head3 WriteColumnData  =head3 WriteColumnData
702    
703  C<< $shelp->WriteColumnData($key, @colValues); >>      $shelp->WriteColumnData($key, @colValues);
704    
705  Write a row of column values to the current search session. It is assumed that  Write a row of column values to the current search session. It is assumed that
706  the session file is already open for output.  the session file is already open for output.
# Line 740  Line 724 
724      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
725      # Write them to the cache file.      # Write them to the cache file.
726      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
727        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
728  }  }
729    
730  =head3 CloseSession  =head3 CloseSession
731    
732  C<< $shelp->CloseSession(); >>      $shelp->CloseSession();
733    
734  Close the session file.  Close the session file.
735    
# Line 758  Line 743 
743          # We found one, so close it.          # We found one, so close it.
744          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
745          close $self->{fileHandle};          close $self->{fileHandle};
746            # Tell the user.
747            my $cgi = $self->Q();
748            $self->PrintLine("Output formatting complete.<br />");
749      }      }
750  }  }
751    
 =head3 NewSessionID  
   
 C<< my $id = SearchHelpers::NewSessionID(); >>  
   
 Generate a new session ID for the current user.  
   
 =cut  
   
 sub NewSessionID {  
     # Declare the return variable.  
     my $retVal;  
     # Get a digest encoder.  
     my $md5 = Digest::MD5->new();  
     # Add the PID, the IP, and the time stamp. Note that the time stamp is  
     # actually two numbers, and we get them both because we're in list  
     # context.  
     $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());  
     # Hash up all this identifying data.  
     $retVal = $md5->hexdigest();  
     # Return the result.  
     return $retVal;  
 }  
   
752  =head3 OrganismData  =head3 OrganismData
753    
754  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>      my ($orgName, $group) = $shelp->Organism($genomeID);
755    
756  Return the name and status of the organism corresponding to the specified genome ID.  Return the name and status of the organism corresponding to the specified genome ID.
757  For performance reasons, this information is cached in a special hash table, so we  For performance reasons, this information is cached in a special hash table, so we
# Line 800  Line 765 
765    
766  =item RETURN  =item RETURN
767    
768  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
769  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
770  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
771    
772  =back  =back
773    
# Line 812  Line 777 
777      # Get the parameters.      # Get the parameters.
778      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
779      # Declare the return variables.      # Declare the return variables.
780      my ($orgName, $group);      my ($orgName, $group, $domain);
781      # Check the cache.      # Check the cache.
782      my $cache = $self->{orgs};      my $cache = $self->{orgs};
783      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
784          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
785            Trace("Cached organism $genomeID has group \"$group\".") if T(4);
786      } else {      } else {
787          # Here we have to use the database.          # Here we have to use the database.
788          my $sprout = $self->DB();          my $sprout = $self->DB();
789          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $newGroup, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
790                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
791                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
792                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
793                                                                     'Genome(taxonomy)']);
794          # Format and cache the name and display group.          # Format and cache the name and display group.
795          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,          Trace("Caching organism $genomeID with group \"$newGroup\".") if T(4);
796                                                              $strain);          ($orgName, $group, $domain) = $self->SaveOrganismData($newGroup, $genomeID, $genus, $species,
797                                                                  $strain, $taxonomy);
798            Trace("Returning group $group.") if T(4);
799      }      }
800      # Return the result.      # Return the result.
801      return ($orgName, $group);      return ($orgName, $group, $domain);
802  }  }
803    
804  =head3 Organism  =head3 Organism
805    
806  C<< my $orgName = $shelp->Organism($genomeID); >>      my $orgName = $shelp->Organism($genomeID);
807    
808  Return the name of the relevant organism. The name is computed from the genus,  Return the name of the relevant organism. The name is computed from the genus,
809  species, and unique characterization. A cache is used to improve performance.  species, and unique characterization. A cache is used to improve performance.
# Line 857  Line 826 
826      # Get the parameters.      # Get the parameters.
827      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
828      # Get the organism data.      # Get the organism data.
829      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureGroup  
   
 C<< my $groupName = $shelp->FeatureGroup($fid); >>  
   
 Return the group name for the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the relevant feature.  
   
 =item RETURN  
   
 Returns the name of the NMPDR group to which the feature belongs, or an empty  
 string if it is not part of an NMPDR group.  
   
 =back  
   
 =cut  
   
 sub FeatureGroup {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Parse the feature ID to get the genome ID.  
     my ($genomeID) = FIGRules::ParseFeatureID($fid);  
     # Get the organism data.  
     my (undef, $retVal) = $self->OrganismData($genomeID);  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureName  
   
 C<< my $fidName = $shelp->FeatureName($fid); >>  
   
 Return the display name of the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the feature whose name is desired.  
   
 =item RETURN  
   
 A displayable feature name, consisting of the organism name plus some feature  
 type and location information.  
   
 =back  
   
 =cut  
   
 sub FeatureName {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Declare the return variable  
     my $retVal;  
     # Parse the feature ID.  
     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);  
     if (! defined $genomeID) {  
         # Here the feature ID has an invalid format.  
         $retVal = "External: $fid";  
     } else {  
         # Here we can get its genome data.  
         $retVal = $self->Organism($genomeID);  
         # Append the FIG ID.  
         $retVal .= " [$fid]";  
     }  
830      # Return the result.      # Return the result.
831      return $retVal;      return $retVal;
832  }  }
833    
834  =head3 ComputeFASTA  =head3 ComputeFASTA
835    
836  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>      my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth, $comments);
837    
838  Parse a sequence input and convert it into a FASTA string of the desired type. Note  Parse a sequence input and convert it into a FASTA string of the desired type with
839  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
840    
841  =over 4  =over 4
842    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
843  =item desiredType  =item desiredType
844    
845  C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the  C<dna> to return a DNA sequence, C<prot> to return a protein sequence, C<dnaPattern>
846  I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.  to return a DNA search pattern, C<protPattern> to return a protein search pattern.
847    
848  =item sequence  =item sequence
849    
# Line 962  Line 853 
853  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
854  line will be provided.  line will be provided.
855    
856    =item flankingWidth
857    
858    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
859    feature that should be included. Currently we can't do this for Proteins because the
860    protein translation of a feature doesn't always match the DNA and is taken directly
861    from the database.
862    
863    =item comments
864    
865    Comment string to be added to the FASTA header.
866    
867  =item RETURN  =item RETURN
868    
869  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 974  Line 876 
876    
877  sub ComputeFASTA {  sub ComputeFASTA {
878      # Get the parameters.      # Get the parameters.
879      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth, $comment) = @_;
880      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
881      my $retVal;      my $retVal;
882      # This variable will be cleared if an error is detected.      # This variable will be cleared if an error is detected.
883      my $okFlag = 1;      my $okFlag = 1;
884      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
885      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
886      Trace("FASTA incoming type is $incomingType, desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
887      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
888      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
889          # Here we have a feature ID in $1. We'll need the Sprout object to process          # Here we have a feature ID in $1. We'll need the Sprout object to process
890          # it.          # it.
# Line 994  Line 896 
896          # exist.          # exist.
897          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
898          if (! $figID) {          if (! $figID) {
899              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
900              $okFlag = 0;              $okFlag = 0;
901          } else {          } else {
902              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
903              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
904                my $favorLen = length $favored;
905                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
906                if (! $fastaLabel) {
907                    # In an emergency, fall back to the original ID.
908                    $fastaLabel = $fid;
909                }
910                # Add any specified comments.
911                if ($comment) {
912                    $fastaLabel .= " $comment";
913                }
914              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
915              if ($desiredType eq 'prot') {              if ($desiredType =~ /prot/) {
916                  # We want protein, so get the translation.                  # We want protein, so get the translation.
917                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
918                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
919              } else {              } elsif ($desiredType =~ /dna/) {
920                  # We want DNA, so get the DNA sequence. This is a two-step process.                  # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
921                    # locations.
922                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
923                    if ($flankingWidth > 0) {
924                        # Here we need to add flanking data. Convert the locations to a list
925                        # of location objects.
926                        my @locObjects = map { BasicLocation->new($_) } @locList;
927                        # Initialize the return variable. We will put the DNA in here segment by segment.
928                        $fastaData = "";
929                        # Now we widen each location by the flanking width and stash the results. This
930                        # requires getting the contig length for each contig so we don't fall off the end.
931                        for my $locObject (@locObjects) {
932                            Trace("Current location is " . $locObject->String . ".") if T(4);
933                            # Remember the current start and length.
934                            my ($start, $len) = ($locObject->Left, $locObject->Length);
935                            # Get the contig length.
936                            my $contigLen = $sprout->ContigLength($locObject->Contig);
937                            # Widen the location and get its DNA.
938                            $locObject->Widen($flankingWidth, $contigLen);
939                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
940                            # Now we need to do some case changing. The main DNA is upper case and
941                            # the flanking DNA is lower case.
942                            my $leftFlank = $start - $locObject->Left;
943                            my $rightFlank = $leftFlank + $len;
944                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
945                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
946                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
947                                                    lc(substr($fastaSegment, $rightFlank));
948                            $fastaData .= $fancyFastaSegment;
949                        }
950                    } else {
951                        # Here we have just the raw sequence.
952                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
953                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);                  }
954                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
955              }              }
956          }          }
     } elsif ($incomingType eq 'prot' && $desiredType eq 'dna') {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
         $okFlag = 0;  
957      } else {      } else {
958          Trace("Analyzing FASTA sequence.") if T(4);          Trace("Analyzing FASTA sequence.") if T(4);
959          # Here we are expecting a FASTA. We need to see if there's a label.          # Here we are expecting a FASTA. We need to see if there's a label.
# Line 1027  Line 966 
966              Trace("No label found in match to sequence:\n$sequence") if T(4);              Trace("No label found in match to sequence:\n$sequence") if T(4);
967              # Here we have no label, so we create one and use the entire sequence              # Here we have no label, so we create one and use the entire sequence
968              # as data.              # as data.
969              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "$desiredType sequence specified by user";
970              $fastaData = $sequence;              $fastaData = $sequence;
971          }          }
972          # The next step is to clean the junk out of the sequence.          # If we are not doing a pattern search, we need to clean the junk out of the sequence.
973            if ($desiredType !~ /pattern/i) {
974          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
975          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
         # Finally, if the user wants to convert to protein, we do it here. Note that  
         # we've already prevented a conversion from protein to DNA.  
         if ($incomingType ne $desiredType) {  
             $fastaData = Sprout::Protein($fastaData);  
             # Check for bad characters.  
             if ($fastaData =~ /X/) {  
                 $self->SetMessage("Invalid characters detected. Is the input really of type $incomingType?");  
                 $okFlag = 0;  
976              }              }
977          } elsif ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {          # Finally, verify that it's DNA if we're doing DNA stuff.
978              $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
979                $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
980              $okFlag = 0;              $okFlag = 0;
981          }          }
982      }      }
983      Trace("FASTA data sequence: $fastaData") if T(4);      Trace("FASTA data sequence: $fastaData") if T(4);
984      # Only proceed if no error was detected.      # Only proceed if no error was detected.
985      if ($okFlag) {      if ($okFlag) {
986            if ($desiredType =~ /pattern/i) {
987                # For a scan, there is no label and no breakup.
988                $retVal = $fastaData;
989            } else {
990          # We need to format the sequence into 60-byte chunks. We use the infamous          # We need to format the sequence into 60-byte chunks. We use the infamous
991          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
992          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
# Line 1058  Line 995 
995          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
996          $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
997      }      }
998        }
999      # Return the result.      # Return the result.
1000      return $retVal;      return $retVal;
1001  }  }
1002    
1003    =head3 SubsystemTree
1004    
1005        my $tree = SearchHelper::SubsystemTree($sprout, %options);
1006    
1007    This method creates a subsystem selection tree suitable for passing to
1008    L</SelectionTree>. Each leaf node in the tree will have a link to the
1009    subsystem display page. In addition, each node can have a radio button. The
1010    radio button alue is either C<classification=>I<string>, where I<string> is
1011    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1012    Thus, it can either be used to filter by a group of related subsystems or a
1013    single subsystem.
1014    
1015    =over 4
1016    
1017    =item sprout
1018    
1019    Sprout database object used to get the list of subsystems.
1020    
1021    =item options
1022    
1023    Hash containing options for building the tree.
1024    
1025    =item RETURN
1026    
1027    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1028    
1029    =back
1030    
1031    The supported options are as follows.
1032    
1033    =over 4
1034    
1035    =item radio
1036    
1037    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1038    
1039    =item links
1040    
1041    TRUE if the tree should be configured for links. The default is TRUE.
1042    
1043    =back
1044    
1045    =cut
1046    
1047    sub SubsystemTree {
1048        # Get the parameters.
1049        my ($sprout, %options) = @_;
1050        # Process the options.
1051        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1052        # Read in the subsystems.
1053        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1054                                   ['Subsystem(classification)', 'Subsystem(id)']);
1055        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1056        # is at the end, ALL subsystems are unclassified and we don't bother.
1057        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1058            while ($subs[0]->[0] eq '') {
1059                my $classLess = shift @subs;
1060                push @subs, $classLess;
1061            }
1062        }
1063        # Get the seedviewer URL.
1064        my $svURL = $FIG_Config::linkinSV || "$FIG_Config::cgi_url/seedviewer.cgi";
1065        Trace("Seed Viewer URL is $svURL.") if T(3);
1066        # Declare the return variable.
1067        my @retVal = ();
1068        # Each element in @subs represents a leaf node, so as we loop through it we will be
1069        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1070        # first element is a semi-colon-delimited list of the classifications for the
1071        # subsystem. There will be a stack of currently-active classifications, which we will
1072        # compare to the incoming classifications from the end backward. A new classification
1073        # requires starting a new branch. A different classification requires closing an old
1074        # branch and starting a new one. Each classification in the stack will also contain
1075        # that classification's current branch. We'll add a fake classification at the
1076        # beginning that we can use to represent the tree as a whole.
1077        my $rootName = '<root>';
1078        # Create the classification stack. Note the stack is a pair of parallel lists,
1079        # one containing names and the other containing content.
1080        my @stackNames = ($rootName);
1081        my @stackContents = (\@retVal);
1082        # Add a null entry at the end of the subsystem list to force an unrolling.
1083        push @subs, ['', undef];
1084        # Loop through the subsystems.
1085        for my $sub (@subs) {
1086            # Pull out the classification list and the subsystem ID.
1087            my ($classString, $id) = @{$sub};
1088            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1089            # Convert the classification string to a list with the root classification in
1090            # the front.
1091            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1092            # Find the leftmost point at which the class list differs from the stack.
1093            my $matchPoint = 0;
1094            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1095                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1096                $matchPoint++;
1097            }
1098            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1099                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1100            # Unroll the stack to the matchpoint.
1101            while ($#stackNames >= $matchPoint) {
1102                my $popped = pop @stackNames;
1103                pop @stackContents;
1104                Trace("\"$popped\" popped from stack.") if T(4);
1105            }
1106            # Start branches for any new classifications.
1107            while ($#stackNames < $#classList) {
1108                # The branch for a new classification contains its radio button
1109                # data and then a list of children. So, at this point, if radio buttons
1110                # are desired, we put them into the content.
1111                my $newLevel = scalar(@stackNames);
1112                my @newClassContent = ();
1113                if ($optionThing->{radio}) {
1114                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1115                    push @newClassContent, { value => "classification=$newClassString%" };
1116                }
1117                # The new classification node is appended to its parent's content
1118                # and then pushed onto the stack. First, we need the node name.
1119                my $nodeName = $classList[$newLevel];
1120                # Add the classification to its parent. This makes it part of the
1121                # tree we'll be returning to the user.
1122                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1123                # Push the classification onto the stack.
1124                push @stackContents, \@newClassContent;
1125                push @stackNames, $nodeName;
1126                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1127            }
1128            # Now the stack contains all our parent branches. We add the subsystem to
1129            # the branch at the top of the stack, but only if it's NOT the dummy node.
1130            if (defined $id) {
1131                # Compute the node name from the ID.
1132                my $nodeName = $id;
1133                $nodeName =~ s/_/ /g;
1134                # Create the node's leaf hash. This depends on the value of the radio
1135                # and link options.
1136                my $nodeContent = {};
1137                if ($optionThing->{links}) {
1138                    # Compute the link value.
1139                    my $linkable = uri_escape($id);
1140                    $nodeContent->{link} = "$svURL?page=Subsystems;subsystem=$linkable";
1141                }
1142                if ($optionThing->{radio}) {
1143                    # Compute the radio value.
1144                    $nodeContent->{value} = "id=$id";
1145                }
1146                # Push the node into its parent branch.
1147                Trace("\"$nodeName\" added to node list.") if T(4);
1148                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1149            }
1150        }
1151        # Return the result.
1152        return \@retVal;
1153    }
1154    
1155    
1156  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1157    
1158  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>      my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows);
1159    
1160  This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The  This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1161  category indicates the low-level NMPDR group. Organizing the genomes in this way makes it  category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
# Line 1093  Line 1184 
1184    
1185  =item crossMenu (optional)  =item crossMenu (optional)
1186    
1187  If specified, is presumed to be the name of another genome menu whose contents  This is currently not supported.
 are to be mutually exclusive with the contents of this menu. As a result, instead  
 of the standard onChange event, the onChange event will deselect any entries in  
 the other menu.  
1188    
1189  =item RETURN  =item RETURN
1190    
# Line 1116  Line 1204 
1204      if (! defined $rows) {      if (! defined $rows) {
1205          $rows = ($multiple ? 10 : 1);          $rows = ($multiple ? 10 : 1);
1206      }      }
1207      # Create the multiple tag.      # Get a comma-delimited list of the preselected genomes.
1208      my $multipleTag = ($multiple ? " multiple" : "");      my $preselected = "";
1209      # Get the form name.      if ($selected) {
1210      my $formName = $self->FormName();          $preselected = join(", ", @$selected);
1211      # Check to see if we already have a genome list in memory.      }
1212      my $genomes = $self->{genomeList};      # Ask Sprout for a genome menu.
1213      my $groupHash;      my $retVal = $sprout->GenomeMenu(name => $menuName,
1214      if (defined $genomes) {                                       multiSelect => $multiple,
1215          # We have a list ready to use.                                       selected => $preselected,
1216          $groupHash = $genomes;                                       size => $rows);
     } else {  
         # Get a list of all the genomes in group order. In fact, we only need them ordered  
         # by name (genus,species,strain), but putting primary-group in front enables us to  
         # take advantage of an existing index.  
         my @genomeList = $sprout->GetAll(['Genome'],  
                                          "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",  
                                          [], ['Genome(primary-group)', 'Genome(id)',  
                                               'Genome(genus)', 'Genome(species)',  
                                               'Genome(unique-characterization)']);  
         # Create a hash to organize the genomes by group. Each group will contain a list of  
         # 2-tuples, the first element being the genome ID and the second being the genome  
         # name.  
         my %gHash = ();  
         for my $genome (@genomeList) {  
             # Get the genome data.  
             my ($group, $genomeID, $genus, $species, $strain) = @{$genome};  
             # Compute and cache its name and display group.  
             my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,  
                                                                 $strain);  
             # Push the genome into the group's list. Note that we use the real group  
             # name here, not the display group name.  
             push @{$gHash{$group}}, [$genomeID, $name];  
         }  
         # Save the genome list for future use.  
         $self->{genomeList} = \%gHash;  
         $groupHash = \%gHash;  
     }  
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};  
     push @groups, $FIG_Config::otherGroup;  
     # Next, create a hash that specifies the pre-selected entries. Note that we need to deal  
     # with the possibility of undefined values in the incoming list.  
     my %selectedHash = ();  
     if (defined $selected) {  
         %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};  
     }  
     # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage  
     # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes  
     # and use that to make the selections.  
     my $nmpdrCount = 0;  
     # Create the type counters.  
     my $groupCount = 1;  
     # Compute the ID for the status display.  
     my $divID = "${formName}_${menuName}_status";  
     # Compute the JavaScript call for updating the status.  
     my $showSelect = "showSelected($menuName, '$divID', 1000);";  
     # If multiple selection is supported, create an onChange event.  
     my $onChange = "";  
     if ($cross) {  
         # Here we have a paired menu. Selecting something in our menu unselects it in the  
         # other and redisplays the status of both.  
         $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";  
     } elsif ($multiple) {  
         # This is an unpaired menu, so all we do is redisplay our status.  
         $onChange = " onChange=\"$showSelect\"";  
     }  
     # Create the SELECT tag and stuff it into the output array.  
     my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");  
     # Loop through the groups.  
     for my $group (@groups) {  
         # Create the option group tag.  
         my $tag = "<OPTGROUP label=\"$group\">";  
         push @lines, "  $tag";  
         # Get the genomes in the group.  
         for my $genome (@{$groupHash->{$group}}) {  
             # Count this organism if it's NMPDR.  
             if ($group ne $FIG_Config::otherGroup) {  
                 $nmpdrCount++;  
             }  
             # Get the organism ID and name.  
             my ($genomeID, $name) = @{$genome};  
             # See if it's selected.  
             my $select = ($selectedHash{$genomeID} ? " selected" : "");  
             # Generate the option tag.  
             my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";  
             push @lines, "    $optionTag";  
         }  
         # Close the option group.  
         push @lines, "  </OPTGROUP>";  
     }  
     # Close the SELECT tag.  
     push @lines, "</SELECT>";  
     # Check for multiple selection.  
     if ($multiple) {  
         # Since multi-select is on, we set up some buttons to set and clear selections.  
         push @lines, "<br />";  
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";  
         # Now add the search box. This allows the user to type text and have all genomes containing  
         # the text selected automatically.  
         my $searchThingName = "${menuName}_SearchThing";  
         push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .  
                      "<INPUT type=\"button\" name=\"Select\" class=\"button\" value=\"Search\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";  
         # Add the status display, too.  
         push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";  
         # Queue to update the status display when the form loads. We need to modify the show statement  
         # slightly because the queued statements are executed outside the form. This may seem like a lot of  
         # trouble, but we want all of the show statement calls to be generated from a single line of code,  
         # in case we decide to twiddle the parameters.  
         $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;  
         $self->QueueFormScript($showSelect);  
         # Finally, add this parameter to the list of genome parameters. This enables us to  
         # easily find all the parameters used to select one or more genomes.  
         push @{$self->{genomeParms}}, $menuName;  
     }  
     # Assemble all the lines into a string.  
     my $retVal = join("\n", @lines, "");  
1217      # Return the result.      # Return the result.
1218      return $retVal;      return $retVal;
1219  }  }
1220    
1221  =head3 PropertyMenu  =head3 PropertyMenu
1222    
1223  C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>      my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force);
1224    
1225  Generate a property name dropdown menu.  Generate a property name dropdown menu.
1226    
# Line 1292  Line 1270 
1270    
1271  =head3 MakeTable  =head3 MakeTable
1272    
1273  C<< my $htmlText = $shelp->MakeTable(\@rows); >>      my $htmlText = $shelp->MakeTable(\@rows);
1274    
1275  Create a table from a group of table rows. The table rows must be fully pre-formatted: in  Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1276  other words, each must have the TR and TD tags included.  other words, each must have the TR and TD tags included.
# Line 1308  Line 1286 
1286  =item rows  =item rows
1287    
1288  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1289  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1290  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1291    
1292  =item RETURN  =item RETURN
1293    
# Line 1324  Line 1302 
1302      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1303      # Get the CGI object.      # Get the CGI object.
1304      my $cgi = $self->Q();      my $cgi = $self->Q();
1305      # Fix the widths on the first column. Note that we eschew the use of the "g"      # The first column of the first row must have its width fixed.
1306        # This flag will be set to FALSE when that happens.
1307        my $needWidth = 1;
1308      # modifier becase we only want to change the first tag. Also, if a width      # modifier becase we only want to change the first tag. Also, if a width
1309      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1310      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1311          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1312            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1313                # Here we have a first cell and its tag parameters are in $2.
1314                my $elements = $2;
1315                if ($elements !~ /colspan/i) {
1316                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1317                    # Here there's no colspan, so we plug in the width. We
1318                    # eschew the "g" modifier on the substitution because we
1319                    # only want to update the first cell.
1320                    $row =~ s/(<(td|th))/$1 width="150"/i;
1321                    # Denote we don't need this any more.
1322                    $needWidth = 0;
1323                }
1324            }
1325      }      }
1326      # Create the table.      # Create the table.
1327      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1340  Line 1333 
1333    
1334  =head3 SubmitRow  =head3 SubmitRow
1335    
1336  C<< my $htmlText = $shelp->SubmitRow(); >>      my $htmlText = $shelp->SubmitRow($caption);
1337    
1338  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1339  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1340  near the top of the form.  near the top of the form.
1341    
 =cut  
   
 sub SubmitRow {  
     # Get the parameters.  
     my ($self) = @_;  
     my $cgi = $self->Q();  
     # Get the current page size.  
     my $pageSize = $cgi->param('PageSize');  
     # Get the incoming external-link flag.  
     my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);  
     # Create the row.  
     my $retVal = $cgi->Tr($cgi->td("Results/Page"),  
                           $cgi->td($cgi->popup_menu(-name => 'PageSize',  
                                                     -values => [10, 25, 50, 100, 1000],  
                                                     -default => $pageSize) . " " .  
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
                           $cgi->td($cgi->submit(-class => 'goButton',  
                                                 -name => 'Search',  
                                                 -value => 'Go')));  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureFilterRows  
   
 C<< my $htmlText = $shelp->FeatureFilterRows(); >>  
   
 This method creates table rows that can be used to filter features. The form  
 values can be used to select features by genome using the B<FeatureQuery>  
 object.  
   
 =cut  
   
 sub FeatureFilterRows {  
     # Get the parameters.  
     my ($self) = @_;  
     # Return the result.  
     return FeatureQuery::FilterRows($self);  
 }  
   
 =head3 GBrowseFeatureURL  
   
 C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  
   
 Compute the URL required to pull up a Gbrowse page for the the specified feature.  
 In order to do this, we need to pull out the ID of the feature's Genome, its  
 contig ID, and some rough starting and stopping offsets.  
   
1342  =over 4  =over 4
1343    
1344  =item sprout  =item caption (optional)
   
 Sprout object for accessing the database.  
   
 =item feat  
1345    
1346  ID of the feature whose Gbrowse URL is desired.  Caption to be put on the search button. The default is C<Go>.
1347    
1348  =item RETURN  =item RETURN
1349    
1350  Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome  Returns a table row containing the controls for submitting the search
1351  ID, contig ID, starting offset, and stopping offset.  and tuning the results.
1352    
1353  =back  =back
1354    
1355  =cut  =cut
1356    
1357  sub GBrowseFeatureURL {  sub SubmitRow {
1358      # Get the parameters.      # Get the parameters.
1359      my ($sprout, $feat) = @_;      my ($self, $caption) = @_;
1360      # Declare the return variable.      my $cgi = $self->Q();
1361      my $retVal;      # Compute the button caption.
1362      # Compute the genome ID.      my $realCaption = (defined $caption ? $caption : 'Go');
1363      my ($genomeID) = FIGRules::ParseFeatureID($feat);      # Get the current page size.
1364      # Only proceed if the feature ID produces a valid genome.      my $pageSize = $cgi->param('PageSize');
1365      if ($genomeID) {      # Get the current feature ID type.
1366          # Get the feature location string.      my $aliasType = $self->GetPreferredAliasType();
1367          my $loc = $sprout->FeatureLocation($feat);      # Create the rows.
1368          # Compute the contig, start, and stop points.      my $retVal = $cgi->Tr($cgi->td("Identifier Type "),
1369          my($contig, $start, $stop) = BasicLocation::Parse($loc);                            $cgi->td({ colspan => 2 },
1370          Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);                                     $cgi->popup_menu(-name => 'AliasType',
1371          # Now we need to do some goofiness to insure that the location is not too                                                      -values => ['FIG', AliasAnalysis::AliasTypes() ],
1372          # big and that we get some surrounding stuff.                                                      -default => $aliasType) .
1373          my $mid = int(($start + $stop) / 2);                                     Hint("Identifier Type", "Specify how you want gene names to be displayed."))) .
1374          my $chunk_len = 20000;                   "\n" .
1375          my $max_feature = 40000;                   $cgi->Tr($cgi->td("Results/Page"),
1376          my $feat_len = abs($stop - $start);                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1377          if ($feat_len > $chunk_len) {                                                      -values => [10, 25, 50, 100, 1000],
1378              if ($feat_len > $max_feature) {                                                      -default => $pageSize)),
1379                  $chunk_len = $max_feature;                            $cgi->td($cgi->submit(-class => 'goButton',
1380              } else {                                                  -name => 'Search',
1381                  $chunk_len = $feat_len + 100;                                                  -value => $realCaption)));
             }  
         }  
         my($show_start, $show_stop);  
         if ($chunk_len == $max_feature) {  
             $show_start = $start - 300;  
         } else {  
             $show_start = $mid - int($chunk_len / 2);  
         }  
         if ($show_start < 1) {  
             $show_start = 1;  
         }  
         $show_stop = $show_start + $chunk_len - 1;  
         my $clen = $sprout->ContigLength($contig);  
         if ($show_stop > $clen) {  
             $show_stop = $clen;  
         }  
         my $seg_id = $contig;  
         $seg_id =~ s/:/--/g;  
         Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);  
         # Assemble all the pieces.  
         $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";  
     }  
1382      # Return the result.      # Return the result.
1383      return $retVal;      return $retVal;
1384  }  }
1385    
1386  =head3 GetGenomes  =head3 GetGenomes
1387    
1388  C<< my @genomeList = $shelp->GetGenomes($parmName); >>      my @genomeList = $shelp->GetGenomes($parmName);
1389    
1390  Return the list of genomes specified by the specified CGI query parameter.  Return the list of genomes specified by the specified CGI query parameter.
1391  If the request method is POST, then the list of genome IDs is returned  If the request method is POST, then the list of genome IDs is returned
# Line 1510  Line 1427 
1427      return @retVal;      return @retVal;
1428  }  }
1429    
 =head3 GetHelpText  
   
 C<< my $htmlText = $shelp->GetHelpText(); >>  
   
 Get the help text for this search. The help text is stored in files on the template  
 server. The help text for a specific search is taken from a file named  
 C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.  
 There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the  
 feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>  
 describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>  
 describes the standard controls for a search, such as page size, URL display, and  
 external alias display.  
   
 =cut  
   
 sub GetHelpText {  
     # Get the parameters.  
     my ($self) = @_;  
     # Create a list to hold the pieces of the help.  
     my @helps = ();  
     # Get the template directory URL.  
     my $urlBase = $FIG_Config::template_url;  
     # Start with the specific help.  
     my $class = $self->{class};  
     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");  
     # Add the genome control help if needed.  
     if (scalar @{$self->{genomeParms}}) {  
         push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");  
     }  
     # Next the filter help.  
     if ($self->{filtered}) {  
         push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");  
     }  
     # Finally, the standard help.  
     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");  
     # Assemble the pieces.  
     my $retVal = join("\n<p>&nbsp;</p>\n", @helps);  
     # Return the result.  
     return $retVal;  
 }  
   
1430  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1431    
1432  C<< my $url = $shelp->ComputeSearchURL(); >>      my $url = $shelp->ComputeSearchURL(%overrides);
1433    
1434  Compute the GET-style URL for the current search. In order for this to work, there  Compute the GET-style URL for the current search. In order for this to work, there
1435  must be a copy of the search form on the current page. This will always be the  must be a copy of the search form on the current page. This will always be the
# Line 1563  Line 1439 
1439  main complication is that if the user specified all genomes, we'll want to  main complication is that if the user specified all genomes, we'll want to
1440  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1441    
1442    =over 4
1443    
1444    =item overrides
1445    
1446    Hash containing override values for the parameters, where the parameter name is
1447    the key and the parameter value is the override value. If the override value is
1448    C<undef>, the parameter will be deleted from the result.
1449    
1450    =item RETURN
1451    
1452    Returns a GET-style URL for invoking the search with the specified overrides.
1453    
1454    =back
1455    
1456  =cut  =cut
1457    
1458  sub ComputeSearchURL {  sub ComputeSearchURL {
1459      # Get the parameters.      # Get the parameters.
1460      my ($self) = @_;      my ($self, %overrides) = @_;
1461      # Get the database and CGI query object.      # Get the database and CGI query object.
1462      my $cgi = $self->Q();      my $cgi = $self->Q();
1463      my $sprout = $self->DB();      my $sprout = $self->DB();
1464      # Start with the full URL.      # Start with the full URL.
1465      my $retVal = $cgi->url(-full => 1);      my $retVal = "$FIG_Config::cgi_url/SearchSkeleton.cgi";
1466      # Get all the query parameters in a hash.      # Get all the query parameters in a hash.
1467      my %parms = $cgi->Vars();      my %parms = $cgi->Vars();
1468      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
# Line 1594  Line 1484 
1484          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1485          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1486          # Check for special cases.          # Check for special cases.
1487          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1488              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1489              @values = ();              @values = ();
1490          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1608  Line 1498 
1498              if ($allFlag) {              if ($allFlag) {
1499                  @values = ();                  @values = ();
1500              }              }
1501            } elsif (exists $overrides{$parmKey}) {
1502                # Here the value is being overridden, so we skip it for now.
1503                @values = ();
1504          }          }
1505          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1506          if (@values) {          if (@values) {
1507              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1508          }          }
1509      }      }
1510        # Now do the overrides.
1511        for my $overKey (keys %overrides) {
1512            # Only use this override if it's not a delete marker.
1513            if (defined $overrides{$overKey}) {
1514                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1515            }
1516        }
1517      # Add the parameters to the URL.      # Add the parameters to the URL.
1518      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1519      # Return the result.      # Return the result.
1520      return $retVal;      return $retVal;
1521  }  }
1522    
1523  =head3 GetRunTimeValue  =head3 AdvancedClassList
1524    
1525        my @classes = SearchHelper::AdvancedClassList();
1526    
1527    Return a list of advanced class names. This list is used to generate the directory
1528    of available searches on the search page.
1529    
1530  C<< my $htmlText = $shelp->GetRunTimeValue($text); >>  We do a file search to accomplish this, but to pull it off we need to look at %INC.
1531    
1532  Compute a run-time column value.  =cut
1533    
1534    sub AdvancedClassList {
1535        # Determine the search helper module directory.
1536        my $libDirectory = $INC{'SearchHelper.pm'};
1537        $libDirectory =~ s/SearchHelper\.pm//;
1538        # Read it, keeping only the helper modules.
1539        my @modules = grep { /^SH\w+\.pm/ } Tracer::OpenDir($libDirectory, 0);
1540        # Convert the file names to search types.
1541        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } @modules;
1542        # Return the result in alphabetical order.
1543        return sort @retVal;
1544    }
1545    
1546    =head3 SelectionTree
1547    
1548        my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options);
1549    
1550    Display a selection tree.
1551    
1552    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1553    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1554    addition, some of the tree nodes can contain hyperlinks.
1555    
1556    The tree itself is passed in as a multi-level list containing node names followed by
1557    contents. Each content element is a reference to a similar list. The first element of
1558    each list may be a hash reference. If so, it should contain one or both of the following
1559    keys.
1560    
1561  =over 4  =over 4
1562    
1563  =item text  =item link
1564    
1565  The run-time column text. It consists of 2 percent signs, a column type, an equal  The navigation URL to be popped up if the user clicks on the node name.
 sign, and the data for the current row.  
1566    
1567  =item RETURN  =item value
1568    
1569  Returns the fully-formatted HTML text to go into the current column of the current row.  The form value to be returned if the user selects the tree node.
1570    
1571  =back  =back
1572    
1573  =cut  The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1574    a C<value> key indicates the node name will have a radio button. If a node has no children,
1575    you may pass it a hash reference instead of a list reference.
1576    
1577  sub GetRunTimeValue {  The following example shows the hash for a three-level tree with links on the second level and
1578      # Get the parameters.  radio buttons on the third.
     my ($self, $text) = @_;  
     # Declare the return variable.  
     my $retVal;  
     # Parse the incoming text.  
     if ($text =~ /^%%([^=]+)=(.*)$/) {  
         $retVal = $self->RunTimeColumns($1, $2);  
     } else {  
         Confess("Invalid run-time column string \"$text\" encountered in session file.");  
     }  
     # Return the result.  
     return $retVal;  
 }  
1579    
1580  =head3 AdvancedClassList      [   Objects => [
1581                Entities => [
1582                    {link => "../docs/WhatIsAnEntity.html"},
1583                    Genome => {value => 'GenomeData'},
1584                    Feature => {value => 'FeatureData'},
1585                    Contig => {value => 'ContigData'},
1586                ],
1587                Relationships => [
1588                    {link => "../docs/WhatIsARelationShip.html"},
1589                    HasFeature => {value => 'GenomeToFeature'},
1590                    IsOnContig => {value => 'FeatureToContig'},
1591                ]
1592            ]
1593        ]
1594    
1595  C<< my @classes = SearchHelper::AdvancedClassList(); >>  Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1596    all have list references.
1597    
1598  Return a list of advanced class names. This list is used to generate the directory  This next example shows how to set up a taxonomy selection field. The value returned
1599  of available searches on the search page.  by the tree control will be the taxonomy string for the selected node ready for use
1600    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1601    reasons of space.
1602    
1603  The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>      [   All => [
1604  script is only able to insert strings into the generated B<FIG_Config> file.              {value => "%"},
1605                Bacteria => [
1606                    {value => "Bacteria%"},
1607                    Proteobacteria => [
1608                        {value => "Bacteria; Proteobacteria%"},
1609                        Epsilonproteobacteria => [
1610                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1611                            Campylobacterales => [
1612                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1613                                Campylobacteraceae =>
1614                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1615                                ...
1616                            ]
1617                            ...
1618                        ]
1619                        ...
1620                    ]
1621                    ...
1622                ]
1623                ...
1624            ]
1625        ]
1626    
 =cut  
1627    
1628  sub AdvancedClassList {  This method of tree storage allows the caller to control the order in which the tree nodes
1629      return split /\s+/, $FIG_Config::advanced_classes;  are displayed and to completely control value selection and use of hyperlinks. It is, however
1630    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1631    
1632    The parameters to this method are as follows.
1633    
1634    =over 4
1635    
1636    =item cgi
1637    
1638    CGI object used to generate the HTML.
1639    
1640    =item tree
1641    
1642    Reference to a hash describing a tree. See the description above.
1643    
1644    =item options
1645    
1646    Hash containing options for the tree display.
1647    
1648    =back
1649    
1650    The allowable options are as follows
1651    
1652    =over 4
1653    
1654    =item nodeImageClosed
1655    
1656    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1657    on the image will expand a section of the tree. The default is C<plus.gif>.
1658    
1659    =item nodeImageOpen
1660    
1661    URL of the image to display next to the tree nodes when they are expanded. Clicking
1662    on the image will collapse a section of the tree. The default is C<minus.gif>.
1663    
1664    =item style
1665    
1666    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1667    as nested lists, the key components of this style are the definitions for the C<ul> and
1668    C<li> tags. The default style file contains the following definitions.
1669    
1670        .tree ul {
1671           margin-left: 0; padding-left: 22px
1672        }
1673        .tree li {
1674            list-style-type: none;
1675  }  }
1676    
1677  =head2 Feature Column Methods  The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1678    parent by the width of the node image. This use of styles limits the things we can do in formatting
1679    the tree, but it has the advantage of vastly simplifying the tree creation.
1680    
1681  The methods in this column manage feature column data. If you want to provide the  =item name
 capability to include new types of data in feature columns, then all the changes  
 are made to this section of the source file. Technically, this should be implemented  
 using object-oriented methods, but this is simpler for non-programmers to maintain.  
 To add a new column of feature data, you must first give it a name. For example,  
 the name for the protein page link column is C<protlink>. If the column is to appear  
 in the default list of feature columns, add it to the list returned by  
 L</DefaultFeatureColumns>. Then add code to produce the column title to  
 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  
 everything else will happen automatically.  
1682    
1683  There is one special column name syntax for extra columns (that is, nonstandard  Field name to give to the radio buttons in the tree. The default is C<selection>.
 feature columns). If the column name begins with C<X=>, then it is presumed to be  
 an extra column. The column title is the text after the C<X=>, and its value is  
 pulled from the extra column hash.  
1684    
1685  =head3 DefaultFeatureColumns  =item target
1686    
1687  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Frame target for links. The default is C<_self>.
1688    
1689  Return a reference to a list of the default feature column identifiers. These  =item selected
1690  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
1691  order to produce the column titles and row values.  If specified, the value of the radio button to be pre-selected.
1692    
1693    =back
1694    
1695  =cut  =cut
1696    
1697  sub DefaultFeatureColumns {  sub SelectionTree {
1698      # Get the parameters.      # Get the parameters.
1699      my ($self) = @_;      my ($cgi, $tree, %options) = @_;
1700        # Get the options.
1701        my $optionThing = Tracer::GetOptions({ name => 'selection',
1702                                               nodeImageClosed => "$FIG_Config::cgi_url/Html/plus.gif",
1703                                               nodeImageOpen => "$FIG_Config::cgi_url/Html/minus.gif",
1704                                               style => 'tree',
1705                                               target => '_self',
1706                                               selected => undef},
1707                                             \%options);
1708        # Declare the return variable. We'll do the standard thing with creating a list
1709        # of HTML lines and rolling them together at the end.
1710        my @retVal = ();
1711        # Only proceed if the tree is present.
1712        if (defined($tree)) {
1713            # Validate the tree.
1714            if (ref $tree ne 'ARRAY') {
1715                Confess("Selection tree is not a list reference.");
1716            } elsif (scalar @{$tree} == 0) {
1717                # The tree is empty, so we do nothing.
1718            } elsif ($tree->[0] eq 'HASH') {
1719                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
1720            } else {
1721                # Here we have a real tree. Apply the tree style.
1722                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
1723                # Give us a DIV ID.
1724                my $divID = GetDivID($optionThing->{name});
1725                # Show the tree.
1726                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
1727                # Close the DIV block.
1728                push @retVal, $cgi->end_div();
1729            }
1730        }
1731      # Return the result.      # Return the result.
1732      return ['orgName', 'function', 'gblink', 'protlink',      return join("\n", @retVal, "");
             FeatureQuery::AdditionalColumns($self)];  
1733  }  }
1734    
1735  =head3 FeatureColumnTitle  =head3 ShowBranch
1736    
1737  C<< my $title = $shelp->FeatureColumnTitle($colName); >>      my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType);
1738    
1739  Return the column heading title to be used for the specified feature column.  This is a recursive method that displays a branch of the tree.
1740    
1741  =over 4  =over 4
1742    
1743  =item name  =item cgi
1744    
1745    CGI object used to format HTML.
1746    
1747    =item label
1748    
1749    Label of this tree branch. It is only used in error messages.
1750    
1751    =item id
1752    
1753    ID to be given to this tree branch. The ID is used in the code that expands and collapses
1754    tree nodes.
1755    
1756    =item branch
1757    
1758    Reference to a list containing the content of the tree branch. The list contains an optional
1759    hash reference that is ignored and the list of children, each child represented by a name
1760    and then its contents. The contents could by a hash reference (indicating the attributes
1761    of a leaf node), or another tree branch.
1762    
1763  Name of the desired feature column.  =item options
1764    
1765    Options from the original call to L</SelectionTree>.
1766    
1767    =item displayType
1768    
1769    C<block> if the contents of this list are to be displayed, C<none> if they are to be
1770    hidden.
1771    
1772  =item RETURN  =item RETURN
1773    
1774  Returns the title to be used as the column header for the named feature column.  Returns one or more HTML lines that can be used to display the tree branch.
1775    
1776  =back  =back
1777    
1778  =cut  =cut
1779    
1780  sub FeatureColumnTitle {  sub ShowBranch {
1781      # Get the parameters.      # Get the parameters.
1782      my ($self, $colName) = @_;      my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
1783      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
1784      my $retVal = "&nbsp;";      my @retVal = ();
1785      # Process the column name.      # Start the branch.
1786      if ($colName =~ /^X=(.+)$/) {      push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
1787          # Here we have an extra column.      # Check for the hash and choose the start location accordingly.
1788          $retVal = $1;      my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
1789      } elsif ($colName eq 'alias') {      # Get the list length.
1790          $retVal = "External Aliases";      my $i1 = scalar(@{$branch});
1791      } elsif ($colName eq 'fid') {      # Verify we have an even number of elements.
1792          $retVal = "FIG ID";      if (($i1 - $i0) % 2 != 0) {
1793      } elsif ($colName eq 'function') {          Trace("Branch elements are from $i0 to $i1.") if T(3);
1794          $retVal = "Functional Assignment";          Confess("Odd number of elements in tree branch $label.");
1795      } elsif ($colName eq 'gblink') {      } else {
1796          $retVal = "GBrowse";          # Loop through the elements.
1797      } elsif ($colName eq 'group') {          for (my $i = $i0; $i < $i1; $i += 2) {
1798          $retVal = "NMDPR Group";              # Get this node's label and contents.
1799      } elsif ($colName =~ /^keyword:(.+)$/) {              my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
1800          $retVal = ucfirst $1;              # Get an ID for this node's children (if any).
1801      } elsif ($colName eq 'orgName') {              my $myID = GetDivID($options->{name});
1802          $retVal = "Name";              # Now we need to find the list of children and the options hash.
1803      } elsif ($colName eq 'protlink') {              # This is a bit ugly because we allow the shortcut of a hash without an
1804          $retVal = "NMPDR Protein Page";              # enclosing list. First, we need some variables.
1805      } elsif ($colName eq 'subsystem') {              my $attrHash = {};
1806          $retVal = "Subsystems";              my @childHtml = ();
1807                my $hasChildren = 0;
1808                if (! ref $myContent) {
1809                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
1810                } elsif (ref $myContent eq 'HASH') {
1811                    # Here the node is a leaf and its content contains the link/value hash.
1812                    $attrHash = $myContent;
1813                } elsif (ref $myContent eq 'ARRAY') {
1814                    # Here the node may be a branch. Its content is a list.
1815                    my $len = scalar @{$myContent};
1816                    if ($len >= 1) {
1817                        # Here the first element of the list could by the link/value hash.
1818                        if (ref $myContent->[0] eq 'HASH') {
1819                            $attrHash = $myContent->[0];
1820                            # If there's data in the list besides the hash, it's our child list.
1821                            # We can pass the entire thing as the child list, because the hash
1822                            # is ignored.
1823                            if ($len > 1) {
1824                                $hasChildren = 1;
1825                            }
1826                        } else {
1827                            $hasChildren = 1;
1828      }      }
1829                        # If we have children, create the child list with a recursive call.
1830                        if ($hasChildren) {
1831                            Trace("Processing children of $myLabel.") if T(4);
1832                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'block');
1833                            Trace("Children of $myLabel finished.") if T(4);
1834                        }
1835                    }
1836                }
1837                # Okay, it's time to pause and take stock. We have the label of the current node
1838                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
1839                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
1840                # Compute the image HTML. It's tricky, because we have to deal with the open and
1841                # closed images.
1842                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
1843                my $image = $images[$hasChildren];
1844                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
1845                if ($hasChildren) {
1846                    # If there are children, we wrap the image in a toggle hyperlink.
1847                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
1848                                          $prefixHtml);
1849                }
1850                # Now the radio button, if any. Note we use "defined" in case the user wants the
1851                # value to be 0.
1852                if (defined $attrHash->{value}) {
1853                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
1854                    # hash for the "input" method. If the item is pre-selected, we add
1855                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
1856                    # at all.
1857                    my $radioParms = { type => 'radio',
1858                                       name => $options->{name},
1859                                       value => $attrHash->{value},
1860                                     };
1861                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
1862                        $radioParms->{checked} = undef;
1863                    }
1864                    $prefixHtml .= $cgi->input($radioParms);
1865                }
1866                # Next, we format the label.
1867                my $labelHtml = $myLabel;
1868                Trace("Formatting tree node for \"$myLabel\".") if T(4);
1869                # Apply a hyperlink if necessary.
1870                if (defined $attrHash->{link}) {
1871                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
1872                                         $labelHtml);
1873                }
1874                # Finally, roll up the child HTML. If there are no children, we'll get a null string
1875                # here.
1876                my $childHtml = join("\n", @childHtml);
1877                # Now we have all the pieces, so we can put them together.
1878                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
1879            }
1880        }
1881        # Close the tree branch.
1882        push @retVal, $cgi->end_ul();
1883      # Return the result.      # Return the result.
1884      return $retVal;      return @retVal;
1885  }  }
1886    
1887    =head3 GetDivID
1888    
1889  =head3 FeatureColumnValue      my $idString = SearchHelper::GetDivID($name);
1890    
1891  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  Return a new HTML ID string.
   
 Return the value to be displayed in the specified feature column.  
1892    
1893  =over 4  =over 4
1894    
1895  =item colName  =item name
1896    
1897    Name to be prefixed to the ID string.
1898    
1899    =item RETURN
1900    
1901    Returns a hopefully-unique ID string.
1902    
1903  Name of the column to be displayed.  =back
1904    
1905  =item record  =cut
1906    
1907  DBObject record for the feature being displayed in the current row.  sub GetDivID {
1908        # Get the parameters.
1909        my ($name) = @_;
1910        # Compute the ID.
1911        my $retVal = "elt_$name$divCount";
1912        # Increment the counter to make sure this ID is not re-used.
1913        $divCount++;
1914        # Return the result.
1915        return $retVal;
1916    }
1917    
1918  =item extraCols  =head3 PrintLine
1919    
1920  Reference to a hash of extra column names to values. If the incoming column name      $shelp->PrintLine($message);
 begins with C<X=>, its value will be taken from this hash.  
1921    
1922  =item RETURN  Print a line of CGI output. This is used during the operation of the B<Find> method while
1923    searching, so the user sees progress in real-time.
1924    
1925  Returns the HTML to be displayed in the named column for the specified feature.  =over 4
1926    
1927    =item message
1928    
1929    HTML text to display.
1930    
1931  =back  =back
1932    
1933  =cut  =cut
1934    
1935  sub FeatureColumnValue {  sub PrintLine {
1936      # Get the parameters.      # Get the parameters.
1937      my ($self, $colName, $record, $extraCols) = @_;      my ($self, $message) = @_;
1938      # Get the sprout and CGI objects.      # Send them to the output.
1939      my $cgi = $self->Q();      print "$message\n";
     my $sprout = $self->DB();  
     # Get the feature ID.  
     my ($fid) = $record->Value('Feature(id)');  
     # Declare the return variable. Denote that we default to a non-breaking space,  
     # which will translate to an empty table cell (rather than a table cell with no  
     # interior, which is what you get for a null string).  
     my $retVal = "&nbsp;";  
     # Process according to the column name.  
     if ($colName =~ /^X=(.+)$/) {  
         # Here we have an extra column. Only update if the value exists. Note that  
         # a value of C<undef> is treated as a non-existent value, because the  
         # caller may have put "colName => undef" in the "PutFeature" call in order  
         # to insure we know the extra column exists.  
         if (defined $extraCols->{$1}) {  
             $retVal = $extraCols->{$1};  
         }  
     } elsif ($colName eq 'alias') {  
         # In this case, the user wants a list of external aliases for the feature.  
         # These are very expensive, so we compute them when the row is displayed.  
         $retVal = "%%alias=$fid";  
     } elsif ($colName eq 'fid') {  
         # Here we have the raw feature ID. We hyperlink it to the protein page.  
         $retVal = HTML::set_prot_links($fid);  
     } elsif ($colName eq 'function') {  
         # The functional assignment is just a matter of getting some text.  
         ($retVal) = $record->Value('Feature(assignment)');  
     } elsif ($colName eq 'gblink') {  
         # Here we want a link to the GBrowse page using the official GBrowse button.  
         my $gurl = "GetGBrowse.cgi?fid=$fid";  
         $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },  
                           $cgi->img({ src => "../images/button-gbrowse.png",  
                                       border => 0 })  
                          );  
     } elsif ($colName eq 'group') {  
         # Get the NMPDR group name.  
         my (undef, $group) = $self->OrganismData($fid);  
         # Dress it with a URL to the group's main page.  
         my $nurl = $sprout->GroupPageName($group);  
         $retVal = $cgi->a({ href => $nurl, title => "$group summary" },  
                           $group);  
     } elsif ($colName =~ /^keyword:(.+)$/) {  
         # Here we want keyword-related values. This is also expensive, so  
         # we compute them when the row is displayed.  
         $retVal = "%%colName=$fid";  
     } elsif ($colName eq 'orgName') {  
         # Here we want the formatted organism name and feature number.  
         $retVal = $self->FeatureName($fid);  
     } elsif ($colName eq 'protlink') {  
         # Here we want a link to the protein page using the official NMPDR button.  
         my $hurl = HTML::fid_link($cgi, $fid, 0, 1);  
         $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },  
                           $cgi->img({ src => "../images/button-nmpdr.png",  
                                      border => 0 })  
                          );  
     }elsif ($colName eq 'subsystem') {  
         # Another run-time column: subsystem list.  
         $retVal = "%%subsystem=$fid";  
     }  
     # Return the result.  
     return $retVal;  
1940  }  }
1941    
1942  =head3 RunTimeColumns  =head3 GetHelper
1943    
1944  C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>      my $shelp = SearchHelper::GetHelper($parm, $type => $className);
1945    
1946  Return the HTML text for a run-time column. Run-time columns are evaluated when the  Return a helper object with the given class name. If no such class exists, an
1947  list is displayed, rather than when it is generated.  error will be thrown.
1948    
1949  =over 4  =over 4
1950    
1951    =item parm
1952    
1953    Parameter to pass to the constructor. This is a CGI object for a search helper
1954    and a search helper object for the result helper.
1955    
1956  =item type  =item type
1957    
1958  Type of column.  Type of helper: C<RH> for a result helper and C<SH> for a search helper.
1959    
1960  =item text  =item className
1961    
1962  Data relevant to this row of the column.  Class name for the helper object, without the preceding C<SH> or C<RH>. This is
1963    identical to what the script expects for the C<Class> or C<ResultType> parameter.
1964    
1965  =item RETURN  =item RETURN
1966    
1967  Returns the fully-formatted HTML text to go in the specified column.  Returns a helper object for the specified class.
1968    
1969  =back  =back
1970    
1971  =cut  =cut
1972    
1973  sub RunTimeColumns {  sub GetHelper {
1974      # Get the parameters.      # Get the parameters.
1975      my ($self, $type, $text) = @_;      my ($parm, $type, $className) = @_;
1976      # Declare the return variable.      # Declare the return variable.
1977      my $retVal = "";      my $retVal;
1978      # Get the Sprout and CGI objects.      # Try to create the helper.
1979      my $sprout = $self->DB();      eval {
1980      my $cgi = $self->Q();          # Load it into memory. If it's already there nothing will happen here.
1981      # Separate the text into a type and data.          my $realName = "$type$className";
1982      if ($type eq 'alias') {          Trace("Requiring helper $realName.") if T(3);
1983          # Here the caller wants external alias links for a feature. The text          require "$realName.pm";
1984          # is the feature ID.          Trace("Constructing helper object.") if T(3);
1985          my $fid = $text;          # Construct the object.
1986          # The complicated part is we have to hyperlink them. First, get the          $retVal = eval("$realName->new(\$parm)");
1987          # aliases.          # Commit suicide if it didn't work.
1988          Trace("Generating aliases for feature $fid.") if T(4);          if (! defined $retVal) {
1989          my @aliases = $sprout->FeatureAliases($fid);              die "Could not find a $type handler of type $className.";
1990          # Only proceed if we found some.          }
1991          if (@aliases) {      };
1992              # Join the aliases into a comma-delimited list.      # Check for errors.
1993              my $aliasList = join(", ", @aliases);      if ($@) {
1994              # Ask the HTML processor to hyperlink them.          Confess("Error retrieving $type$className: $@");
             $retVal = HTML::set_prot_links($cgi, $aliasList);  
         }  
     } elsif ($type eq 'subsystem') {  
         # Here the caller wants the subsystems in which this feature participates.  
         # The text is the feature ID. We will list the subsystem names with links  
         # to the subsystem's summary page.  
         my $fid = $text;  
         # Get the subsystems.  
         Trace("Generating subsystems for feature $fid.") if T(4);  
         my %subs = $sprout->SubsystemsOf($fid);  
         # Convert them to links.  
         my @links = map { HTML::sub_link($cgi, $_) } sort keys %subs;  
         # String them into a list.  
         $retVal = join(", ", @links);  
     } elsif ($type =~ /^keyword:(.+)$/) {  
         # Here the caller wants the value of the named keyword. The text is the  
         # feature ID.  
         my $keywordName = $1;  
         my $fid = $text;  
         # Get the attribute values.  
         Trace("Getting $keywordName values for feature $fid.") if T(4);  
         my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],  
                                       "Feature($keywordName)");  
         # String them into a list.  
         $retVal = join(", ", @values);  
1995      }      }
1996      # Return the result.      # Return the result.
1997      return $retVal;      return $retVal;
# Line 1936  Line 1999 
1999    
2000  =head3 SaveOrganismData  =head3 SaveOrganismData
2001    
2002  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>      my ($name, $displayGroup, $domain) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy);
2003    
2004  Format the name of an organism and the display version of its group name. The incoming  Format the name of an organism and the display version of its group name. The incoming
2005  data should be the relevant fields from the B<Genome> record in the database. The  data should be the relevant fields from the B<Genome> record in the database. The
# Line 1966  Line 2029 
2029    
2030  Strain of the species represented by the genome.  Strain of the species represented by the genome.
2031    
2032    =item taxonomy
2033    
2034    Taxonomy of the species represented by the genome.
2035    
2036  =item RETURN  =item RETURN
2037    
2038  Returns a two-element list. The first element is the formatted genome name. The second  Returns a three-element list. The first element is the formatted genome name. The second
2039  element is the display name of the genome's group.  element is the display name of the genome's group. The third is the genome's domain.
2040    
2041  =back  =back
2042    
# Line 1977  Line 2044 
2044    
2045  sub SaveOrganismData {  sub SaveOrganismData {
2046      # Get the parameters.      # Get the parameters.
2047      my ($self, $group, $genomeID, $genus, $species, $strain) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2048      # Declare the return values.      # Declare the return values.
2049      my ($name, $displayGroup);      my ($name, $displayGroup);
2050      # If the organism does not exist, format an unknown name and a blank group.      # If the organism does not exist, format an unknown name and a blank group.
# Line 1993  Line 2060 
2060          # Compute the display group. This is currently the same as the incoming group          # Compute the display group. This is currently the same as the incoming group
2061          # name unless it's the supporting group, which is nulled out.          # name unless it's the supporting group, which is nulled out.
2062          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2063            Trace("Group = $displayGroup, translated from \"$group\".") if T(4);
2064      }      }
2065        # Compute the domain from the taxonomy.
2066        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2067      # Cache the group and organism data.      # Cache the group and organism data.
2068      my $cache = $self->{orgs};      my $cache = $self->{orgs};
2069      $cache->{$genomeID} = [$name, $displayGroup];      $cache->{$genomeID} = [$name, $displayGroup, $domain];
2070        # Return the result.
2071        return ($name, $displayGroup, $domain);
2072    }
2073    
2074    =head3 ValidateKeywords
2075    
2076        my $okFlag = $shelp->ValidateKeywords($keywordString, $required);
2077    
2078    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2079    set.
2080    
2081    =over 4
2082    
2083    =item keywordString
2084    
2085    Keyword string specified as a parameter to the current search.
2086    
2087    =item required
2088    
2089    TRUE if there must be at least one keyword specified, else FALSE.
2090    
2091    =item RETURN
2092    
2093    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2094    is acceptable if the I<$required> parameter is not specified.
2095    
2096    =back
2097    
2098    =cut
2099    
2100    sub ValidateKeywords {
2101        # Get the parameters.
2102        my ($self, $keywordString, $required) = @_;
2103        # Declare the return variable.
2104        my $retVal = 0;
2105        my @wordList = split /\s+/, $keywordString;
2106        # Right now our only real worry is a list of all minus words. The problem with it is that
2107        # it will return an incorrect result.
2108        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2109        if (! @wordList) {
2110            if ($required) {
2111                $self->SetMessage("No search words specified.");
2112            } else {
2113                $retVal = 1;
2114            }
2115        } elsif (! @plusWords) {
2116            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2117        } else {
2118            $retVal = 1;
2119        }
2120      # Return the result.      # Return the result.
2121      return ($name, $displayGroup);      return $retVal;
2122    }
2123    
2124    =head3 TuningParameters
2125    
2126        my $options = $shelp->TuningParameters(%parmHash);
2127    
2128    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2129    to their default values. The parameters and their values will be returned as a hash reference.
2130    
2131    =over 4
2132    
2133    =item parmHash
2134    
2135    Hash mapping parameter names to their default values.
2136    
2137    =item RETURN
2138    
2139    Returns a reference to a hash containing the parameter names mapped to their actual values.
2140    
2141    =back
2142    
2143    =cut
2144    
2145    sub TuningParameters {
2146        # Get the parameters.
2147        my ($self, %parmHash) = @_;
2148        # Declare the return variable.
2149        my $retVal = {};
2150        # Get the CGI Query Object.
2151        my $cgi = $self->Q();
2152        # Loop through the parameter names.
2153        for my $parm (keys %parmHash) {
2154            # Get the incoming value for this parameter.
2155            my $value = $cgi->param($parm);
2156            # Zero might be a valid value, so we do an is-defined check rather than an OR.
2157            if (defined($value)) {
2158                $retVal->{$parm} = $value;
2159            } else {
2160                $retVal->{$parm} = $parmHash{$parm};
2161            }
2162        }
2163        # Return the result.
2164        return $retVal;
2165    }
2166    
2167    =head3 GetPreferredAliasType
2168    
2169        my $type = $shelp->GetPreferredAliasType();
2170    
2171    Return the preferred alias type for the current session. This information is stored
2172    in the C<AliasType> parameter of the CGI query object, and the default is C<FIG>
2173    (which indicates the FIG ID).
2174    
2175    =cut
2176    
2177    sub GetPreferredAliasType {
2178        # Get the parameters.
2179        my ($self) = @_;
2180        # Determine the preferred type.
2181        my $cgi = $self->Q();
2182        my $retVal = $cgi->param('AliasType') || 'FIG';
2183        # Return it.
2184        return $retVal;
2185  }  }
2186    
2187  =head2 Virtual Methods  =head2 Virtual Methods
2188    
2189  =head3 Form  =head3 Form
2190    
2191  C<< my $html = $shelp->Form(); >>      my $html = $shelp->Form();
2192    
2193  Generate the HTML for a form to request a new search.  Generate the HTML for a form to request a new search.
2194    
2195  =head3 Find  =head3 Find
2196    
2197  C<< my $resultCount = $shelp->Find(); >>      my $resultCount = $shelp->Find();
2198    
2199  Conduct a search based on the current CGI query parameters. The search results will  Conduct a search based on the current CGI query parameters. The search results will
2200  be written to the session cache file and the number of results will be  be written to the session cache file and the number of results will be
2201  returned. If the search parameters are invalid, a result count of C<undef> will be  returned. If the search parameters are invalid, a result count of C<undef> will be
2202  returned and a result message will be stored in this object describing the problem.  returned and a result message will be stored in this object describing the problem.
2203    
2204    =cut
2205    
2206    sub Find {
2207        # Get the parameters.
2208        my ($self) = @_;
2209        $self->Message("Call to pure virtual Find method in helper of type " . ref($self) . ".");
2210        return undef;
2211    }
2212    
2213  =head3 Description  =head3 Description
2214    
2215  C<< my $htmlText = $shelp->Description(); >>      my $htmlText = $shelp->Description();
2216    
2217  Return a description of this search. The description is used for the table of contents  Return a description of this search. The description is used for the table of contents
2218  on the main search tools page. It may contain HTML, but it should be character-level,  on the main search tools page. It may contain HTML, but it should be character-level,
2219  not block-level, since the description is going to appear in a list.  not block-level, since the description is going to appear in a list.
2220    
2221  =head3 SortKey  =cut
2222    
2223  C<< my $key = $shelp->SortKey($fdata); >>  sub Description {
2224        # Get the parameters.
2225        my ($self) = @_;
2226        $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2227        return "Unknown search type";
2228    }
2229    
2230    =head3 SearchTitle
2231    
2232  Return the sort key for the specified feature data. The default is to sort by feature name,      my $titleHtml = $shelp->SearchTitle();
2233  floating NMPDR organisms to the top. If a full-text search is used, then the default  
2234  sort is by relevance followed by feature name. This sort may be overridden by the  Return the display title for this search. The display title appears above the search results.
2235  search class to provide fancier functionality. This method is called by  If no result is returned, no title will be displayed. The result should be an html string
2236  B<PutFeature>, so it is only used for feature searches. A non-feature search  that can be legally put inside a block tag such as C<h3> or C<p>.
2237  would presumably have its own sort logic.  
2238    =cut
2239    
2240    sub SearchTitle {
2241        # Get the parameters.
2242        my ($self) = @_;
2243        # Declare the return variable.
2244        my $retVal = "";
2245        # Return it.
2246        return $retVal;
2247    }
2248    
2249    =head3 DefaultColumns
2250    
2251        $shelp->DefaultColumns($rhelp);
2252    
2253    Store the default columns in the result helper. The default action is just to ask
2254    the result helper for its default columns, but this may be changed by overriding
2255    this method.
2256    
2257  =over 4  =over 4
2258    
2259  =item record  =item rhelp
2260    
2261  The C<FeatureData> containing the current feature.  Result helper object in which the column list should be stored.
2262    
2263    =back
2264    
2265    =cut
2266    
2267    sub DefaultColumns {
2268        # Get the parameters.
2269        my ($self, $rhelp) = @_;
2270        # Get the default columns from the result helper.
2271        my @cols = $rhelp->DefaultResultColumns();
2272        # Store them back.
2273        $rhelp->SetColumns(@cols);
2274    }
2275    
2276    =head3 Hint
2277    
2278        my $htmlText = SearchHelper::Hint($wikiPage, $hintText);
2279    
2280    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
2281    This HTML can be put in forms to provide a useful hinting mechanism.
2282    
2283    =over 4
2284    
2285    =item wikiPage
2286    
2287    Name of the wiki page to be popped up when the hint mark is clicked.
2288    
2289    =item hintText
2290    
2291    Text to display for the hint. It is raw html, but may not contain any double quotes.
2292    
2293  =item RETURN  =item RETURN
2294    
2295  Returns a key field that can be used to sort this row in among the results.  Returns the html for the hint facility. The resulting html shows a small button-like thing that
2296    uses the standard FIG popup technology.
2297    
2298  =back  =back
2299    
2300  =cut  =cut
2301    
2302  sub SortKey {  sub Hint {
2303      # Get the parameters.      # Get the parameters.
2304      my ($self, $fdata) = @_;      my ($wikiPage, $hintText) = @_;
2305      # Get the feature ID from the record.      # Ask Sprout to draw the hint button for us.
2306      my $fid = $fdata->FID();      return Sprout::Hint($wikiPage, $hintText);
     # Get the group from the feature ID.  
     my $group = $self->FeatureGroup($fid);  
     # Ask the feature query object to form the sort key.  
     my $retVal = $fdata->SortKey($self, $group);  
     # Return the result.  
     return $retVal;  
2307  }  }
2308    
2309    
2310  1;  1;

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.42

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3