[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.34, Mon Jul 16 20:04:51 2007 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;
# Line 19  Line 19 
19      use FeatureQuery;      use FeatureQuery;
20      use URI::Escape;      use URI::Escape;
21      use PageBuilder;      use PageBuilder;
22        use AliasAnalysis;
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    
 =item filtered  
   
 TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  
 field is updated by the B<FeatureQuery> object.  
   
89  =back  =back
90    
91  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 103  Line 101 
101  =item 2  =item 2
102    
103  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
104  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
105    type of search.
106    
107  =item 3  =item 3
108    
# Line 113  Line 112 
112    
113  =item 4  =item 4
114    
115  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
116  and then put the class name in the C<@advancedClasses> list.  must create a new subclass of B<ResultHelper>. Its name must be
117    C<RH>I<className>, where I<className> is the type of result.
118    
119  =back  =back
120    
# Line 150  Line 150 
150    
151  Several helper methods are provided for particular purposes.  Several helper methods are provided for particular purposes.
152    
 =over 4  
   
 =item 1  
   
153  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
154  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
155  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
156  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
157  be returned.  be returned.
158    
 =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  
   
159  L</QueueFormScript> allows you to queue JavaScript statements for execution  L</QueueFormScript> allows you to queue JavaScript statements for execution
160  after the form is fully generated. If you are using very complicated  after the form is fully generated. If you are using very complicated
161  form controls, the L</QueueFormScript> method allows you to perform  form controls, the L</QueueFormScript> method allows you to perform
162  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this  JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
163  facility to display a list of the pre-selected genomes.  facility to display a list of the pre-selected genomes.
164    
 =back  
   
165  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
166  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
167    
168  =head3 Finding Search Results  =head3 Finding Search Results
169    
170  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
171  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.  
172    
173      sub Find {      sub Find {
174          my ($self) = @_;          my ($self) = @_;
# Line 198  Line 181 
181          ... validate the parameters ...          ... validate the parameters ...
182          if (... invalid parameters...) {          if (... invalid parameters...) {
183              $self->SetMessage(...appropriate message...);              $self->SetMessage(...appropriate message...);
184          } elsif (FeatureQuery::Valid($self)) {          } else {
185                # Determine the result type.
186                my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
187                # Specify the columns.
188                $self->DefaultColumns($rhelp);
189                # You may want to add extra columns. $name is the column name and
190                # $loc is its location. The other parameters take their names from the
191                # corresponding column methods.
192                $rhelp->AddExtraColumn($name => $loc, style => $style, download => $flag,
193                    title => $title);
194                # Some searches require optional columns that are configured by the
195                # user or by the search query itself. There are some special methods
196                # for this in the result helpers, but there's also the direct approach
197                # shown below.
198                $rhelp->AddOptionalColumn($name => $loc);
199              # Initialize the session file.              # Initialize the session file.
200              $self->OpenSession();              $self->OpenSession($rhelp);
201              # Initialize the result counter.              # Initialize the result counter.
202              $retVal = 0;              $retVal = 0;
203              ... get a list of genomes ...              ... set up to loop through the results ...
204              for my $genomeID (... each genome ...) {              while (...more results...) {
205                  my $fq = FeatureQuery->new($self, $genomeID);                  ...compute extra columns and call PutExtraColumns...
206                  while (my $feature = $fq->Fetch()) {                  $rhelp->PutData($sortKey, $objectID, $record);
                     ... examine the feature ...  
                     if (... we want to keep it ...) {  
                         $self->PutFeature($fq);  
207                          $retVal++;                          $retVal++;
208                      }                      }
                 }  
             }  
         }  
209          # Close the session file.          # Close the session file.
210          $self->CloseSession();          $self->CloseSession();
211            }
212          # Return the result count.          # Return the result count.
213          return $retVal;          return $retVal;
214      }      }
215    
216  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
217  are variations on the above them. For example, you could eschew feature filtering  are variations on the above theme.
218  entirely in favor of your own custom filtering, you could include extra columns  
219  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
220  above code is just a loose framework.  to the output so that the user does not get bored waiting for results. The L</PrintLine>
221    method performs this function. The single parameter should be text to be
222    output to the browser. In general, you'll invoke it as follows.
223    
224  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.  
225    
226      $fq->AddExtraColumns(score => $sc);  The break tag is optional. When the Find method gets control, a paragraph will
227    have been started so that everything is XHTML-compliant.
228    
229  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
230  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 235 
235    
236  # 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.
237  my $formCount = 0;  my $formCount = 0;
238    # This counter is used to generate unique DIV IDs.
239    my $divCount = 0;
240    
241  =head2 Public Methods  =head2 Public Methods
242    
243  =head3 new  =head3 new
244    
245  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
246    
247  Construct a new SearchHelper object.  Construct a new SearchHelper object.
248    
249  =over 4  =over 4
250    
251  =item query  =item cgi
252    
253  The CGI query object for the current script.  The CGI query object for the current script.
254    
# Line 262  Line 258 
258    
259  sub new {  sub new {
260      # Get the parameters.      # Get the parameters.
261      my ($class, $query) = @_;      my ($class, $cgi) = @_;
262      # Check for a session ID.      # Check for a session ID.
263      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
264      my $type = "old";      my $type = "old";
265      if (! $session_id) {      if (! $session_id) {
266            Trace("No session ID found.") if T(3);
267          # 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
268          # store it in the query object.          # store it in the query object.
269          $session_id = NewSessionID();          $session_id = FIGRules::NewSessionID();
270            Trace("New session ID is $session_id.") if T(3);
271          $type = "new";          $type = "new";
272          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
273        } else {
274            Trace("Session ID is $session_id.") if T(3);
275      }      }
276        Trace("Computing subclass.") if T(3);
277      # Compute the subclass name.      # Compute the subclass name.
278      $class =~ /SH(.+)$/;      my $subClass;
279      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
280            # Here we have a real search class.
281            $subClass = $1;
282        } else {
283            # Here we have a bare class. The bare class cannot search, but it can
284            # process search results.
285            $subClass = 'SearchHelper';
286        }
287        Trace("Subclass name is $subClass.") if T(3);
288      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
289      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
290      # Generate the form name.      # Generate the form name.
291      my $formName = "$class$formCount";      my $formName = "$class$formCount";
292      $formCount++;      $formCount++;
293        Trace("Creating helper.") if T(3);
294      # 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)
295      # 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
296      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
297      my $retVal = {      my $retVal = {
298                    query => $query,                    query => $cgi,
299                    type => $type,                    type => $type,
300                    class => $subClass,                    class => $subClass,
301                    sprout => undef,                    sprout => undef,
# Line 294  Line 304 
304                    scriptQueue => [],                    scriptQueue => [],
305                    genomeList => undef,                    genomeList => undef,
306                    genomeParms => [],                    genomeParms => [],
                   filtered => 0,  
307                   };                   };
308      # Bless and return it.      # Bless and return it.
309      bless $retVal, $class;      bless $retVal, $class;
# Line 316  Line 325 
325      return $self->{query};      return $self->{query};
326  }  }
327    
328    
329    
330  =head3 DB  =head3 DB
331    
332  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 447  Line 458 
458      my ($self, $title) = @_;      my ($self, $title) = @_;
459      # Get the CGI object.      # Get the CGI object.
460      my $cgi = $self->Q();      my $cgi = $self->Q();
461      # Start the form.      # Start the form. Note we use the override option on the Class value, in
462        # case the Advanced button was used.
463      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
464                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
465                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
466                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
467                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
468                                -value => $self->{class}) .                                -value => $self->{class},
469                                  -override => 1) .
470                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
471                                -value => 1) .                                -value => 1) .
472                   $cgi->h3($title);                   $cgi->h3($title);
# Line 545  Line 558 
558    
559  =head3 OpenSession  =head3 OpenSession
560    
561  C<< $shelp->OpenSession(); >>  C<< $shelp->OpenSession($rhelp); >>
562    
563    Set up the session cache file and write out the column headers.
564    This method should not be called until all the columns have
565    been configured, including the extra columns.
566    
567  Set up to open the session cache file for writing. Note we don't actually  =over 4
568  open the file until after we know the column headers.  
569    =item rhelp
570    
571    Result helper for formatting the output. This has the column
572    headers stored in it.
573    
574    =back
575    
576  =cut  =cut
577    
578  sub OpenSession {  sub OpenSession {
579      # Get the parameters.      # Get the parameters.
580      my ($self) = @_;      my ($self, $rhelp) = @_;
581      # Denote we have not yet written out the column headers.      # Insure the result helper is valid.
582      $self->{cols} = undef;      if (! defined($rhelp)) {
583            Confess("No result type specified for $self->{class}.");
584        } elsif(! $rhelp->isa('ResultHelper')) {
585            Confess("Invalid result type specified for $self->{class}.");
586        } else {
587            # Get the column headers and write them out.
588            my $colHdrs = $rhelp->GetColumnHeaders();
589            Trace(scalar(@{$colHdrs}) . " column headers written to output.") if T(3);
590            $self->WriteColumnHeaders(@{$colHdrs});
591        }
592  }  }
593    
594  =head3 GetCacheFileName  =head3 GetCacheFileName
# Line 600  Line 632 
632      my ($self, $type) = @_;      my ($self, $type) = @_;
633      # Compute the file name. Note it gets stuffed in the FIG temporary      # Compute the file name. Note it gets stuffed in the FIG temporary
634      # directory.      # directory.
635      my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";      my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
636      # Return the result.      # Return the result.
637      return $retVal;      return $retVal;
638  }  }
639    
 =head3 PutFeature  
   
 C<< $shelp->PutFeature($fquery); >>  
   
 Store a feature in the result cache. This is the workhorse method for most  
 searches, since the primary data item in the database is features.  
   
 For each feature, there are certain columns that are standard: the feature name, the  
 GBrowse and protein page links, the functional assignment, and so forth. If additional  
 columns are required by a particular search subclass, they should be stored in  
 the feature query object using the B<AddExtraColumns> method. For example, the following  
 code adds columns for essentiality and virulence.  
   
     $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  
     $shelp->PutFeature($fq);  
   
 For correct results, all values should be specified for all extra columns in all calls to  
 B<PutFeature>. (In particular, the column header names are computed on the first  
 call.) If a column is to be blank for the current feature, its value can be given  
 as C<undef>.  
   
     if (! $essentialFlag) {  
         $essentialFlag = undef;  
     }  
     $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);  
     $shelp->PutFeature($fq);  
   
 =over 4  
   
 =item fquery  
   
 FeatureQuery object containing the current feature data.  
   
 =back  
   
 =cut  
   
 sub PutFeature {  
     # Get the parameters.  
     my ($self, $fq) = @_;  
     # Get the CGI query object.  
     my $cgi = $self->Q();  
     # 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);  
 }  
   
