[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.8, Wed Oct 4 16:03:35 2006 UTC revision 1.44, Thu Feb 5 07:17:03 2009 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 CGI::Cookie;
23        use FreezeThaw qw(freeze thaw);
24    
25  =head1 Search Helper Base Class  =head1 Search Helper Base Class
26    
# Line 65  Line 67 
67    
68  =item orgs  =item orgs
69    
70  Reference to a hash mapping genome IDs to organism names.  Reference to a hash mapping genome IDs to organism data. (Used to
71    improve performance.)
72    
73  =item name  =item name
74    
# Line 83  Line 86 
86    
87  List of the parameters that are used to select multiple genomes.  List of the parameters that are used to select multiple genomes.
88    
89  =item filtered  =item notices
90    
91  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  A list of messages to be put in the notice file.
 field is updated by the B<FeatureQuery> object.  
92    
93  =back  =back
94    
# Line 103  Line 105 
105  =item 2  =item 2
106    
107  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
108  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
109    type of search.
110    
111  =item 3  =item 3
112    
# Line 113  Line 116 
116    
117  =item 4  =item 4
118    
119  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
120  and then put the class name in the C<@advancedClasses> list.  must create a new subclass of B<ResultHelper>. Its name must be
121    C<RH>I<className>, where I<className> is the type of result.
122    
123  =back  =back
124    
# Line 150  Line 154 
154    
155  Several helper methods are provided for particular purposes.  Several helper methods are provided for particular purposes.
156    
 =over 4  
   
 =item 1  
   
157  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
158  L</GetGenomes> to retrieve all the genomes passed in for a specified parameter  L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
159  name. Note that as an assist to people working with GET-style links, if no  name. Note that as an assist to people working with GET-style links, if no
160  genomes are specified and the incoming request style is GET, all genomes will  genomes are specified and the incoming request style is GET, all genomes will
161  be returned.  be returned.
162    
 =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  
   
163  L</QueueFormScript> allows you to queue JavaScript statements for execution  L</QueueFormScript> allows you to queue JavaScript statements for execution
164  after the form is fully generated. If you are using very complicated  after the form is fully generated. If you are using very complicated
165  form controls, the L</QueueFormScript> method allows you to perform  form controls, the L</QueueFormScript> method allows you to perform
166  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
167  facility to display a list of the pre-selected genomes.  facility to display a list of the pre-selected genomes.
168    
 =back  
   
169  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
170  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
171    
172  =head3 Finding Search Results  =head3 Finding Search Results
173    
174  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
175  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.  
176    
177      sub Find {      sub Find {
178          my ($self) = @_;          my ($self) = @_;
# Line 198  Line 185 
185          ... validate the parameters ...          ... validate the parameters ...
186          if (... invalid parameters...) {          if (... invalid parameters...) {
187              $self->SetMessage(...appropriate message...);              $self->SetMessage(...appropriate message...);
188          } elsif (FeatureQuery::Valid($self)) {          } else {
189                # Determine the result type.
190                my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
191                # Specify the columns.
192                $self->DefaultColumns($rhelp);
193                # You may want to add extra columns. $name is the column name and
194                # $loc is its location. The other parameters take their names from the
195                # corresponding column methods.
196                $rhelp->AddExtraColumn($name => $loc, style => $style, download => $flag,
197                    title => $title);
198                # Some searches require optional columns that are configured by the
199                # user or by the search query itself. There are some special methods
200                # for this in the result helpers, but there's also the direct approach
201                # shown below.
202                $rhelp->AddOptionalColumn($name => $loc);
203              # Initialize the session file.              # Initialize the session file.
204              $self->OpenSession();              $self->OpenSession($rhelp);
205              # Initialize the result counter.              # Initialize the result counter.
206              $retVal = 0;              $retVal = 0;
207              ... get a list of genomes ...              ... set up to loop through the results ...
208              for my $genomeID (... each genome ...) {              while (...more results...) {
209                  my $fq = FeatureQuery->new($self, $genomeID);                  ...compute extra columns and call PutExtraColumns...
210                  while (my $feature = $fq->Fetch()) {                  $rhelp->PutData($sortKey, $objectID, $record);
                     ... examine the feature ...  
                     if (... we want to keep it ...) {  
                         $self->PutFeature($fq);  
211                          $retVal++;                          $retVal++;
212                      }                      }
                 }  
             }  
         }  
213          # Close the session file.          # Close the session file.
214          $self->CloseSession();          $self->CloseSession();
215            }
216          # Return the result count.          # Return the result count.
217          return $retVal;          return $retVal;
218      }      }
219    
220  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
221  are variations on the above them. For example, you could eschew feature filtering  are variations on the above theme.
222  entirely in favor of your own custom filtering, you could include extra columns  
223  in the output, or you could search for something that's not a feature at all. The  In addition to the finding and filtering, it is necessary to send status messages
224  above code is just a loose framework.  to the output so that the user does not get bored waiting for results. The L</PrintLine>
225    method performs this function. The single parameter should be text to be
226    output to the browser. In general, you'll invoke it as follows.
227    
228  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>      $self->PrintLine("...my message text...<br />");
 method of the feature query object.  
229    
230      $fq->AddExtraColumns(score => $sc);  The break tag is optional. When the Find method gets control, a paragraph will
231    have been started so that everything is XHTML-compliant.
232    
233  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
234  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 239 
239    
240  # 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.
241  my $formCount = 0;  my $formCount = 0;
242    # This counter is used to generate unique DIV IDs.
243    my $divCount = 0;
244    
245  =head2 Public Methods  =head2 Public Methods
246    
247  =head3 new  =head3 new
248    
249  C<< my $shelp = SearchHelper->new($query); >>      my $shelp = SearchHelper->new($cgi);
250    
251  Construct a new SearchHelper object.  Construct a new SearchHelper object.
252    
253  =over 4  =over 4
254    
255  =item query  =item cgi
256    
257  The CGI query object for the current script.  The CGI query object for the current script.
258    
# Line 262  Line 262 
262    
263  sub new {  sub new {
264      # Get the parameters.      # Get the parameters.
265      my ($class, $query) = @_;      my ($class, $cgi) = @_;
266      # Check for a session ID.      # Check for a session ID. First we look in the CGI parameters.
267      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
268      my $type = "old";      my $type = "old";
269      if (! $session_id) {      if (! $session_id) {
270            # We need a session ID. Try to get it from the cookies.
271            my %cookies = fetch CGI::Cookie;
272            my $session_cookie = $cookies{$class};
273            if (! $session_cookie) {
274                Trace("No session ID found.") if T(3);
275          # 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
276          # store it in the query object.              # store it in a cookie.
277          $session_id = NewSessionID();              $session_id = FIGRules::NewSessionID();
278                Trace("New session ID is $session_id.") if T(3);
279                $session_cookie = new CGI::Cookie(-name => $class,
280                                                  -value => $session_id);
281                $session_cookie->bake();
282            } else {
283                # Here we're recovering an old session. The session ID is
284                # used to find any old search options lying around, but we're
285                # still considered a new session.
286                $session_id = $session_cookie->value();
287                Trace("Session $session_id recovered from cookie.") if T(3);
288            }
289            # Denote this is a new session.
290          $type = "new";          $type = "new";
291          $query->param(-name => 'SessionID', -value => $session_id);          # Put the session IS in the parameters.
292            $cgi->param(-name => 'SessionID', -value => $session_id);
293        } else {
294            Trace("Session ID is $session_id.") if T(3);
295      }      }
296        Trace("Computing subclass.") if T(3);
297      # Compute the subclass name.      # Compute the subclass name.
298      $class =~ /SH(.+)$/;      my $subClass;
299      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
300            # Here we have a real search class.
301            $subClass = $1;
302        } else {
303            # Here we have a bare class. The bare class cannot search, but it can
304            # process search results.
305            $subClass = 'SearchHelper';
306        }
307        Trace("Subclass name is $subClass.") if T(3);
308      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
309      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
310      # Generate the form name.      # Generate the form name.
311      my $formName = "$class$formCount";      my $formName = "$class$formCount";
312      $formCount++;      $formCount++;
313        Trace("Creating helper.") if T(3);
314      # 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)
315      # 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
316      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
317      my $retVal = {      my $retVal = {
318                    query => $query,                    query => $cgi,
319                    type => $type,                    type => $type,
320                    class => $subClass,                    class => $subClass,
321                    sprout => undef,                    sprout => undef,
# Line 294  Line 324 
324                    scriptQueue => [],                    scriptQueue => [],
325                    genomeList => undef,                    genomeList => undef,
326                    genomeParms => [],                    genomeParms => [],
327                    filtered => 0,                    notices => [],
328                   };                   };
329      # Bless and return it.      # Bless and return it.
330      bless $retVal, $class;      bless $retVal, $class;
# Line 303  Line 333 
333    
334  =head3 Q  =head3 Q
335    
336  C<< my $query = $shelp->Q(); >>      my $query = $shelp->Q();
337    
338  Return the CGI query object.  Return the CGI query object.
339    
# Line 316  Line 346 
346      return $self->{query};      return $self->{query};
347  }  }
348    
349    
350  =head3 DB  =head3 DB
351    
352  C<< my $sprout = $shelp->DB(); >>      my $sprout = $shelp->DB();
353    
354  Return the Sprout database object.  Return the Sprout database object.
355    
# Line 339  Line 370 
370    
371  =head3 IsNew  =head3 IsNew
372    
373  C<< my $flag = $shelp->IsNew(); >>      my $flag = $shelp->IsNew();
374    
375  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
376  session already has search results ready to process.  session already has search results ready to process.
# Line 355  Line 386 
386    
387  =head3 ID  =head3 ID
388    
389  C<< my $sessionID = $shelp->ID(); >>      my $sessionID = $shelp->ID();
390    
391  Return the current session ID.  Return the current session ID.
392    
# Line 370  Line 401 
401    
402  =head3 FormName  =head3 FormName
403    
404  C<< my $name = $shelp->FormName(); >>      my $name = $shelp->FormName();
405    
406  Return the name of the form this helper object will generate.  Return the name of the form this helper object will generate.
407    
# Line 385  Line 416 
416    
417  =head3 QueueFormScript  =head3 QueueFormScript
418    
419  C<< $shelp->QueueFormScript($statement); >>      $shelp->QueueFormScript($statement);
420    
421  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
422  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 420  Line 451 
451    
452  =head3 FormStart  =head3 FormStart
453    
454  C<< my $html = $shelp->FormStart($title); >>      my $html = $shelp->FormStart($title);
455    
456  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
457  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 447  Line 478 
478      my ($self, $title) = @_;      my ($self, $title) = @_;
479      # Get the CGI object.      # Get the CGI object.
480      my $cgi = $self->Q();      my $cgi = $self->Q();
481      # Start the form.      # Start the form. Note we use the override option on the Class value, in
482        # case the Advanced button was used.
483      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
484                   $cgi->start_form(-method => 'POST',                   CGI::start_form(-method => 'POST',
485                                    -action => $cgi->url(-relative => 1),                                    -action => "$FIG_Config::cgi_url/wiki/rest.cgi/NmpdrPlugin/search",
486                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
487                   $cgi->hidden(-name => 'Class',                   CGI::hidden(-name => 'Class',
488                                -value => $self->{class}) .                                -value => $self->{class}) .
489                   $cgi->hidden(-name => 'SPROUT',                   CGI::hidden(-name => 'SPROUT',
490                                -value => 1) .                                -value => 1) .
491                   $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));  
     }  
