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

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.36

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3