640  =head3 WriteColumnHeaders  =head3 WriteColumnHeaders
641    
642  C<< $shelp->WriteColumnHeaders(@colNames); >>  C<< $shelp->WriteColumnHeaders(@colNames); >>
# Line 692  Line 649 
649    
650  =item colNames  =item colNames
651    
652  A list of column names in the desired presentation order.  A list of column names in the desired presentation order. For extra columns,
653    the column name is the hash supplied as the column definition.
654    
655  =back  =back
656    
# Line 704  Line 662 
662      # Get the cache file name and open it for output.      # Get the cache file name and open it for output.
663      my $fileName = $self->GetCacheFileName();      my $fileName = $self->GetCacheFileName();
664      my $handle1 = Open(undef, ">$fileName");      my $handle1 = Open(undef, ">$fileName");
665        # Freeze the column headers.
666        my @colHdrs = map { freeze($_) } @colNames;
667      # Write the column headers and close the file.      # Write the column headers and close the file.
668      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colHdrs);
669      close $handle1;      close $handle1;
670      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
671      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
# Line 714  Line 674 
674      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
675  }  }
676    
677    =head3 ReadColumnHeaders
678    
679    C<< my @colHdrs = $shelp->ReadColumnHeaders($fh); >>
680    
681    Read the column headers from the specified file handle. The column headers are
682    frozen strings intermixed with frozen hash references. The strings represent
683    column names defined in the result helper. The hash references represent the
684    definitions of the extra columns.
685    
686    =over 4
687    
688    =item fh
689    
690    File handle from which the column headers are to be read.
691    
692    =item RETURN
693    
694    Returns a list of the column headers pulled from the specified file's first line.
695    
696    =back
697    
698    =cut
699    
700    sub ReadColumnHeaders {
701        # Get the parameters.
702        my ($self, $fh) = @_;
703        # Read and thaw the columns.
704        my @retVal = map { thaw($_) } Tracer::GetLine($fh);
705        # Return them to the caller.
706        return @retVal;
707    }
708    
709  =head3 WriteColumnData  =head3 WriteColumnData
710    
711  C<< $shelp->WriteColumnData($key, @colValues); >>  C<< $shelp->WriteColumnData($key, @colValues); >>
# Line 740  Line 732 
732      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
733      # Write them to the cache file.      # Write them to the cache file.
734      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
735        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
736  }  }
737    
738  =head3 CloseSession  =head3 CloseSession
# Line 756  Line 749 
749      # Check for an open session file.      # Check for an open session file.
750      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
751          # We found one, so close it.          # We found one, so close it.
752            Trace("Closing session file.") if T(2);
753          close $self->{fileHandle};          close $self->{fileHandle};
754            # Tell the user.
755            my $cgi = $self->Q();
756            $self->PrintLine("Output formatting complete.<br />");
757      }      }
758  }  }
759    
 =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;  
 }  
   
760  =head3 OrganismData  =head3 OrganismData
761    
762  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
# Line 799  Line 773 
773    
774  =item RETURN  =item RETURN
775    
776  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,
777  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
778  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
779    
780  =back  =back
781    
# Line 811  Line 785 
785      # Get the parameters.      # Get the parameters.
786      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
787      # Declare the return variables.      # Declare the return variables.
788      my ($orgName, $group);      my ($orgName, $group, $domain);
789      # Check the cache.      # Check the cache.
790      my $cache = $self->{orgs};      my $cache = $self->{orgs};
791      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
792          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
793      } else {      } else {
794          # Here we have to use the database.          # Here we have to use the database.
795          my $sprout = $self->DB();          my $sprout = $self->DB();
796          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
797                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
798                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
799                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
800          # Null out the supporting group.                                                                   'Genome(taxonomy)']);
801          $group = "" if ($group eq $FIG_Config::otherGroup);          # Format and cache the name and display group.
802          # If the organism does not exist, format an unknown name.          ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
803          if (! defined($genus)) {                                                                $strain, $taxonomy);
             $orgName = "Unknown Genome $genomeID";  
         } else {  
             # 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];  
804      }      }
805      # Return the result.      # Return the result.
806      return ($orgName, $group);      return ($orgName, $group, $domain);
807  }  }
808    
809  =head3 Organism  =head3 Organism
# Line 867  Line 831 
831      # Get the parameters.      # Get the parameters.
832      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
833      # Get the organism data.      # Get the organism data.
834      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]";  
     }  