492      # 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.
493      my $anchorName = $self->FormName();      my $anchorName = $self->FormName();
494      $retVal .= "<a name=\"$anchorName\"></a>\n";      $retVal .= "<a name=\"$anchorName\"></a>\n";
# Line 473  Line 498 
498    
499  =head3 FormEnd  =head3 FormEnd
500    
501  C<< my $htmlText = $shelp->FormEnd(); >>      my $htmlText = $shelp->FormEnd();
502    
503  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
504  C<div> tags.  C<div> tags.
# Line 505  Line 530 
530    
531  =head3 SetMessage  =head3 SetMessage
532    
533  C<< $shelp->SetMessage($msg); >>      $shelp->SetMessage($msg);
534    
535  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
536  if an invalid parameter value is specified.  if an invalid parameter value is specified.
# Line 529  Line 554 
554    
555  =head3 Message  =head3 Message
556    
557  C<< my $text = $shelp->Message(); >>      my $text = $shelp->Message();
558    
559  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
560  value is specified.  value is specified.
# Line 545  Line 570 
570    
571  =head3 OpenSession  =head3 OpenSession
572    
573  C<< $shelp->OpenSession(); >>      $shelp->OpenSession($rhelp);
574    
575    Set up the session cache file and write out the column headers.
576    This method should not be called until all the columns have
577    been configured, including the extra columns.
578    
579    =over 4
580    
581    =item rhelp
582    
583    Result helper for formatting the output. This has the column
584    headers stored in it.
585    
586  Set up to open the session cache file for writing. Note we don't actually  =back
 open the file until after we know the column headers.  
587    
588  =cut  =cut
589    
590  sub OpenSession {  sub OpenSession {
591      # Get the parameters.      # Get the parameters.
592      my ($self) = @_;      my ($self, $rhelp) = @_;
593      # Denote we have not yet written out the column headers.      # Insure the result helper is valid.
594      $self->{cols} = undef;      if (! defined($rhelp)) {
595            Confess("No result type specified for $self->{class}.");
596        } elsif(! $rhelp->isa('ResultHelper')) {
597            Confess("Invalid result type specified for $self->{class}.");
598        } else {
599            # Get the column headers and write them out.
600            my $colHdrs = $rhelp->GetColumnHeaders();
601            Trace(scalar(@{$colHdrs}) . " column headers written to output.") if T(3);
602            $self->WriteColumnHeaders(@{$colHdrs});
603        }
604  }  }
605    
606  =head3 GetCacheFileName  =head3 GetCacheFileName
607    
608  C<< my $fileName = $shelp->GetCacheFileName(); >>      my $fileName = $shelp->GetCacheFileName();
609    
610  Return the name to be used for this session's cache file.  Return the name to be used for this session's cache file.
611    
# Line 576  Line 620 
620    
621  =head3 GetTempFileName  =head3 GetTempFileName
622    
623  C<< my $fileName = $shelp->GetTempFileName($type); >>      my $fileName = $shelp->GetTempFileName($type);
624    
625  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
626  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 600  Line 644 
644      my ($self, $type) = @_;      my ($self, $type) = @_;
645      # Compute the file name. Note it gets stuffed in the FIG temporary      # Compute the file name. Note it gets stuffed in the FIG temporary
646      # directory.      # directory.
647      my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";      my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
648      # Return the result.      # Return the result.
649      return $retVal;      return $retVal;
650  }  }
651    
652  =head3 PutFeature  =head3 WriteColumnHeaders
653    
654        $shelp->WriteColumnHeaders(@colNames);
655    
656    Write out the column headers for the current search session. The column headers
657    are sent to the cache file, and then the cache is re-opened as a sort pipe and
658    the handle saved.
659    
660  C<< $shelp->PutFeature($fquery); >>  =over 4
661    
662  Store a feature in the result cache. This is the workhorse method for most  =item colNames
 searches, since the primary data item in the database is features.  
663    
664  For each feature, there are certain columns that are standard: the feature name, the  A list of column names in the desired presentation order. For extra columns,
665  GBrowse and protein page links, the functional assignment, and so forth. If additional  the column name is the hash supplied as the column definition.
 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.  
666    
667      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  =back
     $shelp->PutFeature($fq);  
668    
669  For correct results, all values should be specified for all extra columns in all calls to  =cut
 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>.  
670    
671      if (! $essentialFlag) {  sub WriteColumnHeaders {
672          $essentialFlag = undef;      # Get the parameters.
673        my ($self, @colNames) = @_;
674        # Get the cache file name and open it for output.
675        my $fileName = $self->GetCacheFileName();
676        my $handle1 = Open(undef, ">$fileName");
677        # Freeze the column headers.
678        my @colHdrs = map { freeze($_) } @colNames;
679        # Write the column headers and close the file.
680        Tracer::PutLine($handle1, \@colHdrs);
681        close $handle1;
682        # Now open the sort pipe and save the file handle. Note how we append the
683        # sorted data to the column header row already in place. The output will
684        # contain a sort key followed by the real columns. The sort key is
685        # hacked off before going to the output file.
686        $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
687      }      }
688      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  
689      $shelp->PutFeature($fq);  =head3 SetNotice
690    
691        $shelp->SetNotice($message);
692    
693    This method creates a notice that will be displayed on the search results
694    page. After the search is complete, notices are placed in a small temporary
695    file that is checked by the results display engine.
696    
697  =over 4  =over 4
698    
699  =item fquery  =item message
700    
701  FeatureQuery object containing the current feature data.  Message to write to the notice file.
702    
703  =back  =back
704    
705  =cut  =cut
706    
707  sub PutFeature {  sub SetNotice {
708      # Get the parameters.      # Get the parameters.
709      my ($self, $fq) = @_;      my ($self, $message) = @_;
710      # Get the CGI query object.      # Save the message.
711      my $cgi = $self->Q();      push @{$self->{notices}}, $message;
     # Get the feature data.  
     my $record = $fq->Feature();  
     my $extraCols = $fq->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 the externals if they were requested.  
         if ($cgi->param('ShowAliases')) {  
             push @{$self->{cols}}, 'alias';  
         }  
         # 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) = $record->Value('Feature(id)');  
     # 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 floats NMPDR organism features to the  
     # top of the return list.  
     my $key = $self->SortKey($record);  
     # Write the feature data.  
     $self->WriteColumnData($key, @output);  
712  }  }
713    
 =head3 WriteColumnHeaders  