835      # Return the result.      # Return the result.
836      return $retVal;      return $retVal;
837  }  }
838    
839  =head3 ComputeFASTA  =head3 ComputeFASTA
840    
841  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
842    
843  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
844  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
845    
846  =over 4  =over 4
847    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
848  =item desiredType  =item desiredType
849    
850  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>
851  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.
852    
853  =item sequence  =item sequence
854    
# Line 972  Line 858 
858  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
859  line will be provided.  line will be provided.
860    
861    =item flankingWidth
862    
863    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
864    feature that should be included. Currently we can't do this for Proteins because the
865    protein translation of a feature doesn't always match the DNA and is taken directly
866    from the database.
867    
868  =item RETURN  =item RETURN
869    
870  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 877 
877    
878  sub ComputeFASTA {  sub ComputeFASTA {
879      # Get the parameters.      # Get the parameters.
880      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
881      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
882      my $retVal;      my $retVal;
883        # This variable will be cleared if an error is detected.
884        my $okFlag = 1;
885      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
886      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
887      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
888        # Check for a feature specification. The smoking gun for that is a vertical bar.
889      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
890          # 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
891          # it.          # it.
892          my $fid = $1;          my $fid = $1;
893            Trace("Feature ID for fasta is $fid.") if T(3);
894          my $sprout = $self->DB();          my $sprout = $self->DB();
895          # 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
896          # 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
897          # exist.          # exist.
898          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
899          if (! $figID) {          if (! $figID) {
900              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
901                $okFlag = 0;
902          } else {          } else {
903              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
904              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
905                my $favorLen = length $favored;
906                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
907                if (! $fastaLabel) {
908                    # In an emergency, fall back to the original ID.
909                    $fastaLabel = $fid;
910                }
911              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
912              if ($desiredType =~ /prot/i) {              if ($desiredType =~ /prot/) {
913                  # We want protein, so get the translation.                  # We want protein, so get the translation.
914                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
915              } else {                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
916                  # We want DNA, so get the DNA sequence. This is a two-step process.              } elsif ($desiredType =~ /dna/) {
917                    # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
918                    # locations.
919                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
920                    if ($flankingWidth > 0) {
921                        # Here we need to add flanking data. Convert the locations to a list
922                        # of location objects.
923                        my @locObjects = map { BasicLocation->new($_) } @locList;
924                        # Initialize the return variable. We will put the DNA in here segment by segment.
925                        $fastaData = "";
926                        # Now we widen each location by the flanking width and stash the results. This
927                        # requires getting the contig length for each contig so we don't fall off the end.
928                        for my $locObject (@locObjects) {
929                            Trace("Current location is " . $locObject->String . ".") if T(4);
930                            # Remember the current start and length.
931                            my ($start, $len) = ($locObject->Left, $locObject->Length);
932                            # Get the contig length.
933                            my $contigLen = $sprout->ContigLength($locObject->Contig);
934                            # Widen the location and get its DNA.
935                            $locObject->Widen($flankingWidth, $contigLen);
936                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
937                            # Now we need to do some case changing. The main DNA is upper case and
938                            # the flanking DNA is lower case.
939                            my $leftFlank = $start - $locObject->Left;
940                            my $rightFlank = $leftFlank + $len;
941                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
942                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
943                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
944                                                    lc(substr($fastaSegment, $rightFlank));
945                            $fastaData .= $fancyFastaSegment;
946                        }
947                    } else {
948                        # Here we have just the raw sequence.
949                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
950              }              }
951                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
952                }
953          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
954      } else {      } else {
955            Trace("Analyzing FASTA sequence.") if T(4);
956          # 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.
957          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
958                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
959              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
960              $fastaLabel = $1;              $fastaLabel = $1;
961              $fastaData = $2;              $fastaData = $2;
962          } else {          } else {
963                Trace("No label found in match to sequence:\n$sequence") if T(4);
964              # 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
965              # as data.              # as data.
966              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "$desiredType sequence specified by user";
967              $fastaData = $sequence;              $fastaData = $sequence;
968          }          }
969          # 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.
970            if ($desiredType !~ /pattern/i) {
971          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
972          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
973          # Finally, if the user wants to convert to protein, we do it here. Note that          }
974          # we've already prevented a conversion from protein to DNA.          # Finally, verify that it's DNA if we're doing DNA stuff.
975          if ($incomingType ne $desiredType) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
976              $fastaData = Sprout::Protein($fastaData);              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
977                $okFlag = 0;
978          }          }
979      }      }
980      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
981      # in progress.      # Only proceed if no error was detected.
982      if (defined $fastaLabel) {      if ($okFlag) {
983            if ($desiredType =~ /pattern/i) {
984                # For a scan, there is no label and no breakup.
985                $retVal = $fastaData;
986            } else {
987          # 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
988          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
989          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
990          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
991          # the delimiters are what we want.          # the delimiters are what we want.
992          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
993          my $retVal = join("\n", ">$fastaLabel", @chunks, "");              $retVal = join("\n", ">$fastaLabel", @chunks, "");
994            }
995      }      }
996      # Return the result.      # Return the result.
997      return $retVal;      return $retVal;
998  }  }
999    
1000    =head3 SubsystemTree
1001    
1002    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1003    
1004    This method creates a subsystem selection tree suitable for passing to
1005    L</SelectionTree>. Each leaf node in the tree will have a link to the
1006    subsystem display page. In addition, each node can have a radio button. The
1007    radio button alue is either C<classification=>I<string>, where I<string> is
1008    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1009    Thus, it can either be used to filter by a group of related subsystems or a
1010    single subsystem.
1011    
1012    =over 4
1013    
1014    =item sprout
1015    
1016    Sprout database object used to get the list of subsystems.
1017    
1018    =item options
1019    
1020    Hash containing options for building the tree.
1021    
1022    =item RETURN
1023    
1024    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1025    
1026    =back
1027    
1028    The supported options are as follows.
1029    
1030    =over 4
1031    
1032    =item radio
1033    
1034    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1035    
1036    =item links
1037    
1038    TRUE if the tree should be configured for links. The default is TRUE.
1039    
1040    =back
1041    
1042    =cut
1043    
1044    sub SubsystemTree {
1045        # Get the parameters.
1046        my ($sprout, %options) = @_;
1047        # Process the options.
1048        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1049        # Read in the subsystems.
1050        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1051                                   ['Subsystem(classification)', 'Subsystem(id)']);
1052        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1053        # is at the end, ALL subsystems are unclassified and we don't bother.
1054        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1055            while ($subs[0]->[0] eq '') {
1056                my $classLess = shift @subs;
1057                push @subs, $classLess;
1058            }
1059        }
1060        # Declare the return variable.
1061        my @retVal = ();
1062        # Each element in @subs represents a leaf node, so as we loop through it we will be
1063        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1064        # first element is a semi-colon-delimited list of the classifications for the
1065        # subsystem. There will be a stack of currently-active classifications, which we will
1066        # compare to the incoming classifications from the end backward. A new classification
1067        # requires starting a new branch. A different classification requires closing an old
1068        # branch and starting a new one. Each classification in the stack will also contain
1069        # that classification's current branch. We'll add a fake classification at the
1070        # beginning that we can use to represent the tree as a whole.
1071        my $rootName = '<root>';
1072        # Create the classification stack. Note the stack is a pair of parallel lists,
1073        # one containing names and the other containing content.
1074        my @stackNames = ($rootName);
1075        my @stackContents = (\@retVal);
1076        # Add a null entry at the end of the subsystem list to force an unrolling.
1077        push @subs, ['', undef];
1078        # Loop through the subsystems.
1079        for my $sub (@subs) {
1080            # Pull out the classification list and the subsystem ID.
1081            my ($classString, $id) = @{$sub};
1082            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1083            # Convert the classification string to a list with the root classification in
1084            # the front.
1085            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1086            # Find the leftmost point at which the class list differs from the stack.
1087            my $matchPoint = 0;
1088            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1089                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1090                $matchPoint++;
1091            }
1092            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1093                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1094            # Unroll the stack to the matchpoint.
1095            while ($#stackNames >= $matchPoint) {
1096                my $popped = pop @stackNames;
1097                pop @stackContents;
1098                Trace("\"$popped\" popped from stack.") if T(4);
1099            }
1100            # Start branches for any new classifications.
1101            while ($#stackNames < $#classList) {
1102                # The branch for a new classification contains its radio button
1103                # data and then a list of children. So, at this point, if radio buttons
1104                # are desired, we put them into the content.
1105                my $newLevel = scalar(@stackNames);
1106                my @newClassContent = ();
1107                if ($optionThing->{radio}) {
1108                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1109                    push @newClassContent, { value => "classification=$newClassString%" };
1110                }
1111                # The new classification node is appended to its parent's content
1112                # and then pushed onto the stack. First, we need the node name.
1113                my $nodeName = $classList[$newLevel];
1114                # Add the classification to its parent. This makes it part of the
1115                # tree we'll be returning to the user.
1116                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1117                # Push the classification onto the stack.
1118                push @stackContents, \@newClassContent;
1119                push @stackNames, $nodeName;
1120                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1121            }
1122            # Now the stack contains all our parent branches. We add the subsystem to
1123            # the branch at the top of the stack, but only if it's NOT the dummy node.
1124            if (defined $id) {
1125                # Compute the node name from the ID.
1126                my $nodeName = $id;
1127                $nodeName =~ s/_/ /g;
1128                # Create the node's leaf hash. This depends on the value of the radio
1129                # and link options.
1130                my $nodeContent = {};
1131                if ($optionThing->{links}) {
1132                    # Compute the link value.
1133                    my $linkable = uri_escape($id);
1134                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1135                }
1136                if ($optionThing->{radio}) {
1137                    # Compute the radio value.
1138                    $nodeContent->{value} = "id=$id";
1139                }
1140                # Push the node into its parent branch.
1141                Trace("\"$nodeName\" added to node list.") if T(4);
1142                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1143            }
1144        }
1145        # Return the result.
1146        return \@retVal;
1147    }
1148    
1149    
1150  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1151    
1152  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
# Line 1112  Line 1206 
1206      # Get the form name.      # Get the form name.
1207      my $formName = $self->FormName();      my $formName = $self->FormName();
1208      # Check to see if we already have a genome list in memory.      # Check to see if we already have a genome list in memory.
     my $genomes = $self->{genomeList};  