714    
715  C<< $shelp->WriteColumnHeaders(@colNames); >>  =head3 ReadColumnHeaders
716    
717  Write out the column headers for the current search session. The column headers      my @colHdrs = $shelp->ReadColumnHeaders($fh);
718  are sent to the cache file, and then the cache is re-opened as a sort pipe and  
719  the handle saved.  Read the column headers from the specified file handle. The column headers are
720    frozen strings intermixed with frozen hash references. The strings represent
721    column names defined in the result helper. The hash references represent the
722    definitions of the extra columns.
723    
724  =over 4  =over 4
725    
726  =item colNames  =item fh
727    
728    File handle from which the column headers are to be read.
729    
730  A list of column names in the desired presentation order.  =item RETURN
731    
732    Returns a list of the column headers pulled from the specified file's first line.
733    
734  =back  =back
735    
736  =cut  =cut
737    
738  sub WriteColumnHeaders {  sub ReadColumnHeaders {
739      # Get the parameters.      # Get the parameters.
740      my ($self, @colNames) = @_;      my ($self, $fh) = @_;
741      # Get the cache file name and open it for output.      # Read and thaw the columns.
742      my $fileName = $self->GetCacheFileName();      my @retVal = map { thaw($_) } Tracer::GetLine($fh);
743      my $handle1 = Open(undef, ">$fileName");      # Return them to the caller.
744      # Write the column headers and close the file.      return @retVal;
     Tracer::PutLine($handle1, \@colNames);  
     close $handle1;  
     # Now open the sort pipe and save the file handle. Note how we append the  
     # sorted data to the column header row already in place. The output will  
     # contain a sort key followed by the real columns. The sort key is  
     # hacked off before going to the output file.  
     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");  
745  }  }
746    
747  =head3 WriteColumnData  =head3 WriteColumnData
748    
749  C<< $shelp->WriteColumnData($key, @colValues); >>      $shelp->WriteColumnData($key, @colValues);
750    
751  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
752  the session file is already open for output.  the session file is already open for output.
# Line 740  Line 770 
770      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
771      # Write them to the cache file.      # Write them to the cache file.
772      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
773        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
774  }  }
775    
776  =head3 CloseSession  =head3 CloseSession
777    
778  C<< $shelp->CloseSession(); >>      $shelp->CloseSession();
779    
780  Close the session file.  Close the session file.
781    
# Line 756  Line 787 
787      # Check for an open session file.      # Check for an open session file.
788      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
789          # We found one, so close it.          # We found one, so close it.
790            Trace("Closing session file.") if T(2);
791          close $self->{fileHandle};          close $self->{fileHandle};
792            # Tell the user.
793            my $cgi = $self->Q();
794            $self->PrintLine("Output formatting complete.<br />");
795      }      }
796        # Check for notices.
797        my @notices = @{$self->{notices}};
798        if (scalar @notices) {
799            # We have some, so put then in a notice file.
800            my $noticeFile = $self->GetTempFileName('notices');
801            my $nh = Open(undef, ">$noticeFile");
802            print $nh join("\n", @notices, "");
803            close $nh;
804            $self->PrintLine(scalar(@notices) . " notices saved.<br />");
805  }  }
   
 =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;  
806  }  }
807    
808  =head3 OrganismData  =head3 OrganismData
809    
810  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>      my ($orgName, $group) = $shelp->Organism($genomeID);
811    
812  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.
813  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 799  Line 821 
821    
822  =item RETURN  =item RETURN
823    
824  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,
825  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
826  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
827    
828  =back  =back
829    
# Line 811  Line 833 
833      # Get the parameters.      # Get the parameters.
834      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
835      # Declare the return variables.      # Declare the return variables.
836      my ($orgName, $group);      my ($orgName, $group, $domain);
837      # Check the cache.      # Check the cache.
838      my $cache = $self->{orgs};      my $cache = $self->{orgs};
839      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
840          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
841            Trace("Cached organism $genomeID has group \"$group\".") if T(4);
842      } else {      } else {
843          # Here we have to use the database.          # Here we have to use the database.
844          my $sprout = $self->DB();          my $sprout = $self->DB();
845          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $newGroup, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
846                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
847                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
848                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
849          # Null out the supporting group.                                                                   'Genome(taxonomy)']);
850          $group = "" if ($group eq $FIG_Config::otherGroup);          # Format and cache the name and display group.
851          # If the organism does not exist, format an unknown name.          Trace("Caching organism $genomeID with group \"$newGroup\".") if T(4);
852          if (! defined($genus)) {          ($orgName, $group, $domain) = $self->SaveOrganismData($newGroup, $genomeID, $genus, $species,
853              $orgName = "Unknown Genome $genomeID";                                                                $strain, $taxonomy);
854          } else {          Trace("Returning group $group.") if T(4);
             # It does exist, so format the organism name.  
             $orgName = "$genus $species";  
             if ($strain) {  
                 $orgName .= " $strain";  
             }  
         }  
         # Save this organism in the cache.  
         $cache->{$genomeID} = [$orgName, $group];  
855      }      }
856      # Return the result.      # Return the result.
857      return ($orgName, $group);      return ($orgName, $group, $domain);
858  }  }
859    
860  =head3 Organism  =head3 Organism
861    
862  C<< my $orgName = $shelp->Organism($genomeID); >>      my $orgName = $shelp->Organism($genomeID);
863    
864  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,
865  species, and unique characterization. A cache is used to improve performance.  species, and unique characterization. A cache is used to improve performance.
# Line 867  Line 882 
882      # Get the parameters.      # Get the parameters.
883      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
884      # Get the organism data.      # Get the organism data.
885      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]";  
     }  
886      # Return the result.      # Return the result.
887      return $retVal;      return $retVal;
888  }  }
889    
890  =head3 ComputeFASTA  =head3 ComputeFASTA
891    
892  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>      my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth, $comments);
893    
894  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
895  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
896    
897  =over 4  =over 4
898    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
899  =item desiredType  =item desiredType
900    
901  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>
902  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.
903    
904  =item sequence  =item sequence
905    
# Line 972  Line 909 
909  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
910  line will be provided.  line will be provided.
911    
912    =item flankingWidth
913    
914    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
915    feature that should be included. Currently we can't do this for Proteins because the
916    protein translation of a feature doesn't always match the DNA and is taken directly
917    from the database.
918    
919    =item comments
920    
921    Comment string to be added to the FASTA header.
922    
923  =item RETURN  =item RETURN
924    
925  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 984  Line 932 
932    
933  sub ComputeFASTA {  sub ComputeFASTA {
934      # Get the parameters.      # Get the parameters.
935      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth, $comment) = @_;
936      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
937      my $retVal;      my $retVal;
938        # This variable will be cleared if an error is detected.
939        my $okFlag = 1;
940      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
941      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
942      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
943        # Check for a feature specification. The smoking gun for that is a vertical bar.
944      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
945          # 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
946          # it.          # it.
947          my $fid = $1;          my $fid = $1;
948            Trace("Feature ID for fasta is $fid.") if T(3);
949          my $sprout = $self->DB();          my $sprout = $self->DB();
950          # Get the FIG ID. Note that we only use the first feature found. We are not          # Get the FIG ID. Note that we only use the first feature found. We are not
951          # supposed to have redundant aliases, though we may have an ID that doesn't          # supposed to have redundant aliases, though we may have an ID that doesn't
952          # exist.          # exist.
953          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
954          if (! $figID) {          if (! $figID) {
955              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
956                $okFlag = 0;
957          } else {          } else {
958              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
959              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
960                my $favorLen = length $favored;
961                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
962                if (! $fastaLabel) {
963                    # In an emergency, fall back to the original ID.
964                    $fastaLabel = $fid;
965                }
966                # Add any specified comments.
967                if ($comment) {
968                    $fastaLabel .= " $comment";
969                }
970              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
971              if ($desiredType =~ /prot/i) {              if ($desiredType =~ /prot/) {
972                  # We want protein, so get the translation.                  # We want protein, so get the translation.
973                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
974              } else {                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
975                  # We want DNA, so get the DNA sequence. This is a two-step process.              } elsif ($desiredType =~ /dna/) {
976                    # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
977                    # locations.
978                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
979                    if ($flankingWidth > 0) {
980                        # Here we need to add flanking data. Convert the locations to a list
981                        # of location objects.
982                        my @locObjects = map { BasicLocation->new($_) } @locList;
983                        # Initialize the return variable. We will put the DNA in here segment by segment.
984                        $fastaData = "";
985                        # Now we widen each location by the flanking width and stash the results. This
986                        # requires getting the contig length for each contig so we don't fall off the end.
987                        for my $locObject (@locObjects) {
988                            Trace("Current location is " . $locObject->String . ".") if T(4);
989                            # Remember the current start and length.
990                            my ($start, $len) = ($locObject->Left, $locObject->Length);
991                            # Get the contig length.
992                            my $contigLen = $sprout->ContigLength($locObject->Contig);
993                            # Widen the location and get its DNA.
994                            $locObject->Widen($flankingWidth, $contigLen);
995                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
996                            # Now we need to do some case changing. The main DNA is upper case and
997                            # the flanking DNA is lower case.
998                            my $leftFlank = $start - $locObject->Left;
999                            my $rightFlank = $leftFlank + $len;
1000                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1001                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1002                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1003                                                    lc(substr($fastaSegment, $rightFlank));
1004                            $fastaData .= $fancyFastaSegment;
1005                        }
1006                    } else {
1007                        # Here we have just the raw sequence.
1008                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1009              }              }
1010                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1011                }
1012          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1013      } else {      } else {
1014            Trace("Analyzing FASTA sequence.") if T(4);
1015          # 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.
1016          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1017                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1018              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1019              $fastaLabel = $1;              $fastaLabel = $1;
1020              $fastaData = $2;              $fastaData = $2;
1021          } else {          } else {
1022                Trace("No label found in match to sequence:\n$sequence") if T(4);
1023              # 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
1024              # as data.              # as data.
1025              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "$desiredType sequence specified by user";
1026              $fastaData = $sequence;              $fastaData = $sequence;
1027          }          }
1028          # 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.
1029            if ($desiredType !~ /pattern/i) {
1030          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1031          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1032          # Finally, if the user wants to convert to protein, we do it here. Note that          }
1033          # we've already prevented a conversion from protein to DNA.          # Finally, verify that it's DNA if we're doing DNA stuff.
1034          if ($incomingType ne $desiredType) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
1035              $fastaData = Sprout::Protein($fastaData);              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1036                $okFlag = 0;
1037          }          }
1038      }      }
1039      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1040      # in progress.      # Only proceed if no error was detected.
1041      if (defined $fastaLabel) {      if ($okFlag) {
1042            if ($desiredType =~ /pattern/i) {
1043                # For a scan, there is no label and no breakup.
1044                $retVal = $fastaData;
1045            } else {
1046          # 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
1047          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1048          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1049          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1050          # the delimiters are what we want.          # the delimiters are what we want.
1051          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1052          my $retVal = join("\n", ">$fastaLabel", @chunks, "");              $retVal = join("\n", ">$fastaLabel", @chunks, "");
1053            }
1054      }      }
1055      # Return the result.      # Return the result.
1056      return $retVal;      return $retVal;
1057  }  }
1058    
1059    =head3 SubsystemTree
1060    
1061        my $tree = SearchHelper::SubsystemTree($sprout, %options);
1062    
1063    This method creates a subsystem selection tree suitable for passing to
1064    L</SelectionTree>. Each leaf node in the tree will have a link to the
1065    subsystem display page. In addition, each node can have a radio button. The
1066    radio button alue is either C<classification=>I<string>, where I<string> is
1067    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1068    Thus, it can either be used to filter by a group of related subsystems or a
1069    single subsystem.
1070    
1071    =over 4
1072    
1073    =item sprout
1074    
1075    Sprout database object used to get the list of subsystems.
1076    
1077    =item options
1078    
1079    Hash containing options for building the tree.
1080    
1081    =item RETURN
1082    
1083    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1084    
1085    =back
1086    
1087    The supported options are as follows.
1088    
1089    =over 4
1090    
1091    =item radio
1092    
1093    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1094    
1095    =item links
1096    
1097    TRUE if the tree should be configured for links. The default is TRUE.
1098    
1099    =back
1100    
1101    =cut
1102    
1103    sub SubsystemTree {
1104        # Get the parameters.
1105        my ($sprout, %options) = @_;
1106        # Process the options.
1107        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1108        # Read in the subsystems.
1109        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1110                                   ['Subsystem(classification)', 'Subsystem(id)']);
1111        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1112        # is at the end, ALL subsystems are unclassified and we don't bother.
1113        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1114            while ($subs[0]->[0] eq '') {
1115                my $classLess = shift @subs;
1116                push @subs, $classLess;
1117            }
1118        }
1119        # Get the seedviewer URL.
1120        my $svURL = $FIG_Config::linkinSV || "$FIG_Config::cgi_url/seedviewer.cgi";
1121        Trace("Seed Viewer URL is $svURL.") if T(3);
1122        # Declare the return variable.
1123        my @retVal = ();
1124        # Each element in @subs represents a leaf node, so as we loop through it we will be
1125        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1126        # first element is a semi-colon-delimited list of the classifications for the
1127        # subsystem. There will be a stack of currently-active classifications, which we will
1128        # compare to the incoming classifications from the end backward. A new classification
1129        # requires starting a new branch. A different classification requires closing an old
1130        # branch and starting a new one. Each classification in the stack will also contain
1131        # that classification's current branch. We'll add a fake classification at the
1132        # beginning that we can use to represent the tree as a whole.
1133        my $rootName = '<root>';
1134        # Create the classification stack. Note the stack is a pair of parallel lists,
1135        # one containing names and the other containing content.
1136        my @stackNames = ($rootName);
1137        my @stackContents = (\@retVal);
1138        # Add a null entry at the end of the subsystem list to force an unrolling.
1139        push @subs, ['', undef];
1140        # Loop through the subsystems.
1141        for my $sub (@subs) {
1142            # Pull out the classification list and the subsystem ID.
1143            my ($classString, $id) = @{$sub};
1144            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1145            # Convert the classification string to a list with the root classification in
1146            # the front.
1147            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1148            # Find the leftmost point at which the class list differs from the stack.
1149            my $matchPoint = 0;
1150            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1151                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1152                $matchPoint++;
1153            }
1154            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1155                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1156            # Unroll the stack to the matchpoint.
1157            while ($#stackNames >= $matchPoint) {
1158                my $popped = pop @stackNames;
1159                pop @stackContents;
1160                Trace("\"$popped\" popped from stack.") if T(4);
1161            }
1162            # Start branches for any new classifications.
1163            while ($#stackNames < $#classList) {
1164                # The branch for a new classification contains its radio button
1165                # data and then a list of children. So, at this point, if radio buttons
1166                # are desired, we put them into the content.
1167                my $newLevel = scalar(@stackNames);
1168                my @newClassContent = ();
1169                if ($optionThing->{radio}) {
1170                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1171                    push @newClassContent, { value => "classification=$newClassString%" };
1172                }
1173                # The new classification node is appended to its parent's content
1174                # and then pushed onto the stack. First, we need the node name.
1175                my $nodeName = $classList[$newLevel];
1176                # Add the classification to its parent. This makes it part of the
1177                # tree we'll be returning to the user.
1178                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1179                # Push the classification onto the stack.
1180                push @stackContents, \@newClassContent;
1181                push @stackNames, $nodeName;
1182                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1183            }
1184            # Now the stack contains all our parent branches. We add the subsystem to
1185            # the branch at the top of the stack, but only if it's NOT the dummy node.
1186            if (defined $id) {
1187                # Compute the node name from the ID.
1188                my $nodeName = $id;
1189                $nodeName =~ s/_/ /g;
1190                # Create the node's leaf hash. This depends on the value of the radio
1191                # and link options.
1192                my $nodeContent = {};
1193                if ($optionThing->{links}) {
1194                    # Compute the link value.
1195                    my $linkable = uri_escape($id);
1196                    $nodeContent->{link} = "$svURL?page=Subsystems;subsystem=$linkable";
1197                }
1198                if ($optionThing->{radio}) {
1199                    # Compute the radio value.
1200                    $nodeContent->{value} = "id=$id";
1201                }
1202                # Push the node into its parent branch.
1203                Trace("\"$nodeName\" added to node list.") if T(4);
1204                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1205            }
1206        }
1207        # Return the result.
1208        return \@retVal;
1209    }
1210    
1211    
1212  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1213    
1214  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>      my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows);
1215    
1216  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
1217  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 1084  Line 1240 
1240    
1241  =item crossMenu (optional)  =item crossMenu (optional)
1242    
1243  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.  
1244    
1245  =item RETURN  =item RETURN
1246    
# Line 1107  Line 1260 
1260      if (! defined $rows) {      if (! defined $rows) {
1261          $rows = ($multiple ? 10 : 1);          $rows = ($multiple ? 10 : 1);
1262      }      }
1263      # Create the multiple tag.      # Get a comma-delimited list of the preselected genomes.
1264      my $multipleTag = ($multiple ? " multiple" : "");      my $preselected = "";
1265      # Get the form name.      if ($selected) {
1266      my $formName = $self->FormName();          $preselected = join(", ", @$selected);
1267      # Check to see if we already have a genome list in memory.      }
1268      my $genomes = $self->{genomeList};      # Ask Sprout for a genome menu.
1269      my $groupHash;      my $retVal = $sprout->GenomeMenu(name => $menuName,
1270      if (defined $genomes) {                                       multiSelect => $multiple,
1271          # We have a list ready to use.                                       selected => $preselected,
1272          $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};  
             # Form the genome name.  
             my $name = "$genus $species";  
             if ($strain) {  
                 $name .= " $strain";  
             }  
             # Push the genome into the group's list.  
             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.  
     # 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) {  
         $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";  
     } elsif ($multiple) {  
         $onChange = " onChange=\"$showSelect\"";  
     }  
     # Create the SELECT tag and stuff it into the output array.  
     my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";  
     my @lines = ($select);  
     # Loop through the groups.  
     for my $group (@groups) {  
         # Create the option group tag.  
         my $tag = "<OPTGROUP label=\"$group\">";  
         push @lines, "  $tag";  
         # Compute the label for this group's options. This is seriously dirty stuff, as the  
         # label option may have functionality in future browsers. If that happens, we'll need  
         # to modify the genome text so that the "selectSome" method can tell which are NMPDR  
         # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript  
         # hierarchy, so we can't use it.  
         my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");  
         # Get the genomes in the group.  
         for my $genome (@{$groupHash->{$group}}) {  
             my ($genomeID, $name) = @{$genome};  
             # See if it's selected.  
             my $select = ($selectedHash{$genomeID} ? " selected" : "");  
             # Generate the option tag.  
             my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$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, 'nmpdr'); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $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, "");  
1273      # Return the result.      # Return the result.
1274      return $retVal;      return $retVal;
1275  }  }
1276    
1277  =head3 PropertyMenu  =head3 PropertyMenu
1278    
1279  C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>      my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force);
1280    
1281  Generate a property name dropdown menu.  Generate a property name dropdown menu.
1282    
# Line 1272  Line 1318 
1318      # Get all the property names, putting them after the null choice if one exists.      # Get all the property names, putting them after the null choice if one exists.
1319      push @propNames, $sprout->GetChoices('Property', 'property-name');      push @propNames, $sprout->GetChoices('Property', 'property-name');
1320      # Create a menu from them.      # Create a menu from them.
1321      my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,      my $retVal = CGI::popup_menu(-name=> $menuName, -values => \@propNames,
1322                                    -default => $selected);                                    -default => $selected);
1323      # Return the result.      # Return the result.
1324      return $retVal;      return $retVal;
# Line 1280  Line 1326 
1326    
1327  =head3 MakeTable  =head3 MakeTable
1328    
1329  C<< my $htmlText = $shelp->MakeTable(\@rows); >>      my $htmlText = $shelp->MakeTable(\@rows);
1330    
1331  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
1332  other words, each must have the TR and TD tags included.  other words, each must have the TR and TD tags included.
# Line 1296  Line 1342 
1342  =item rows  =item rows
1343    
1344  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
1345  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
1346  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1347    
1348  =item RETURN  =item RETURN
1349    
# Line 1312  Line 1358 
1358      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1359      # Get the CGI object.      # Get the CGI object.
1360      my $cgi = $self->Q();      my $cgi = $self->Q();
1361      # 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.
1362        # This flag will be set to FALSE when that happens.
1363        my $needWidth = 1;
1364      # 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
1365      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1366      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1367          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1368            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1369                # Here we have a first cell and its tag parameters are in $2.
1370                my $elements = $2;
1371                if ($elements !~ /colspan/i) {
1372                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1373                    # Here there's no colspan, so we plug in the width. We
1374                    # eschew the "g" modifier on the substitution because we
1375                    # only want to update the first cell.
1376                    $row =~ s/(<(td|th))/$1 width="150"/i;
1377                    # Denote we don't need this any more.
1378                    $needWidth = 0;
1379                }
1380            }
1381      }      }
1382      # Create the table.      # Create the table.
1383      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = CGI::table({border => 2, cellspacing => 2,
1384                                width => 700, class => 'search'},                                width => 700, class => 'search'},
1385                               @{$rows});                               @{$rows});
1386      # Return the result.      # Return the result.
# Line 1328  Line 1389 
1389    
1390  =head3 SubmitRow  =head3 SubmitRow
1391    
1392  C<< my $htmlText = $shelp->SubmitRow(); >>      my $htmlText = $shelp->SubmitRow($caption);
1393    
1394  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1395  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1396  near the top of the form.  near the top of the form.
1397    
 =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. There are  
 two rows returned, and the 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.  
   