1209      my $groupHash;      my $groupHash;
1210        my @groups;
1211        my $nmpdrGroupCount;
1212        my $genomes = $self->{genomeList};
1213      if (defined $genomes) {      if (defined $genomes) {
1214          # We have a list ready to use.          # We have a list ready to use.
1215          $groupHash = $genomes;          $groupHash = $genomes;
1216            @groups = @{$self->{groupList}};
1217            $nmpdrGroupCount = $self->{groupCount};
1218      } else {      } else {
1219          # Get a list of all the genomes in group order. In fact, we only need them ordered          # Get a list of all the genomes in group order. In fact, we only need them ordered
1220          # by name (genus,species,strain), but putting primary-group in front enables us to          # by name (genus,species,strain), but putting primary-group in front enables us to
# Line 1125  Line 1223 
1223                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1224                                           [], ['Genome(primary-group)', 'Genome(id)',                                           [], ['Genome(primary-group)', 'Genome(id)',
1225                                                'Genome(genus)', 'Genome(species)',                                                'Genome(genus)', 'Genome(species)',
1226                                                'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1227                                                  'Genome(taxonomy)']);
1228          # Create a hash to organize the genomes by group. Each group will contain a list of          # Create a hash to organize the genomes by group. Each group will contain a list of
1229          # 2-tuples, the first element being the genome ID and the second being the genome          # 2-tuples, the first element being the genome ID and the second being the genome
1230          # name.          # name.
1231          my %gHash = ();          my %gHash = ();
1232          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1233              # Get the genome data.              # Get the genome data.
1234              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1235              # Form the genome name.              # Compute and cache its name and display group.
1236              my $name = "$genus $species";              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1237              if ($strain) {                                                                           $strain, $taxonomy);
1238                  $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1239                # name here, not the display group name.
1240                push @{$gHash{$group}}, [$genomeID, $name, $domain];
1241            }
1242            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1243            # the supporting genomes by domain. First, we sort the NMPDR groups.
1244            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1245            # Remember the number of NMPDR groups.
1246            $nmpdrGroupCount = scalar @groups;
1247            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1248            # of the domains found.
1249            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1250            my @domains = ();
1251            for my $genomeData (@otherGenomes) {
1252                my ($genomeID, $name, $domain) = @{$genomeData};
1253                if (exists $gHash{$domain}) {
1254                    push @{$gHash{$domain}}, $genomeData;
1255                } else {
1256                    $gHash{$domain} = [$genomeData];
1257                    push @domains, $domain;
1258              }              }
             # Push the genome into the group's list.  
             push @{$gHash{$group}}, [$genomeID, $name];  
1259          }          }
1260            # Add the domain groups at the end of the main group list. The main group list will now
1261            # contain all the categories we need to display the genomes.
1262            push @groups, sort @domains;
1263            # Delete the supporting group.
1264            delete $gHash{$FIG_Config::otherGroup};
1265          # Save the genome list for future use.          # Save the genome list for future use.
1266          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1267            $self->{groupList} = \@groups;
1268            $self->{groupCount} = $nmpdrGroupCount;
1269          $groupHash = \%gHash;          $groupHash = \%gHash;
1270      }      }
     # 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;  
1271      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1272      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1273      my %selectedHash = ();      my %selectedHash = ();
1274      if (defined $selected) {      if (defined $selected) {
1275          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1276      }      }
1277      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1278        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1279        # and use that to make the selections.
1280        my $nmpdrCount = 0;
1281      # Create the type counters.      # Create the type counters.
1282      my $groupCount = 1;      my $groupCount = 1;
1283      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 1165  Line 1287 
1287      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1288      my $onChange = "";      my $onChange = "";
1289      if ($cross) {      if ($cross) {
1290            # Here we have a paired menu. Selecting something in our menu unselects it in the
1291            # other and redisplays the status of both.
1292          $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";          $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1293      } elsif ($multiple) {      } elsif ($multiple) {
1294            # This is an unpaired menu, so all we do is redisplay our status.
1295          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1296      }      }
1297      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1298      my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1299      # Loop through the groups.      # Loop through the groups.
1300      for my $group (@groups) {      for my $group (@groups) {
1301          # Create the option group tag.          # Create the option group tag.
1302          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1303          push @lines, "  $tag";          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");  
1304          # Get the genomes in the group.          # Get the genomes in the group.
1305          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1306              my ($genomeID, $name) = @{$genome};              # Count this organism if it's NMPDR.
1307                if ($nmpdrGroupCount > 0) {
1308                    $nmpdrCount++;
1309                }
1310                # Get the organism ID, name, and domain.
1311                my ($genomeID, $name, $domain) = @{$genome};
1312              # See if it's selected.              # See if it's selected.
1313              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1314              # Generate the option tag.              # Generate the option tag.
1315              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1316              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1317          }          }
1318          # Close the option group.          # Close the option group.
1319          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1320            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1321            # groups.
1322            $nmpdrGroupCount--;
1323      }      }
1324      # Close the SELECT tag.      # Close the SELECT tag.
1325      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1326      # Check for multiple selection.      # Check for multiple selection.
1327      if ($multiple) {      if ($multiple) {
1328          # Since multi-select is on, we set up some buttons to set and clear selections.          # Multi-select is on, so we need to add some selection helpers. First is
1329          push @lines, "<br />";          # the search box. This allows the user to type text and have all genomes containing
         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  
1330          # the text selected automatically.          # the text selected automatically.
1331          my $searchThingName = "${menuName}_SearchThing";          my $searchThingName = "${menuName}_SearchThing";
1332          push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .          push @lines, "<br />" .
1333                       "<INPUT type=\"button\" name=\"Select\" class=\"button\" value=\"Search\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";                       "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1334                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />" . Hint("Enter a genome number click the button to the left " .
1335                                                                                                "in order to select the genome with that number. " .
1336                                                                                                "Enter a genus, species, or strain and click the " .
1337                                                                                                "button to select all genomes with that genus, species, " .
1338                                                                                                "or strain name.");
1339            # Next are the buttons to set and clear selections.
1340            push @lines, "<br />";
1341            push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1342            push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1343            push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1344            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1345          # Add the status display, too.          # Add the status display, too.
1346          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1347          # Queue to update the status display when the form loads. We need to modify the show statement          # Queue to update the status display when the form loads. We need to modify the show statement
# Line 1296  Line 1428 
1428  =item rows  =item rows
1429    
1430  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
1431  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
1432  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1433    
1434  =item RETURN  =item RETURN
1435    
# Line 1312  Line 1444 
1444      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1445      # Get the CGI object.      # Get the CGI object.
1446      my $cgi = $self->Q();      my $cgi = $self->Q();
1447      # 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.
1448        # This flag will be set to FALSE when that happens.
1449        my $needWidth = 1;
1450      # 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
1451      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1452      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1453          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1454            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1455                # Here we have a first cell and its tag parameters are in $2.
1456                my $elements = $2;
1457                if ($elements !~ /colspan/i) {
1458                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1459                    # Here there's no colspan, so we plug in the width. We
1460                    # eschew the "g" modifier on the substitution because we
1461                    # only want to update the first cell.
1462                    $row =~ s/(<(td|th))/$1 width="150"/i;
1463                    # Denote we don't need this any more.
1464                    $needWidth = 0;
1465                }
1466            }
1467      }      }
1468      # Create the table.      # Create the table.
1469      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1328  Line 1475 
1475    
1476  =head3 SubmitRow  =head3 SubmitRow
1477    
1478  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1479    
1480  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1481  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1482  near the top of the form.  near the top of the form.
1483    
 =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.  
   