1398  =over 4  =over 4
1399    
1400  =item sprout  =item caption (optional)
   
 Sprout object for accessing the database.  
   
 =item feat  
1401    
1402  ID of the feature whose Gbrowse URL is desired.  Caption to be put on the search button. The default is C<Go>.
1403    
1404  =item RETURN  =item RETURN
1405    
1406  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
1407  ID, contig ID, starting offset, and stopping offset.  and tuning the results.
1408    
1409  =back  =back
1410    
1411  =cut  =cut
1412    
1413  sub GBrowseFeatureURL {  sub SubmitRow {
1414      # Get the parameters.      # Get the parameters.
1415      my ($sprout, $feat) = @_;      my ($self, $caption) = @_;
1416      # Declare the return variable.      my $cgi = $self->Q();
1417      my $retVal;      # Compute the button caption.
1418      # Compute the genome ID.      my $realCaption = (defined $caption ? $caption : 'Go');
1419      my ($genomeID) = FIGRules::ParseFeatureID($feat);      # Get the current page size.
1420      # Only proceed if the feature ID produces a valid genome.      my $pageSize = $cgi->param('PageSize');
1421      if ($genomeID) {      # Get the current feature ID type.
1422          # Get the feature location string.      my $aliasType = $self->GetPreferredAliasType();
1423          my $loc = $sprout->FeatureLocation($feat);      # Create the rows.
1424          # Compute the contig, start, and stop points.      my $retVal = CGI::Tr(CGI::td("Identifier Type "),
1425          my($contig, $start, $stop) = BasicLocation::Parse($loc);                            CGI::td({ colspan => 2 },
1426          Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);                                     CGI::popup_menu(-name => 'AliasType',
1427          # Now we need to do some goofiness to insure that the location is not too                                                      -values => ['FIG', AliasAnalysis::AliasTypes() ],
1428          # big and that we get some surrounding stuff.                                                      -default => $aliasType) .
1429          my $mid = int(($start + $stop) / 2);                                     Hint("Identifier Type", "Specify how you want gene names to be displayed."))) .
1430          my $chunk_len = 20000;                   "\n" .
1431          my $max_feature = 40000;                   CGI::Tr(CGI::td("Results/Page"),
1432          my $feat_len = abs($stop - $start);                            CGI::td(CGI::popup_menu(-name => 'PageSize',
1433          if ($feat_len > $chunk_len) {                                                      -values => [10, 25, 50, 100, 1000],
1434              if ($feat_len > $max_feature) {                                                      -default => $pageSize)),
1435                  $chunk_len = $max_feature;                            CGI::td(CGI::submit(-class => 'goButton',
1436              } else {                                                  -name => 'Search',
1437                  $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";  
     }  
1438      # Return the result.      # Return the result.
1439      return $retVal;      return $retVal;
1440  }  }
1441    
1442  =head3 GetGenomes  =head3 GetGenomes
1443    
1444  C<< my @genomeList = $shelp->GetGenomes($parmName); >>      my @genomeList = $shelp->GetGenomes($parmName);
1445    
1446  Return the list of genomes specified by the specified CGI query parameter.  Return the list of genomes specified by the specified CGI query parameter.
1447  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 1498  Line 1483 
1483      return @retVal;      return @retVal;
1484  }  }
1485    
1486  =head3 GetHelpText  =head3 ComputeSearchURL
   
 C<< my $htmlText = $shelp->GetHelpText(); >>  
1487    
1488  Get the help text for this search. The help text is stored in files on the template      my $url = $shelp->ComputeSearchURL(%overrides);
 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;  
 }  
   
 =head3 ComputeSearchURL  
   
 C<< my $url = $shelp->ComputeSearchURL(); >>  
1489    
1490  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
1491  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 1551  Line 1495 
1495  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
1496  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1497    
1498    =over 4
1499    
1500    =item overrides
1501    
1502    Hash containing override values for the parameters, where the parameter name is
1503    the key and the parameter value is the override value. If the override value is
1504    C<undef>, the parameter will be deleted from the result.
1505    
1506    =item RETURN
1507    
1508    Returns a GET-style URL for invoking the search with the specified overrides.
1509    
1510    =back
1511    
1512  =cut  =cut
1513    
1514  sub ComputeSearchURL {  sub ComputeSearchURL {
1515      # Get the parameters.      # Get the parameters.
1516      my ($self) = @_;      my ($self, %overrides) = @_;
1517      # Get the database and CGI query object.      # Get the database and CGI query object.
1518      my $cgi = $self->Q();      my $cgi = $self->Q();
1519      my $sprout = $self->DB();      my $sprout = $self->DB();
1520      # Start with the full URL.      # Start with the full URL.
1521      my $retVal = $cgi->url(-full => 1);      my $retVal = "$FIG_Config::cgi_url/SearchSkeleton.cgi";
1522      # Get all the query parameters in a hash.      # Get all the query parameters in a hash.
1523      my %parms = $cgi->Vars();      my %parms = $cgi->Vars();
1524      # 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 1582  Line 1540 
1540          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1541          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1542          # Check for special cases.          # Check for special cases.
1543          if ($parmKey eq 'featureTypes') {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
             # Here we need to see if the user wants all the feature types. If he  
             # does, we erase all the values so that the parameter is not output.  
             my %valueCheck = map { $_ => 1 } @values;  
             my @list = FeatureQuery::AllFeatureTypes();  
             my $okFlag = 1;  
             for (my $i = 0; $okFlag && $i <= $#list; $i++) {  
                 if (! $valueCheck{$list[$i]}) {  
                     $okFlag = 0;  
                 }  
             }  
             if ($okFlag) {  
                 @values = ();  
             }  
         } elsif (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {  
1544              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1545              @values = ();              @values = ();
1546          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1610  Line 1554 
1554              if ($allFlag) {              if ($allFlag) {
1555                  @values = ();                  @values = ();
1556              }              }
1557            } elsif (exists $overrides{$parmKey}) {
1558                # Here the value is being overridden, so we skip it for now.
1559                @values = ();
1560          }          }
1561          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1562          if (@values) {          if (@values) {
1563              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1564          }          }
1565      }      }
1566        # Now do the overrides.
1567        for my $overKey (keys %overrides) {
1568            # Only use this override if it's not a delete marker.
1569            if (defined $overrides{$overKey}) {
1570                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1571            }
1572        }
1573      # Add the parameters to the URL.      # Add the parameters to the URL.
1574      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1575      # Return the result.      # Return the result.
1576      return $retVal;      return $retVal;
1577  }  }
1578    
1579  =head3 GetRunTimeValue  =head3 AdvancedClassList
1580    
1581        my @classes = SearchHelper::AdvancedClassList();
1582    
1583    Return a list of advanced class names. This list is used to generate the directory
1584    of available searches on the search page.
1585    
1586    We do a file search to accomplish this, but to pull it off we need to look at %INC.
1587    
1588    =cut
1589    
1590    sub AdvancedClassList {
1591        # Determine the search helper module directory.
1592        my $libDirectory = $INC{'SearchHelper.pm'};
1593        $libDirectory =~ s/SearchHelper\.pm//;
1594        # Read it, keeping only the helper modules.
1595        my @modules = grep { /^SH\w+\.pm/ } Tracer::OpenDir($libDirectory, 0);
1596        # Convert the file names to search types.
1597        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } @modules;
1598        # Return the result in alphabetical order.
1599        return sort @retVal;
1600    }
1601    
1602    =head3 SelectionTree
1603    
1604        my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options);
1605    
1606    Display a selection tree.
1607    
1608    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1609    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1610    addition, some of the tree nodes can contain hyperlinks.
1611    
1612    The tree itself is passed in as a multi-level list containing node names followed by
1613    contents. Each content element is a reference to a similar list. The first element of
1614    each list may be a hash reference. If so, it should contain one or both of the following
1615    keys.
1616    
1617    =over 4
1618    
1619    =item link
1620    
1621    The navigation URL to be popped up if the user clicks on the node name.
1622    
1623    =item value
1624    
1625    The form value to be returned if the user selects the tree node.
1626    
1627    =back
1628    
1629    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1630    a C<value> key indicates the node name will have a radio button. If a node has no children,
1631    you may pass it a hash reference instead of a list reference.
1632    
1633    The following example shows the hash for a three-level tree with links on the second level and
1634    radio buttons on the third.
1635    
1636        [   Objects => [
1637                Entities => [
1638                    {link => "../docs/WhatIsAnEntity.html"},
1639                    Genome => {value => 'GenomeData'},
1640                    Feature => {value => 'FeatureData'},
1641                    Contig => {value => 'ContigData'},
1642                ],
1643                Relationships => [
1644                    {link => "../docs/WhatIsARelationShip.html"},
1645                    HasFeature => {value => 'GenomeToFeature'},
1646                    IsOnContig => {value => 'FeatureToContig'},
1647                ]
1648            ]
1649        ]
1650    
1651    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1652    all have list references.
1653    
1654    This next example shows how to set up a taxonomy selection field. The value returned
1655    by the tree control will be the taxonomy string for the selected node ready for use
1656    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1657    reasons of space.
1658    
1659        [   All => [
1660                {value => "%"},
1661                Bacteria => [
1662                    {value => "Bacteria%"},
1663                    Proteobacteria => [
1664                        {value => "Bacteria; Proteobacteria%"},
1665                        Epsilonproteobacteria => [
1666                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1667                            Campylobacterales => [
1668                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1669                                Campylobacteraceae =>
1670                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1671                                ...
1672                            ]
1673                            ...
1674                        ]
1675                        ...
1676                    ]
1677                    ...
1678                ]
1679                ...
1680            ]
1681        ]
1682    
 C<< my $htmlText = $shelp->GetRunTimeValue($text); >>  
1683    
1684  Compute a run-time column value.  This method of tree storage allows the caller to control the order in which the tree nodes
1685    are displayed and to completely control value selection and use of hyperlinks. It is, however
1686    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1687    
1688    The parameters to this method are as follows.
1689    
1690  =over 4  =over 4
1691    
1692  =item text  =item cgi
1693    
1694    CGI object used to generate the HTML.
1695    
1696    =item tree
1697    
1698    Reference to a hash describing a tree. See the description above.
1699    
1700    =item options
1701    
1702  The run-time column text. It consists of 2 percent signs, a column type, an equal  Hash containing options for the tree display.
1703  sign, and the data for the current row.  
1704    =back
1705    
1706    The allowable options are as follows
1707    
1708    =over 4
1709    
1710    =item nodeImageClosed
1711    
1712    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1713    on the image will expand a section of the tree. The default is C<plus.gif>.
1714    
1715    =item nodeImageOpen
1716    
1717    URL of the image to display next to the tree nodes when they are expanded. Clicking
1718    on the image will collapse a section of the tree. The default is C<minus.gif>.
1719    
1720    =item style
1721    
1722    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1723    as nested lists, the key components of this style are the definitions for the C<ul> and
1724    C<li> tags. The default style file contains the following definitions.
1725    
1726        .tree ul {
1727           margin-left: 0; padding-left: 22px
1728        }
1729        .tree li {
1730            list-style-type: none;
1731        }
1732    
1733    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1734    parent by the width of the node image. This use of styles limits the things we can do in formatting
1735    the tree, but it has the advantage of vastly simplifying the tree creation.
1736    
1737    =item name
1738    
1739    Field name to give to the radio buttons in the tree. The default is C<selection>.
1740    
1741    =item target
1742    
1743    Frame target for links. The default is C<_self>.
1744    
1745    =item selected
1746    
1747    If specified, the value of the radio button to be pre-selected.
1748    
1749    =back
1750    
1751    =cut
1752    
1753    sub SelectionTree {
1754        # Get the parameters.
1755        my ($cgi, $tree, %options) = @_;
1756        # Get the options.
1757        my $optionThing = Tracer::GetOptions({ name => 'selection',
1758                                               nodeImageClosed => "$FIG_Config::cgi_url/Html/plus.gif",
1759                                               nodeImageOpen => "$FIG_Config::cgi_url/Html/minus.gif",
1760                                               style => 'tree',
1761                                               target => '_self',
1762                                               selected => undef},
1763                                             \%options);
1764        # Declare the return variable. We'll do the standard thing with creating a list
1765        # of HTML lines and rolling them together at the end.
1766        my @retVal = ();
1767        # Only proceed if the tree is present.
1768        if (defined($tree)) {
1769            # Validate the tree.
1770            if (ref $tree ne 'ARRAY') {
1771                Confess("Selection tree is not a list reference.");
1772            } elsif (scalar @{$tree} == 0) {
1773                # The tree is empty, so we do nothing.
1774            } elsif ($tree->[0] eq 'HASH') {
1775                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
1776            } else {
1777                # Here we have a real tree. Apply the tree style.
1778                push @retVal, CGI::start_div({ class => $optionThing->{style} });
1779                # Give us a DIV ID.
1780                my $divID = GetDivID($optionThing->{name});
1781                # Show the tree.
1782                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
1783                # Close the DIV block.
1784                push @retVal, CGI::end_div();
1785            }
1786        }
1787        # Return the result.
1788        return join("\n", @retVal, "");
1789    }
1790    
1791    =head3 ShowBranch
1792    
1793        my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType);
1794    
1795    This is a recursive method that displays a branch of the tree.
1796    
1797    =over 4
1798    
1799    =item cgi
1800    
1801    CGI object used to format HTML.
1802    
1803    =item label
1804    
1805    Label of this tree branch. It is only used in error messages.
1806    
1807    =item id
1808    
1809    ID to be given to this tree branch. The ID is used in the code that expands and collapses
1810    tree nodes.
1811    
1812    =item branch
1813    
1814    Reference to a list containing the content of the tree branch. The list contains an optional
1815    hash reference that is ignored and the list of children, each child represented by a name
1816    and then its contents. The contents could by a hash reference (indicating the attributes
1817    of a leaf node), or another tree branch.
1818    
1819    =item options
1820    
1821    Options from the original call to L</SelectionTree>.
1822    
1823    =item displayType
1824    
1825    C<block> if the contents of this list are to be displayed, C<none> if they are to be
1826    hidden.
1827    
1828  =item RETURN  =item RETURN
1829    
1830  Returns the fully-formatted HTML text to go into the current column of the current row.  Returns one or more HTML lines that can be used to display the tree branch.
1831    
1832  =back  =back
1833    
1834  =cut  =cut
1835    
1836  sub GetRunTimeValue {  sub ShowBranch {
1837      # Get the parameters.      # Get the parameters.
1838      my ($self, $text) = @_;      my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
1839      # Declare the return variable.      # Declare the return variable.
1840      my $retVal;      my @retVal = ();
1841      # Parse the incoming text.      # Start the branch.
1842      if ($text =~ /^%%([^=]+)=(.*)$/) {      push @retVal, CGI::start_ul({ id => $id, style => "display:$displayType" });
1843          $retVal = $self->RunTimeColumns($1, $2);      # Check for the hash and choose the start location accordingly.
1844        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
1845        # Get the list length.
1846        my $i1 = scalar(@{$branch});
1847        # Verify we have an even number of elements.
1848        if (($i1 - $i0) % 2 != 0) {
1849            Trace("Branch elements are from $i0 to $i1.") if T(3);
1850            Confess("Odd number of elements in tree branch $label.");
1851      } else {      } else {
1852          Confess("Invalid run-time column string \"$text\" encountered in session file.");          # Loop through the elements.
1853            for (my $i = $i0; $i < $i1; $i += 2) {
1854                # Get this node's label and contents.
1855                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
1856                # Get an ID for this node's children (if any).
1857                my $myID = GetDivID($options->{name});
1858                # Now we need to find the list of children and the options hash.
1859                # This is a bit ugly because we allow the shortcut of a hash without an
1860                # enclosing list. First, we need some variables.
1861                my $attrHash = {};
1862                my @childHtml = ();
1863                my $hasChildren = 0;
1864                if (! ref $myContent) {
1865                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
1866                } elsif (ref $myContent eq 'HASH') {
1867                    # Here the node is a leaf and its content contains the link/value hash.
1868                    $attrHash = $myContent;
1869                } elsif (ref $myContent eq 'ARRAY') {
1870                    # Here the node may be a branch. Its content is a list.
1871                    my $len = scalar @{$myContent};
1872                    if ($len >= 1) {
1873                        # Here the first element of the list could by the link/value hash.
1874                        if (ref $myContent->[0] eq 'HASH') {
1875                            $attrHash = $myContent->[0];
1876                            # If there's data in the list besides the hash, it's our child list.
1877                            # We can pass the entire thing as the child list, because the hash
1878                            # is ignored.
1879                            if ($len > 1) {
1880                                $hasChildren = 1;
1881      }      }
1882                        } else {
1883                            $hasChildren = 1;
1884                        }
1885                        # If we have children, create the child list with a recursive call.
1886                        if ($hasChildren) {
1887                            Trace("Processing children of $myLabel.") if T(4);
1888                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'block');
1889                            Trace("Children of $myLabel finished.") if T(4);
1890                        }
1891                    }
1892                }
1893                # Okay, it's time to pause and take stock. We have the label of the current node
1894                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
1895                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
1896                # Compute the image HTML. It's tricky, because we have to deal with the open and
1897                # closed images.
1898                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
1899                my $image = $images[$hasChildren];
1900                my $prefixHtml = CGI::img({src => $image, id => "${myID}img"});
1901                if ($hasChildren) {
1902                    # If there are children, we wrap the image in a toggle hyperlink.
1903                    $prefixHtml = CGI::a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
1904                                          $prefixHtml);
1905                }
1906                # Now the radio button, if any. Note we use "defined" in case the user wants the
1907                # value to be 0.
1908                if (defined $attrHash->{value}) {
1909                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
1910                    # hash for the "input" method. If the item is pre-selected, we add
1911                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
1912                    # at all.
1913                    my $radioParms = { type => 'radio',
1914                                       name => $options->{name},
1915                                       value => $attrHash->{value},
1916                                     };
1917                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
1918                        $radioParms->{checked} = undef;
1919                    }
1920                    $prefixHtml .= CGI::input($radioParms);
1921                }
1922                # Next, we format the label.
1923                my $labelHtml = $myLabel;
1924                Trace("Formatting tree node for \"$myLabel\".") if T(4);
1925                # Apply a hyperlink if necessary.
1926                if (defined $attrHash->{link}) {
1927                    $labelHtml = CGI::a({ href => $attrHash->{link}, target => $options->{target} },
1928                                         $labelHtml);
1929                }
1930                # Finally, roll up the child HTML. If there are no children, we'll get a null string
1931                # here.
1932                my $childHtml = join("\n", @childHtml);
1933                # Now we have all the pieces, so we can put them together.
1934                push @retVal, CGI::li("$prefixHtml$labelHtml$childHtml");
1935            }
1936        }
1937        # Close the tree branch.
1938        push @retVal, CGI::end_ul();
1939      # Return the result.      # Return the result.
1940      return $retVal;      return @retVal;
1941  }  }
1942    
1943  =head2 Feature Column Methods  =head3 GetDivID
1944    
1945  The methods in this column manage feature column data. If you want to provide the      my $idString = SearchHelper::GetDivID($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.  
1946    
1947  There is one special column name syntax for extra columns (that is, nonstandard  Return a new HTML ID string.
 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.  
1948    
1949  =head3 DefaultFeatureColumns  =over 4
1950    
1951    =item name
1952    
1953  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Name to be prefixed to the ID string.
1954    
1955  Return a reference to a list of the default feature column identifiers. These  =item RETURN
1956  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
1957  order to produce the column titles and row values.  Returns a hopefully-unique ID string.
1958    
1959    =back
1960    
1961  =cut  =cut
1962    
1963  sub DefaultFeatureColumns {  sub GetDivID {
1964      # Get the parameters.      # Get the parameters.
1965      my ($self) = @_;      my ($name) = @_;
1966        # Compute the ID.
1967        my $retVal = "elt_$name$divCount";
1968        # Increment the counter to make sure this ID is not re-used.
1969        $divCount++;
1970      # Return the result.      # Return the result.
1971      return ['orgName', 'function', 'gblink', 'protlink',      return $retVal;
             FeatureQuery::AdditionalColumns($self)];  
1972  }  }
1973    
1974  =head3 FeatureColumnTitle  =head3 PrintLine
1975    
1976  C<< my $title = $shelp->FeatureColumnTitle($colName); >>      $shelp->PrintLine($message);
1977    
1978  Return the column heading title to be used for the specified feature column.  Print a line of CGI output. This is used during the operation of the B<Find> method while
1979    searching, so the user sees progress in real-time.
1980    
1981  =over 4  =over 4
1982    
1983  =item name  =item message
1984    
1985    HTML text to display.
1986    
1987    =back
1988    
1989    =cut
1990    
1991    sub PrintLine {
1992        # Get the parameters.
1993        my ($self, $message) = @_;
1994        # Send the message to the output.
1995        print "$message\n";
1996    }
1997    
1998    =head3 GetHelper
1999    
2000        my $shelp = SearchHelper::GetHelper($parm, $type => $className);
2001    
2002    Return a helper object with the given class name. If no such class exists, an
2003    error will be thrown.
2004    
2005    =over 4
2006    
2007    =item parm
2008    
2009  Name of the desired feature column.  Parameter to pass to the constructor. This is a CGI object for a search helper
2010    and a search helper object for the result helper.
2011    
2012    =item type
2013    
2014    Type of helper: C<RH> for a result helper and C<SH> for a search helper.
2015    
2016    =item className
2017    
2018    Class name for the helper object, without the preceding C<SH> or C<RH>. This is
2019    identical to what the script expects for the C<Class> or C<ResultType> parameter.
2020    
2021  =item RETURN  =item RETURN
2022    
2023  Returns the title to be used as the column header for the named feature column.  Returns a helper object for the specified class.
2024    
2025  =back  =back
2026    
2027  =cut  =cut
2028    
2029  sub FeatureColumnTitle {  sub GetHelper {
2030      # Get the parameters.      # Get the parameters.
2031      my ($self, $colName) = @_;      my ($parm, $type, $className) = @_;
2032      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
2033      my $retVal = "&nbsp;";      my $retVal;
2034      # Process the column name.      # Try to create the helper.
2035      if ($colName =~ /^X=(.+)$/) {      eval {
2036          # Here we have an extra column.          # Load it into memory. If it's already there nothing will happen here.
2037          $retVal = $1;          my $realName = "$type$className";
2038      } elsif ($colName eq 'orgName') {          Trace("Requiring helper $realName.") if T(3);
2039          $retVal = "Name";          require "$realName.pm";
2040      } elsif ($colName eq 'fid') {          Trace("Constructing helper object.") if T(3);
2041          $retVal = "FIG ID";          # Construct the object.
2042      } elsif ($colName eq 'alias') {          $retVal = eval("$realName->new(\$parm)");
2043          $retVal = "External Aliases";          # Commit suicide if it didn't work.
2044      } elsif ($colName eq 'function') {          if (! defined $retVal) {
2045          $retVal = "Functional Assignment";              die "Could not find a $type handler of type $className.";
2046      } elsif ($colName eq 'gblink') {          } else {
2047          $retVal = "GBrowse";              # Perform any necessary subclass initialization.
2048      } elsif ($colName eq 'protlink') {              $retVal->Initialize();
2049          $retVal = "NMPDR Protein Page";          }
2050      } elsif ($colName eq 'group') {      };
2051          $retVal = "NMDPR Group";      # Check for errors.
2052        if ($@) {
2053            Confess("Error retrieving $type$className: $@");
2054      }      }
2055      # Return the result.      # Return the result.
2056      return $retVal;      return $retVal;
2057  }  }
2058    
2059  =head3 FeatureColumnValue  =head3 SaveOrganismData
2060    
2061  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>      my ($name, $displayGroup, $domain) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy);
2062    
2063  Return the value to be displayed in the specified feature column.  Format the name of an organism and the display version of its group name. The incoming
2064    data should be the relevant fields from the B<Genome> record in the database. The
2065    data will also be stored in the genome cache for later use in posting search results.
2066    
2067  =over 4  =over 4
2068    
2069  =item colName  =item group
2070    
2071    Name of the genome's group as it appears in the database.
2072    
2073    =item genomeID
2074    
2075    ID of the relevant genome.
2076    
2077  Name of the column to be displayed.  =item genus
2078    
2079  =item record  Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2080    in the database. In this case, the organism name is derived from the genomeID and the group
2081    is automatically the supporting-genomes group.
2082    
2083  DBObject record for the feature being displayed in the current row.  =item species
2084    
2085  =item extraCols  Species of the genome's organism.
2086    
2087  Reference to a hash of extra column names to values. If the incoming column name  =item strain
2088  begins with C<X=>, its value will be taken from this hash.  
2089    Strain of the species represented by the genome.
2090    
2091    =item taxonomy
2092    
2093    Taxonomy of the species represented by the genome.
2094    
2095  =item RETURN  =item RETURN
2096    
2097  Returns the HTML to be displayed in the named column for the specified feature.  Returns a three-element list. The first element is the formatted genome name. The second
2098    element is the display name of the genome's group. The third is the genome's domain.
2099    
2100  =back  =back
2101    
2102  =cut  =cut
2103    
2104  sub FeatureColumnValue {  sub SaveOrganismData {
2105      # Get the parameters.      # Get the parameters.
2106      my ($self, $colName, $record, $extraCols) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2107      # Get the sprout and CGI objects.      # Declare the return values.
2108      my $cgi = $self->Q();      my ($name, $displayGroup);
2109      my $sprout = $self->DB();      # If the organism does not exist, format an unknown name and a blank group.
2110      # Get the feature ID.      if (! defined($genus)) {
2111      my ($fid) = $record->Value('Feature(id)');          $name = "Unknown Genome $genomeID";
2112      # Declare the return variable. Denote that we default to a non-breaking space,          $displayGroup = "";
2113      # which will translate to an empty table cell (rather than a table cell with no      } else {
2114      # interior, which is what you get for a null string).          # It does exist, so format the organism name.
2115      my $retVal = "&nbsp;";          $name = "$genus $species";
2116      # Process according to the column name.          if ($strain) {
2117      if ($colName =~ /^X=(.+)$/) {              $name .= " $strain";
         # 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 'orgName') {  
         # Here we want the formatted organism name and feature number.  
         $retVal = $self->FeatureName($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 '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 = "%%aliases=$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 '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 '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);  
2118      }      }
2119            # Compute the display group. This is currently the same as the incoming group
2120            # name unless it's the supporting group, which is nulled out.
2121            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2122            Trace("Group = $displayGroup, translated from \"$group\".") if T(4);
2123        }
2124        # Compute the domain from the taxonomy.
2125        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2126        # Cache the group and organism data.
2127        my $cache = $self->{orgs};
2128        $cache->{$genomeID} = [$name, $displayGroup, $domain];
2129      # Return the result.      # Return the result.
2130      return $retVal;      return ($name, $displayGroup, $domain);
2131  }  }
2132    
2133  =head3 RunTimeColumns  =head3 ValidateKeywords
2134    
2135  C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>      my $okFlag = $shelp->ValidateKeywords($keywordString, $required);
2136    
2137  Return the HTML text for a run-time column. Run-time columns are evaluated when the  Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2138  list is displayed, rather than when it is generated.  set.
2139    
2140  =over 4  =over 4
2141    
2142  =item type  =item keywordString
2143    
2144  Type of column.  Keyword string specified as a parameter to the current search.
2145    
2146  =item text  =item required
2147    
2148  Data relevant to this row of the column.  TRUE if there must be at least one keyword specified, else FALSE.
2149    
2150  =item RETURN  =item RETURN
2151    
2152  Returns the fully-formatted HTML text to go in the specified column.  Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2153    is acceptable if the I<$required> parameter is not specified.
2154    
2155  =back  =back
2156    
2157  =cut  =cut
2158    
2159  sub RunTimeColumns {  sub ValidateKeywords {
2160      # Get the parameters.      # Get the parameters.
2161      my ($self, $type, $text) = @_;      my ($self, $keywordString, $required) = @_;
2162      # Declare the return variable.      # Declare the return variable.
2163      my $retVal = "";      my $retVal = 0;
2164      # Get the Sprout and CGI objects.      my @wordList = split /\s+/, $keywordString;
2165      my $sprout = $self->DB();      # Right now our only real worry is a list of all minus words. The problem with it is that
2166        # it will return an incorrect result.
2167        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2168        if (! @wordList) {
2169            if ($required) {
2170                $self->SetMessage("No search words specified.");
2171            } else {
2172                $retVal = 1;
2173            }
2174        } elsif (! @plusWords) {
2175            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2176        } else {
2177            $retVal = 1;
2178        }
2179        # Return the result.
2180        return $retVal;
2181    }
2182    
2183    =head3 TuningParameters
2184    
2185        my $options = $shelp->TuningParameters(%parmHash);
2186    
2187    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2188    to their default values. The parameters and their values will be returned as a hash reference.
2189    
2190    =over 4
2191    
2192    =item parmHash
2193    
2194    Hash mapping parameter names to their default values.
2195    
2196    =item RETURN
2197    
2198    Returns a reference to a hash containing the parameter names mapped to their actual values.
2199    
2200    =back
2201    
2202    =cut
2203    
2204    sub TuningParameters {
2205        # Get the parameters.
2206        my ($self, %parmHash) = @_;
2207        # Declare the return variable.
2208        my $retVal = {};
2209        # Get the CGI Query Object.
2210      my $cgi = $self->Q();      my $cgi = $self->Q();
2211      # Separate the text into a type and data.      # Loop through the parameter names.
2212      if ($type eq 'aliases') {      for my $parm (keys %parmHash) {
2213          # Here the caller wants external alias links for a feature. The text          # Get the incoming value for this parameter.
2214          # is the feature ID.          my $value = $cgi->param($parm);
2215          my $fid = $text;          # Zero might be a valid value, so we do an is-defined check rather than an OR.
2216          # The complicated part is we have to hyperlink them. First, get the          if (defined($value)) {
2217          # aliases.              $retVal->{$parm} = $value;
2218          Trace("Generating aliases for feature $fid.") if T(4);          } else {
2219          my @aliases = $sprout->FeatureAliases($fid);              $retVal->{$parm} = $parmHash{$parm};
         # Only proceed if we found some.  
         if (@aliases) {  
             # Join the aliases into a comma-delimited list.  
             my $aliasList = join(", ", @aliases);  
             # Ask the HTML processor to hyperlink them.  
             $retVal = HTML::set_prot_links($cgi, $aliasList);  
2220          }          }
2221      }      }
2222      # Return the result.      # Return the result.
2223      return $retVal;      return $retVal;
2224  }  }
2225    
2226    =head3 GetPreferredAliasType
2227    
2228        my $type = $shelp->GetPreferredAliasType();
2229    
2230    Return the preferred alias type for the current session. This information is stored
2231    in the C<AliasType> parameter of the CGI query object, and the default is C<FIG>
2232    (which indicates the FIG ID).
2233    
2234    =cut
2235    
2236    sub GetPreferredAliasType {
2237        # Get the parameters.
2238        my ($self) = @_;
2239        # Determine the preferred type.
2240        my $cgi = $self->Q();
2241        my $retVal = $cgi->param('AliasType') || 'FIG';
2242        # Return it.
2243        return $retVal;
2244    }
2245    
2246    =head3 Hint
2247    
2248        my $htmlText = SearchHelper::Hint($wikiPage, $hintText);
2249    
2250    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
2251    This HTML can be put in forms to provide a useful hinting mechanism.
2252    
2253    =over 4
2254    
2255    =item wikiPage
2256    
2257    Name of the wiki page to be popped up when the hint mark is clicked.
2258    
2259    =item hintText
2260    
2261    Text to display for the hint. It is raw html, but may not contain any double quotes.
2262    
2263    =item RETURN
2264    
2265    Returns the html for the hint facility. The resulting html shows a small button-like thing that
2266    uses the standard FIG popup technology.
2267    
2268    =back
2269    
2270    =cut
2271    
2272    sub Hint {
2273        # Get the parameters.
2274        my ($wikiPage, $hintText) = @_;
2275        # Ask Sprout to draw the hint button for us.
2276        return Sprout::Hint($wikiPage, $hintText);
2277    }
2278    
2279    
2280    
2281  =head2 Virtual Methods  =head2 Virtual Methods
2282    
2283    =head3 HeaderHtml
2284    
2285        my $html = $shelp->HeaderHtml();
2286    
2287    Generate HTML for the HTML header. If extra styles or javascript are required,
2288    they should go in here.
2289    
2290    =cut
2291    
2292    sub HeaderHtml {
2293        return "";
2294    }
2295    
2296  =head3 Form  =head3 Form
2297    
2298  C<< my $html = $shelp->Form(); >>      my $html = $shelp->Form($mode);
2299    
2300  Generate the HTML for a form to request a new search.  Generate the HTML for a form to request a new search. If the subclass does not
2301    override this method, then the search is formless, and must be started from an
2302    external page.
2303    
2304    =cut
2305    
2306    sub Form {
2307        # Get the parameters.
2308        my ($self) = @_;
2309        return "";
2310    }
2311    
2312  =head3 Find  =head3 Find
2313    
2314  C<< my $resultCount = $shelp->Find(); >>      my $resultCount = $shelp->Find();
2315    
2316  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
2317  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
2318  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
2319  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.
2320    
2321    =cut
2322    
2323    sub Find {
2324        # Get the parameters.
2325        my ($self) = @_;
2326        $self->Message("Call to pure virtual Find method in helper of type " . ref($self) . ".");
2327        return undef;
2328    }
2329    
2330  =head3 Description  =head3 Description
2331    
2332  C<< my $htmlText = $shelp->Description(); >>      my $htmlText = $shelp->Description();
2333    
2334  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
2335  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,
2336  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.
2337    
2338  =head3 SortKey  =cut
2339    
2340    sub Description {
2341        # Get the parameters.
2342        my ($self) = @_;
2343        $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2344        return "Unknown search type";
2345    }
2346    
2347  C<< my $key = $shelp->SortKey($record); >>  =head3 SearchTitle
2348    
2349  Return the sort key for the specified record. The default is to sort by feature name,      my $titleHtml = $shelp->SearchTitle();
2350  floating NMPDR organisms to the top. This sort may be overridden by the search class  
2351  to provide fancier functionality. This method is called by B<PutFeature>, so it  Return the display title for this search. The display title appears above the search results.
2352  is only used for feature searches. A non-feature search would presumably have its  If no result is returned, no title will be displayed. The result should be an html string
2353  own sort logic.  that can be legally put inside a block tag such as C<h3> or C<p>.
2354    
2355    =cut
2356    
2357    sub SearchTitle {
2358        # Get the parameters.
2359        my ($self) = @_;
2360        # Declare the return variable.
2361        my $retVal = "";
2362        # Return it.
2363        return $retVal;
2364    }
2365    
2366    =head3 DefaultColumns
2367    
2368        $shelp->DefaultColumns($rhelp);
2369    
2370    Store the default columns in the result helper. The default action is just to ask
2371    the result helper for its default columns, but this may be changed by overriding
2372    this method.
2373    
2374  =over 4  =over 4
2375    
2376  =item record  =item rhelp
2377    
2378  The C<DBObject> from which the current row of data is derived.  Result helper object in which the column list should be stored.
2379    
2380    =back
2381    
2382    =cut
2383    
2384    sub DefaultColumns {
2385        # Get the parameters.
2386        my ($self, $rhelp) = @_;
2387        # Get the default columns from the result helper.
2388        my @cols = $rhelp->DefaultResultColumns();
2389        # Store them back.
2390        $rhelp->SetColumns(@cols);
2391    }
2392    
2393    
2394    =head3 Initialize
2395    
2396        $shelp->Initialize();
2397    
2398    Perform any initialization required after construction of the helper.
2399    
2400    =cut
2401    
2402    sub Initialize {
2403        # The default is to do nothing.
2404    }
2405    
2406    =head3 GetResultHelper
2407    
2408        my $rhelp = $shelp->GetResultHelper($className);
2409    
2410    Return a result helper for this search helper. The default action is to create
2411    a result helper from scratch; however, if the subclass has an internal result
2412    helper it can override this method to return it without having to create a new
2413    one.
2414    
2415    =over 4
2416    
2417    =item className
2418    
2419    Result helper class name.
2420    
2421  =item RETURN  =item RETURN
2422    
2423  Returns a key field that can be used to sort this row in among the results.  Returns a result helper of the specified class connected to this search helper.
2424    
2425  =back  =back
2426    
2427  =cut  =cut
2428    
2429  sub SortKey {  sub GetResultHelper {
2430      # Get the parameters.      # Get the parameters.
2431      my ($self, $record) = @_;      my ($self, $className) = @_;
2432      # Get the feature ID from the record.      # Create the helper.
2433      my ($fid) = $record->Value('Feature(id)');      my $retVal = GetHelper($self, RH => $className);
2434      # Get the group from the feature ID.      # return it.
     my $group = $self->FeatureGroup($fid);  
     # Ask the feature query object to form the sort key.  
     my $retVal = FeatureQuery::SortKey($self, $group, $record);  
     # Return the result.  
2435      return $retVal;      return $retVal;
2436  }  }
2437    
2438  1;  1;

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.44

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3