1484  =over 4  =over 4
1485    
1486  =item sprout  =item caption (optional)
   
 Sprout object for accessing the database.  
   
 =item feat  
1487    
1488  ID of the feature whose Gbrowse URL is desired.  Caption to be put on the search button. The default is C<Go>.
1489    
1490  =item RETURN  =item RETURN
1491    
1492  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
1493  ID, contig ID, starting offset, and stopping offset.  and tuning the results.
1494    
1495  =back  =back
1496    
1497  =cut  =cut
1498    
1499  sub GBrowseFeatureURL {  sub SubmitRow {
1500      # Get the parameters.      # Get the parameters.
1501      my ($sprout, $feat) = @_;      my ($self, $caption) = @_;
1502      # Declare the return variable.      my $cgi = $self->Q();
1503      my $retVal;      # Compute the button caption.
1504      # Compute the genome ID.      my $realCaption = (defined $caption ? $caption : 'Go');
1505      my ($genomeID) = FIGRules::ParseFeatureID($feat);      # Get the current page size.
1506      # Only proceed if the feature ID produces a valid genome.      my $pageSize = $cgi->param('PageSize');
1507      if ($genomeID) {      # Get the current feature ID type.
1508          # Get the feature location string.      my $aliasType = $self->GetPreferredAliasType();
1509          my $loc = $sprout->FeatureLocation($feat);      # Create the rows.
1510          # Compute the contig, start, and stop points.      my $retVal = $cgi->Tr($cgi->td("ID Type"), $cgi->td({ colspan => 2 },
1511          my($contig, $start, $stop) = BasicLocation::Parse($loc);                                                          $cgi->popup_menu(-name => 'AliasType',
1512          Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);                                                                           -values => ['FIG', AliasAnalysis::AliasTypes() ],
1513          # Now we need to do some goofiness to insure that the location is not too                                                                           -default => $aliasType) .
1514          # big and that we get some surrounding stuff.                                                          Hint("Specify how you want gene names to be displayed."))) .
1515          my $mid = int(($start + $stop) / 2);                   "\n" .
1516          my $chunk_len = 20000;                   $cgi->Tr($cgi->td("Results/Page"),
1517          my $max_feature = 40000;                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1518          my $feat_len = abs($stop - $start);                                                      -values => [10, 25, 50, 100, 1000],
1519          if ($feat_len > $chunk_len) {                                                      -default => $pageSize)),
1520              if ($feat_len > $max_feature) {                            $cgi->td($cgi->submit(-class => 'goButton',
1521                  $chunk_len = $max_feature;                                                  -name => 'Search',
1522              } else {                                                  -value => $realCaption)));
                 $chunk_len = $feat_len + 100;  
             }  
         }  
         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";  
     }  
1523      # Return the result.      # Return the result.
1524      return $retVal;      return $retVal;
1525  }  }
# Line 1541  Line 1611 
1611    
1612  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1613    
1614  C<< my $url = $shelp->ComputeSearchURL(); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1615    
1616  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
1617  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 1621 
1621  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
1622  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1623    
1624    =over 4
1625    
1626    =item overrides
1627    
1628    Hash containing override values for the parameters, where the parameter name is
1629    the key and the parameter value is the override value. If the override value is
1630    C<undef>, the parameter will be deleted from the result.
1631    
1632    =item RETURN
1633    
1634    Returns a GET-style URL for invoking the search with the specified overrides.
1635    
1636    =back
1637    
1638  =cut  =cut
1639    
1640  sub ComputeSearchURL {  sub ComputeSearchURL {
1641      # Get the parameters.      # Get the parameters.
1642      my ($self) = @_;      my ($self, %overrides) = @_;
1643      # Get the database and CGI query object.      # Get the database and CGI query object.
1644      my $cgi = $self->Q();      my $cgi = $self->Q();
1645      my $sprout = $self->DB();      my $sprout = $self->DB();
# Line 1582  Line 1666 
1666          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1667          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1668          # Check for special cases.          # Check for special cases.
1669          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)) {  
1670              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1671              @values = ();              @values = ();
1672          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1610  Line 1680 
1680              if ($allFlag) {              if ($allFlag) {
1681                  @values = ();                  @values = ();
1682              }              }
1683            } elsif (exists $overrides{$parmKey}) {
1684                # Here the value is being overridden, so we skip it for now.
1685                @values = ();
1686          }          }
1687          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1688          if (@values) {          if (@values) {
1689              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1690          }          }
1691      }      }
1692        # Now do the overrides.
1693        for my $overKey (keys %overrides) {
1694            # Only use this override if it's not a delete marker.
1695            if (defined $overrides{$overKey}) {
1696                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1697            }
1698        }
1699      # Add the parameters to the URL.      # Add the parameters to the URL.
1700      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1701      # Return the result.      # Return the result.
1702      return $retVal;      return $retVal;
1703  }  }
1704    
1705  =head3 GetRunTimeValue  =head3 AdvancedClassList
1706    
1707    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1708    
1709    Return a list of advanced class names. This list is used to generate the directory
1710    of available searches on the search page.
1711    
1712    We do a file search to accomplish this, but to pull it off we need to look at %INC.
1713    
1714    =cut
1715    
1716    sub AdvancedClassList {
1717        # Determine the search helper module directory.
1718        my $libDirectory = $INC{'SearchHelper.pm'};
1719        $libDirectory =~ s/SearchHelper\.pm//;
1720        # Read it, keeping only the helper modules.
1721        my @modules = grep { /^SH\w+\.pm/ } Tracer::OpenDir($libDirectory, 0);
1722        # Convert the file names to search types.
1723        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } @modules;
1724        # Return the result in alphabetical order.
1725        return sort @retVal;
1726    }
1727    
1728    =head3 SelectionTree
1729    
1730    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1731    
1732    Display a selection tree.
1733    
1734  C<< my $htmlText = $shelp->GetRunTimeValue($text); >>  This method creates the HTML for a tree selection control. The tree is implemented as a set of
1735    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1736    addition, some of the tree nodes can contain hyperlinks.
1737    
1738  Compute a run-time column value.  The tree itself is passed in as a multi-level list containing node names followed by
1739    contents. Each content element is a reference to a similar list. The first element of
1740    each list may be a hash reference. If so, it should contain one or both of the following
1741    keys.
1742    
1743  =over 4  =over 4
1744    
1745  =item text  =item link
1746    
1747    The navigation URL to be popped up if the user clicks on the node name.
1748    
1749    =item value
1750    
1751    The form value to be returned if the user selects the tree node.
1752    
1753    =back
1754    
1755    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1756    a C<value> key indicates the node name will have a radio button. If a node has no children,
1757    you may pass it a hash reference instead of a list reference.
1758    
1759    The following example shows the hash for a three-level tree with links on the second level and
1760    radio buttons on the third.
1761    
1762        [   Objects => [
1763                Entities => [
1764                    {link => "../docs/WhatIsAnEntity.html"},
1765                    Genome => {value => 'GenomeData'},
1766                    Feature => {value => 'FeatureData'},
1767                    Contig => {value => 'ContigData'},
1768                ],
1769                Relationships => [
1770                    {link => "../docs/WhatIsARelationShip.html"},
1771                    HasFeature => {value => 'GenomeToFeature'},
1772                    IsOnContig => {value => 'FeatureToContig'},
1773                ]
1774            ]
1775        ]
1776    
1777    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1778    all have list references.
1779    
1780    This next example shows how to set up a taxonomy selection field. The value returned
1781    by the tree control will be the taxonomy string for the selected node ready for use
1782    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1783    reasons of space.
1784    
1785        [   All => [
1786                {value => "%"},
1787                Bacteria => [
1788                    {value => "Bacteria%"},
1789                    Proteobacteria => [
1790                        {value => "Bacteria; Proteobacteria%"},
1791                        Epsilonproteobacteria => [
1792                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1793                            Campylobacterales => [
1794                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1795                                Campylobacteraceae =>
1796                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1797                                ...
1798                            ]
1799                            ...
1800                        ]
1801                        ...
1802                    ]
1803                    ...
1804                ]
1805                ...
1806            ]
1807        ]
1808    
1809    
1810    This method of tree storage allows the caller to control the order in which the tree nodes
1811    are displayed and to completely control value selection and use of hyperlinks. It is, however
1812    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1813    
1814    The parameters to this method are as follows.
1815    
1816    =over 4
1817    
1818    =item cgi
1819    
1820    CGI object used to generate the HTML.
1821    
1822    =item tree
1823    
1824    Reference to a hash describing a tree. See the description above.
1825    
1826    =item options
1827    
1828    Hash containing options for the tree display.
1829    
1830    =back
1831    
1832    The allowable options are as follows
1833    
1834    =over 4
1835    
1836    =item nodeImageClosed
1837    
1838    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1839    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1840    
1841    =item nodeImageOpen
1842    
1843    URL of the image to display next to the tree nodes when they are expanded. Clicking
1844    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1845    
1846  The run-time column text. It consists of 2 percent signs, a column type, an equal  =item style
1847  sign, and the data for the current row.  
1848    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1849    as nested lists, the key components of this style are the definitions for the C<ul> and
1850    C<li> tags. The default style file contains the following definitions.
1851    
1852        .tree ul {
1853           margin-left: 0; padding-left: 22px
1854        }
1855        .tree li {
1856            list-style-type: none;
1857        }
1858    
1859    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1860    parent by the width of the node image. This use of styles limits the things we can do in formatting
1861    the tree, but it has the advantage of vastly simplifying the tree creation.
1862    
1863    =item name
1864    
1865    Field name to give to the radio buttons in the tree. The default is C<selection>.
1866    
1867    =item target
1868    
1869    Frame target for links. The default is C<_self>.
1870    
1871    =item selected
1872    
1873    If specified, the value of the radio button to be pre-selected.
1874    
1875    =back
1876    
1877    =cut
1878    
1879    sub SelectionTree {
1880        # Get the parameters.
1881        my ($cgi, $tree, %options) = @_;
1882        # Get the options.
1883        my $optionThing = Tracer::GetOptions({ name => 'selection',
1884                                               nodeImageClosed => '../FIG/Html/plus.gif',
1885                                               nodeImageOpen => '../FIG/Html/minus.gif',
1886                                               style => 'tree',
1887                                               target => '_self',
1888                                               selected => undef},
1889                                             \%options);
1890        # Declare the return variable. We'll do the standard thing with creating a list
1891        # of HTML lines and rolling them together at the end.
1892        my @retVal = ();
1893        # Only proceed if the tree is present.
1894        if (defined($tree)) {
1895            # Validate the tree.
1896            if (ref $tree ne 'ARRAY') {
1897                Confess("Selection tree is not a list reference.");
1898            } elsif (scalar @{$tree} == 0) {
1899                # The tree is empty, so we do nothing.
1900            } elsif ($tree->[0] eq 'HASH') {
1901                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
1902            } else {
1903                # Here we have a real tree. Apply the tree style.
1904                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
1905                # Give us a DIV ID.
1906                my $divID = GetDivID($optionThing->{name});
1907                # Show the tree.
1908                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
1909                # Close the DIV block.
1910                push @retVal, $cgi->end_div();
1911            }
1912        }
1913        # Return the result.
1914        return join("\n", @retVal, "");
1915    }
1916    
1917    =head3 ShowBranch
1918    
1919    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
1920    
1921    This is a recursive method that displays a branch of the tree.
1922    
1923    =over 4
1924    
1925    =item cgi
1926    
1927    CGI object used to format HTML.
1928    
1929    =item label
1930    
1931    Label of this tree branch. It is only used in error messages.
1932    
1933    =item id
1934    
1935    ID to be given to this tree branch. The ID is used in the code that expands and collapses
1936    tree nodes.
1937    
1938    =item branch
1939    
1940    Reference to a list containing the content of the tree branch. The list contains an optional
1941    hash reference that is ignored and the list of children, each child represented by a name
1942    and then its contents. The contents could by a hash reference (indicating the attributes
1943    of a leaf node), or another tree branch.
1944    
1945    =item options
1946    
1947    Options from the original call to L</SelectionTree>.
1948    
1949    =item displayType
1950    
1951    C<block> if the contents of this list are to be displayed, C<none> if they are to be
1952    hidden.
1953    
1954  =item RETURN  =item RETURN
1955    
1956  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.
1957    
1958  =back  =back
1959    
1960  =cut  =cut
1961    
1962  sub GetRunTimeValue {  sub ShowBranch {
1963      # Get the parameters.      # Get the parameters.
1964      my ($self, $text) = @_;      my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
1965      # Declare the return variable.      # Declare the return variable.
1966      my $retVal;      my @retVal = ();
1967      # Parse the incoming text.      # Start the branch.
1968      if ($text =~ /^%%([^=]+)=(.*)$/) {      push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
1969          $retVal = $self->RunTimeColumns($1, $2);      # Check for the hash and choose the start location accordingly.
1970        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
1971        # Get the list length.
1972        my $i1 = scalar(@{$branch});
1973        # Verify we have an even number of elements.
1974        if (($i1 - $i0) % 2 != 0) {
1975            Trace("Branch elements are from $i0 to $i1.") if T(3);
1976            Confess("Odd number of elements in tree branch $label.");
1977        } else {
1978            # Loop through the elements.
1979            for (my $i = $i0; $i < $i1; $i += 2) {
1980                # Get this node's label and contents.
1981                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
1982                # Get an ID for this node's children (if any).
1983                my $myID = GetDivID($options->{name});
1984                # Now we need to find the list of children and the options hash.
1985                # This is a bit ugly because we allow the shortcut of a hash without an
1986                # enclosing list. First, we need some variables.
1987                my $attrHash = {};
1988                my @childHtml = ();
1989                my $hasChildren = 0;
1990                if (! ref $myContent) {
1991                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
1992                } elsif (ref $myContent eq 'HASH') {
1993                    # Here the node is a leaf and its content contains the link/value hash.
1994                    $attrHash = $myContent;
1995                } elsif (ref $myContent eq 'ARRAY') {
1996                    # Here the node may be a branch. Its content is a list.
1997                    my $len = scalar @{$myContent};
1998                    if ($len >= 1) {
1999                        # Here the first element of the list could by the link/value hash.
2000                        if (ref $myContent->[0] eq 'HASH') {
2001                            $attrHash = $myContent->[0];
2002                            # If there's data in the list besides the hash, it's our child list.
2003                            # We can pass the entire thing as the child list, because the hash
2004                            # is ignored.
2005                            if ($len > 1) {
2006                                $hasChildren = 1;
2007                            }
2008      } else {      } else {
2009          Confess("Invalid run-time column string \"$text\" encountered in session file.");                          $hasChildren = 1;
2010                        }
2011                        # If we have children, create the child list with a recursive call.
2012                        if ($hasChildren) {
2013                            Trace("Processing children of $myLabel.") if T(4);
2014                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2015                            Trace("Children of $myLabel finished.") if T(4);
2016                        }
2017                    }
2018      }      }
2019                # Okay, it's time to pause and take stock. We have the label of the current node
2020                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2021                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2022                # Compute the image HTML. It's tricky, because we have to deal with the open and
2023                # closed images.
2024                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2025                my $image = $images[$hasChildren];
2026                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2027                if ($hasChildren) {
2028                    # If there are children, we wrap the image in a toggle hyperlink.
2029                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2030                                          $prefixHtml);
2031                }
2032                # Now the radio button, if any. Note we use "defined" in case the user wants the
2033                # value to be 0.
2034                if (defined $attrHash->{value}) {
2035                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2036                    # hash for the "input" method. If the item is pre-selected, we add
2037                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2038                    # at all.
2039                    my $radioParms = { type => 'radio',
2040                                       name => $options->{name},
2041                                       value => $attrHash->{value},
2042                                     };
2043                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2044                        $radioParms->{checked} = undef;
2045                    }
2046                    $prefixHtml .= $cgi->input($radioParms);
2047                }
2048                # Next, we format the label.
2049                my $labelHtml = $myLabel;
2050                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2051                # Apply a hyperlink if necessary.
2052                if (defined $attrHash->{link}) {
2053                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2054                                         $labelHtml);
2055                }
2056                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2057                # here.
2058                my $childHtml = join("\n", @childHtml);
2059                # Now we have all the pieces, so we can put them together.
2060                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2061            }
2062        }
2063        # Close the tree branch.
2064        push @retVal, $cgi->end_ul();
2065      # Return the result.      # Return the result.
2066      return $retVal;      return @retVal;
2067  }  }
2068    
2069  =head2 Feature Column Methods  =head3 GetDivID
2070    
2071  The methods in this column manage feature column data. If you want to provide the  C<< 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.  
2072    
2073  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.  
2074    
2075  =head3 DefaultFeatureColumns  =over 4
2076    
2077  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  =item name
2078    
2079    Name to be prefixed to the ID string.
2080    
2081    =item RETURN
2082    
2083  Return a reference to a list of the default feature column identifiers. These  Returns a hopefully-unique ID string.
2084  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
2085  order to produce the column titles and row values.  =back
2086    
2087  =cut  =cut
2088    
2089  sub DefaultFeatureColumns {  sub GetDivID {
2090      # Get the parameters.      # Get the parameters.
2091      my ($self) = @_;      my ($name) = @_;
2092        # Compute the ID.
2093        my $retVal = "elt_$name$divCount";
2094        # Increment the counter to make sure this ID is not re-used.
2095        $divCount++;
2096      # Return the result.      # Return the result.
2097      return ['orgName', 'function', 'gblink', 'protlink',      return $retVal;
             FeatureQuery::AdditionalColumns($self)];  
2098  }  }
2099    
2100  =head3 FeatureColumnTitle  =head3 PrintLine
2101    
2102  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< $shelp->PrintLine($message); >>
2103    
2104  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
2105    searching, so the user sees progress in real-time.
2106    
2107  =over 4  =over 4
2108    
2109  =item name  =item message
2110    
2111    HTML text to display.
2112    
2113    =back
2114    
2115    =cut
2116    
2117    sub PrintLine {
2118        # Get the parameters.
2119        my ($self, $message) = @_;
2120        # Send them to the output.
2121        print "$message\n";
2122    }
2123    
2124    =head3 GetHelper
2125    
2126    C<< my $shelp = SearchHelper::GetHelper($parm, $type => $className); >>
2127    
2128    Return a helper object with the given class name. If no such class exists, an
2129    error will be thrown.
2130    
2131    =over 4
2132    
2133  Name of the desired feature column.  =item parm
2134    
2135    Parameter to pass to the constructor. This is a CGI object for a search helper
2136    and a search helper object for the result helper.
2137    
2138    =item type
2139    
2140    Type of helper: C<RH> for a result helper and C<SH> for a search helper.
2141    
2142    =item className
2143    
2144    Class name for the helper object, without the preceding C<SH> or C<RH>. This is
2145    identical to what the script expects for the C<Class> or C<ResultType> parameter.
2146    
2147  =item RETURN  =item RETURN
2148    
2149  Returns the title to be used as the column header for the named feature column.  Returns a helper object for the specified class.
2150    
2151  =back  =back
2152    
2153  =cut  =cut
2154    
2155  sub FeatureColumnTitle {  sub GetHelper {
2156      # Get the parameters.      # Get the parameters.
2157      my ($self, $colName) = @_;      my ($parm, $type, $className) = @_;
2158      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
2159      my $retVal = "&nbsp;";      my $retVal;
2160      # Process the column name.      # Try to create the helper.
2161      if ($colName =~ /^X=(.+)$/) {      eval {
2162          # Here we have an extra column.          # Load it into memory. If it's already there nothing will happen here.
2163          $retVal = $1;          my $realName = "$type$className";
2164      } elsif ($colName eq 'orgName') {          Trace("Requiring helper $realName.") if T(3);
2165          $retVal = "Name";          require "$realName.pm";
2166      } elsif ($colName eq 'fid') {          Trace("Constructing helper object.") if T(3);
2167          $retVal = "FIG ID";          # Construct the object.
2168      } elsif ($colName eq 'alias') {          $retVal = eval("$realName->new(\$parm)");
2169          $retVal = "External Aliases";          # Commit suicide if it didn't work.
2170      } elsif ($colName eq 'function') {          if (! defined $retVal) {
2171          $retVal = "Functional Assignment";              die "Could not find a $type handler of type $className.";
2172      } elsif ($colName eq 'gblink') {          }
2173          $retVal = "GBrowse";      };
2174      } elsif ($colName eq 'protlink') {      # Check for errors.
2175          $retVal = "NMPDR Protein Page";      if ($@) {
2176      } elsif ($colName eq 'group') {          Confess("Error retrieving $type$className: $@");
         $retVal = "NMDPR Group";  
2177      }      }
2178      # Return the result.      # Return the result.
2179      return $retVal;      return $retVal;
2180  }  }
2181    
2182  =head3 FeatureColumnValue  =head3 SaveOrganismData
2183    
2184  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2185    
2186  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
2187    data should be the relevant fields from the B<Genome> record in the database. The
2188    data will also be stored in the genome cache for later use in posting search results.
2189    
2190  =over 4  =over 4
2191    
2192  =item colName  =item group
2193    
2194    Name of the genome's group as it appears in the database.
2195    
2196    =item genomeID
2197    
2198    ID of the relevant genome.
2199    
2200    =item genus
2201    
2202  Name of the column to be displayed.  Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2203    in the database. In this case, the organism name is derived from the genomeID and the group
2204    is automatically the supporting-genomes group.
2205    
2206  =item record  =item species
2207    
2208  DBObject record for the feature being displayed in the current row.  Species of the genome's organism.
2209    
2210  =item extraCols  =item strain
2211    
2212  Reference to a hash of extra column names to values. If the incoming column name  Strain of the species represented by the genome.
2213  begins with C<X=>, its value will be taken from this hash.  
2214    =item taxonomy
2215    
2216    Taxonomy of the species represented by the genome.
2217    
2218  =item RETURN  =item RETURN
2219    
2220  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
2221    element is the display name of the genome's group. The third is the genome's domain.
2222    
2223  =back  =back
2224    
2225  =cut  =cut
2226    
2227  sub FeatureColumnValue {  sub SaveOrganismData {
2228      # Get the parameters.      # Get the parameters.
2229      my ($self, $colName, $record, $extraCols) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2230      # Get the sprout and CGI objects.      # Declare the return values.
2231      my $cgi = $self->Q();      my ($name, $displayGroup);
2232      my $sprout = $self->DB();      # If the organism does not exist, format an unknown name and a blank group.
2233      # Get the feature ID.      if (! defined($genus)) {
2234      my ($fid) = $record->Value('Feature(id)');          $name = "Unknown Genome $genomeID";
2235      # Declare the return variable. Denote that we default to a non-breaking space,          $displayGroup = "";
2236      # which will translate to an empty table cell (rather than a table cell with no      } else {
2237      # interior, which is what you get for a null string).          # It does exist, so format the organism name.
2238      my $retVal = "&nbsp;";          $name = "$genus $species";
2239      # Process according to the column name.          if ($strain) {
2240      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);  
2241      }      }
2242            # Compute the display group. This is currently the same as the incoming group
2243            # name unless it's the supporting group, which is nulled out.
2244            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2245        }
2246        # Compute the domain from the taxonomy.
2247        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2248        # Cache the group and organism data.
2249        my $cache = $self->{orgs};
2250        $cache->{$genomeID} = [$name, $displayGroup, $domain];
2251      # Return the result.      # Return the result.
2252      return $retVal;      return ($name, $displayGroup, $domain);
2253  }  }
2254    
2255  =head3 RunTimeColumns  =head3 ValidateKeywords
2256    
2257  C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>  C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2258    
2259  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
2260  list is displayed, rather than when it is generated.  set.
2261    
2262  =over 4  =over 4
2263    
2264  =item type  =item keywordString
2265    
2266  Type of column.  Keyword string specified as a parameter to the current search.
2267    
2268  =item text  =item required
2269    
2270  Data relevant to this row of the column.  TRUE if there must be at least one keyword specified, else FALSE.
2271    
2272  =item RETURN  =item RETURN
2273    
2274  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
2275    is acceptable if the I<$required> parameter is not specified.
2276    
2277  =back  =back
2278    
2279  =cut  =cut
2280    
2281  sub RunTimeColumns {  sub ValidateKeywords {
2282      # Get the parameters.      # Get the parameters.
2283      my ($self, $type, $text) = @_;      my ($self, $keywordString, $required) = @_;
2284      # Declare the return variable.      # Declare the return variable.
2285      my $retVal = "";      my $retVal = 0;
2286      # Get the Sprout and CGI objects.      my @wordList = split /\s+/, $keywordString;
2287      my $sprout = $self->DB();      # Right now our only real worry is a list of all minus words. The problem with it is that
2288        # it will return an incorrect result.
2289        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2290        if (! @wordList) {
2291            if ($required) {
2292                $self->SetMessage("No search words specified.");
2293            } else {
2294                $retVal = 1;
2295            }
2296        } elsif (! @plusWords) {
2297            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2298        } else {
2299            $retVal = 1;
2300        }
2301        # Return the result.
2302        return $retVal;
2303    }
2304    
2305    =head3 TuningParameters
2306    
2307    C<< my $options = $shelp->TuningParameters(%parmHash); >>
2308    
2309    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2310    to their default values. The parameters and their values will be returned as a hash reference.
2311    
2312    =over 4
2313    
2314    =item parmHash
2315    
2316    Hash mapping parameter names to their default values.
2317    
2318    =item RETURN
2319    
2320    Returns a reference to a hash containing the parameter names mapped to their actual values.
2321    
2322    =back
2323    
2324    =cut
2325    
2326    sub TuningParameters {
2327        # Get the parameters.
2328        my ($self, %parmHash) = @_;
2329        # Declare the return variable.
2330        my $retVal = {};
2331        # Get the CGI Query Object.
2332      my $cgi = $self->Q();      my $cgi = $self->Q();
2333      # Separate the text into a type and data.      # Loop through the parameter names.
2334      if ($type eq 'aliases') {      for my $parm (keys %parmHash) {
2335          # Here the caller wants external alias links for a feature. The text          # Get the incoming value for this parameter.
2336          # is the feature ID.          my $value = $cgi->param($parm);
2337          my $fid = $text;          # Zero might be a valid value, so we do an is-defined check rather than an OR.
2338          # The complicated part is we have to hyperlink them. First, get the          if (defined($value)) {
2339          # aliases.              $retVal->{$parm} = $value;
2340          Trace("Generating aliases for feature $fid.") if T(4);          } else {
2341          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);  
2342          }          }
2343      }      }
2344      # Return the result.      # Return the result.
2345      return $retVal;      return $retVal;
2346  }  }
2347    
2348    =head3 GetPreferredAliasType
2349    
2350    C<< my $type = $shelp->GetPreferredAliasType(); >>
2351    
2352    Return the preferred alias type for the current session. This information is stored
2353    in the C<AliasType> parameter of the CGI query object, and the default is C<FIG>
2354    (which indicates the FIG ID).
2355    
2356    =cut
2357    
2358    sub GetPreferredAliasType {
2359        # Get the parameters.
2360        my ($self) = @_;
2361        # Determine the preferred type.
2362        my $cgi = $self->Q();
2363        my $retVal = $cgi->param('AliasType') || 'FIG';
2364        # Return it.
2365        return $retVal;
2366    }
2367    
2368  =head2 Virtual Methods  =head2 Virtual Methods
2369    
2370  =head3 Form  =head3 Form
# Line 1902  Line 2382 
2382  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
2383  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.
2384    
2385    =cut
2386    
2387    sub Find {
2388        # Get the parameters.
2389        my ($self) = @_;
2390        $self->Message("Call to pure virtual Find method in helper of type " . ref($self) . ".");
2391        return undef;
2392    }
2393    
2394  =head3 Description  =head3 Description
2395    
2396  C<< my $htmlText = $shelp->Description(); >>  C<< my $htmlText = $shelp->Description(); >>
# Line 1910  Line 2399 
2399  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,
2400  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.
2401    
2402  =head3 SortKey  =cut
2403    
2404    sub Description {
2405        # Get the parameters.
2406        my ($self) = @_;
2407        $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2408        return "Unknown search type";
2409    }
2410    
2411    =head3 SearchTitle
2412    
2413    C<< my $titleHtml = $shelp->SearchTitle(); >>
2414    
2415    Return the display title for this search. The display title appears above the search results.
2416    If no result is returned, no title will be displayed. The result should be an html string
2417    that can be legally put inside a block tag such as C<h3> or C<p>.
2418    
2419    =cut
2420    
2421    sub SearchTitle {
2422        # Get the parameters.
2423        my ($self) = @_;
2424        # Declare the return variable.
2425        my $retVal = "";
2426        # Return it.
2427        return $retVal;
2428    }
2429    
2430    =head3 DefaultColumns
2431    
2432  C<< my $key = $shelp->SortKey($record); >>  C<< $shelp->DefaultColumns($rhelp); >>
2433    
2434  Return the sort key for the specified record. The default is to sort by feature name,  Store the default columns in the result helper. The default action is just to ask
2435  floating NMPDR organisms to the top. This sort may be overridden by the search class  the result helper for its default columns, but this may be changed by overriding
2436  to provide fancier functionality. This method is called by B<PutFeature>, so it  this method.
 is only used for feature searches. A non-feature search would presumably have its  
 own sort logic.  
2437    
2438  =over 4  =over 4
2439    
2440  =item record  =item rhelp
2441    
2442  The C<DBObject> from which the current row of data is derived.  Result helper object in which the column list should be stored.
2443    
2444    =back
2445    
2446    =cut
2447    
2448    sub DefaultColumns {
2449        # Get the parameters.
2450        my ($self, $rhelp) = @_;
2451        # Get the default columns from the result helper.
2452        my @cols = $rhelp->DefaultResultColumns();
2453        # Store them back.
2454        $rhelp->SetColumns(@cols);
2455    }
2456    
2457    =head3 Hint
2458    
2459    C<< my $htmlText = SearchHelper::Hint($hintText); >>
2460    
2461    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
2462    This HTML can be put in forms to provide a useful hinting mechanism.
2463    
2464    =over 4
2465    
2466    =item hintText
2467    
2468    Text to display for the hint. It is raw html, but may not contain any double quotes.
2469    
2470  =item RETURN  =item RETURN
2471    
2472  Returns a key field that can be used to sort this row in among the results.  Returns the html for the hint facility. The resulting html shows a small button-like thing that
2473    uses the standard FIG popup technology.
2474    
2475  =back  =back
2476    
2477  =cut  =cut
2478    
2479  sub SortKey {  sub Hint {
2480      # Get the parameters.      # Get the parameters.
2481      my ($self, $record) = @_;      my ($hintText) = @_;
2482      # Get the feature ID from the record.      # Escape the single quotes.
2483      my ($fid) = $record->Value('Feature(id)');      my $quotedText = $hintText;
2484      # Get the group from the feature ID.      $quotedText =~ s/'/\\'/g;
2485      my $group = $self->FeatureGroup($fid);      # Create the html.
2486      # Ask the feature query object to form the sort key.      my $retVal = "&nbsp;<input type=\"button\" class=\"hintbutton\" onMouseOver=\"javascript:if (!this.tooltip) { " .
2487      my $retVal = FeatureQuery::SortKey($self, $group, $record);                   "this.tooltip = new Popup_Tooltip(this, 'Search Hint', '$quotedText', '', 1); this.tooltip.addHandler(); } " .
2488      # Return the result.                   "return false;\" value=\"?\" />";
2489        # Return it.
2490      return $retVal;      return $retVal;
2491  }  }
2492    
2493    
2494  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3