[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.1, Tue Sep 26 13:46:03 2006 UTC revision 1.30, Thu Apr 19 00:05:51 2007 UTC
# Line 16  Line 16 
16      use FIGRules;      use FIGRules;
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
19        use FeatureQuery;
20        use URI::Escape;
21        use PageBuilder;
22    
23  =head1 Search Helper Base Class  =head1 Search Helper Base Class
24    
# Line 72  Line 75 
75    
76  List of JavaScript statements to be executed after the form is closed.  List of JavaScript statements to be executed after the form is closed.
77    
78    =item genomeHash
79    
80    Cache of the genome group hash used to build genome selection controls.
81    
82    =item genomeParms
83    
84    List of the parameters that are used to select multiple genomes.
85    
86    =item filtered
87    
88    TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89    field is updated by the B<FeatureQuery> object.
90    
91    =item extraPos
92    
93    Hash indicating which extra columns should be put at the end. Extra columns
94    not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
95    method to change this option.
96    
97    =back
98    
99    =head2 Adding a new Search Tool
100    
101    To add a new search tool to the system, you must
102    
103    =over 4
104    
105    =item 1
106    
107    Choose a class name for your search tool.
108    
109    =item 2
110    
111    Create a new subclass of this object and implement each of the virtual methods. The
112    name of the subclass must be C<SH>I<className>.
113    
114    =item 3
115    
116    Create an include file among the web server pages that describes how to use
117    the search tool. The include file must be in the B<includes> directory, and
118    its name must be C<SearchHelp_>I<className>C<.inc>.
119    
120    =item 4
121    
122    In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
123    
124    =back
125    
126    =head3 Building a Search Form
127    
128    All search forms are three-column tables. In general, you want one form
129    variable per table row. The first column should contain the label and
130    the second should contain the form control for specifying the variable
131    value. If the control is wide, you should use C<colspan="2"> to give it
132    extra room. B<Do not> specify a width in any of your table cells, as
133    width management is handled by this class.
134    
135    The general code for creating the form should be
136    
137        sub Form {
138            my ($self) = @_;
139            # Get the CGI object.
140            my $cgi = @self->Q();
141            # Start the form.
142            my $retVal = $self->FormStart("form title");
143            # Assemble the table rows.
144            my @rows = ();
145            ... push table row Html into @rows ...
146            push @rows, $self->SubmitRow();
147            ... push more Html into @rows ...
148            # Build the table from the rows.
149            $retVal .= $self->MakeTable(\@rows);
150            # Close the form.
151            $retVal .= $self->FormEnd();
152            # Return the form Html.
153            return $retVal;
154        }
155    
156    Several helper methods are provided for particular purposes.
157    
158    =over 4
159    
160    =item 1
161    
162    L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
163    L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
164    name. Note that as an assist to people working with GET-style links, if no
165    genomes are specified and the incoming request style is GET, all genomes will
166    be returned.
167    
168    =item 2
169    
170    L</FeatureFilterRow> formats several rows of controls for filtering features.
171    When you start building the code for the L</Find> method, you can use a
172    B<FeatureQuery> object to automatically filter each genome's features using
173    the values from the filter controls.
174    
175    =item 3
176    
177    L</QueueFormScript> allows you to queue JavaScript statements for execution
178    after the form is fully generated. If you are using very complicated
179    form controls, the L</QueueFormScript> method allows you to perform
180    JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
181    facility to display a list of the pre-selected genomes.
182    
183  =back  =back
184    
185    If you are doing a feature search, you can also change the list of feature
186    columns displayed and their display order by overriding
187    L</DefaultFeatureColumns>.
188    
189    Finally, when generating the code for your controls, be sure to use any incoming
190    query parameters as default values so that the search request is persistent.
191    
192    =head3 Finding Search Results
193    
194    The L</Find> method is used to create the search results. For a search that
195    wants to return features (which is most of them), the basic code structure
196    would work as follows. It is assumed that the L</FeatureFilterRows> method
197    has been used to create feature filtering parameters.
198    
199        sub Find {
200            my ($self) = @_;
201            # Get the CGI and Sprout objects.
202            my $cgi = $self->Q();
203            my $sprout = $self->DB();
204            # Declare the return variable. If it remains undefined, the caller will
205            # know that an error occurred.
206            my $retVal;
207            ... validate the parameters ...
208            if (... invalid parameters...) {
209                $self->SetMessage(...appropriate message...);
210            } elsif (FeatureQuery::Valid($self)) {
211                # Initialize the session file.
212                $self->OpenSession();
213                # Initialize the result counter.
214                $retVal = 0;
215                ... get a list of genomes ...
216                for my $genomeID (... each genome ...) {
217                    my $fq = FeatureQuery->new($self, $genomeID);
218                    while (my $feature = $fq->Fetch()) {
219                        ... examine the feature ...
220                        if (... we want to keep it ...) {
221                            $self->PutFeature($fq);
222                            $retVal++;
223                        }
224                    }
225                }
226                # Close the session file.
227                $self->CloseSession();
228            }
229            # Return the result count.
230            return $retVal;
231        }
232    
233    A Find method is of course much more complicated than generating a form, and there
234    are variations on the above theme. For example, you could eschew feature filtering
235    entirely in favor of your own custom filtering, you could include extra columns
236    in the output, or you could search for something that's not a feature at all. The
237    above code is just a loose framework.
238    
239    In addition to the finding and filtering, it is necessary to send status messages
240    to the output so that the user does not get bored waiting for results. The L</PrintLine>
241    method performs this function. The single parameter should be text to be
242    output to the browser. In general, you'll invoke it as follows.
243    
244        $self->PrintLine("...my message text...<br />");
245    
246    The break tag is optional. When the Find method gets control, a paragraph will
247    have been started so that everything is XHTML-compliant.
248    
249    If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
250    method of the feature query object.
251    
252        $fq->AddExtraColumns(score => $sc);
253    
254    The L</Find> method must return C<undef> if the search parameters are invalid. If this
255    is the case, then a message describing the problem should be passed to the framework
256    by calling L</SetMessage>. If the parameters are valid, then the method must return
257    the number of items found.
258    
259  =cut  =cut
260    
261  # 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.
262  my $formCount = 0;  my $formCount = 0;
263    # This counter is used to generate unique DIV IDs.
264    my $divCount = 0;
265    
266  =head2 Public Methods  =head2 Public Methods
267    
268  =head3 new  =head3 new
269    
270  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
271    
272  Construct a new SearchHelper object.  Construct a new SearchHelper object.
273    
274  =over 4  =over 4
275    
276  =item query  =item cgi
277    
278  The CGI query object for the current script.  The CGI query object for the current script.
279    
# Line 99  Line 283 
283    
284  sub new {  sub new {
285      # Get the parameters.      # Get the parameters.
286      my ($class, $query) = @_;      my ($class, $cgi) = @_;
287      # Check for a session ID.      # Check for a session ID.
288      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
289      my $type = "old";      my $type = "old";
290      if (! $session_id) {      if (! $session_id) {
291            Trace("No session ID found.") if T(3);
292          # 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
293          # store it in the query object.          # store it in the query object.
294          $session_id = NewSessionID();          $session_id = NewSessionID();
295          $type = "new";          $type = "new";
296          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
297        } else {
298            Trace("Session ID is $session_id.") if T(3);
299      }      }
300      # Compute the subclass name.      # Compute the subclass name.
301      $class =~ /SH(.+)$/;      my $subClass;
302      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
303      # Create the Sprout object.          # Here we have a real search class.
304      my $sprout = SFXlate->new_sprout_only();          $subClass = $1;
305        } else {
306            # Here we have a bare class. The bare class cannot search, but it can
307            # process search results.
308            $subClass = 'SearchHelper';
309        }
310      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
311      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
312      # Generate the form name.      # Generate the form name.
313      my $formName = "$class$formCount";      my $formName = "$class$formCount";
314      $formCount++;      $formCount++;
315      # 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)
316      # 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
317      # class name and the Sprout object.      # class name and a placeholder for the Sprout object.
318      my $retVal = {      my $retVal = {
319                    query => $query,                    query => $cgi,
320                    type => $type,                    type => $type,
321                    class => $subClass,                    class => $subClass,
322                    sprout => $sprout,                    sprout => undef,
323                    orgs => {},                    orgs => {},
324                    name => $formName,                    name => $formName,
325                    scriptQueue => [],                    scriptQueue => [],
326                      genomeList => undef,
327                      genomeParms => [],
328                      filtered => 0,
329                      extraPos => {},
330                   };                   };
331      # Bless and return it.      # Bless and return it.
332      bless $retVal, $class;      bless $retVal, $class;
# Line 152  Line 348 
348      return $self->{query};      return $self->{query};
349  }  }
350    
351    
352    
353  =head3 DB  =head3 DB
354    
355  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 163  Line 361 
361  sub DB {  sub DB {
362      # Get the parameters.      # Get the parameters.
363      my ($self) = @_;      my ($self) = @_;
364        # Insure we have a database.
365        my $retVal = $self->{sprout};
366        if (! defined $retVal) {
367            $retVal = SFXlate->new_sprout_only();
368            $self->{sprout} = $retVal;
369        }
370      # Return the result.      # Return the result.
371      return $self->{sprout};      return $retVal;
372  }  }
373    
374  =head3 IsNew  =head3 IsNew
# Line 183  Line 387 
387      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
388  }  }
389    
390    =head3 SetExtraPos
391    
392    C<< $shelp->SetExtraPos(@columnMap); >>
393    
394    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
395    
396    =over 4
397    
398    =item columnMap
399    
400    A list of extra columns to display at the end.
401    
402    =back
403    
404    =cut
405    
406    sub SetExtraPos {
407        # Get the parameters.
408        my ($self, @columnMap) = @_;
409        # Convert the column map to a hash.
410        my %map = map { $_ => 1 } @columnMap;
411        # Save a reference to it.
412        $self->{extraPos} = \%map;
413    }
414    
415  =head3 ID  =head3 ID
416    
417  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 277  Line 506 
506      my ($self, $title) = @_;      my ($self, $title) = @_;
507      # Get the CGI object.      # Get the CGI object.
508      my $cgi = $self->Q();      my $cgi = $self->Q();
509      # Start the form.      # Start the form. Note we use the override option on the Class value, in
510        # case the Advanced button was used.
511      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
512                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
513                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
514                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
515                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
516                                -value => $self->{class}) .                                -value => $self->{class},
517                                  -override => 1) .
518                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
519                                -value => 1) .                                -value => 1) .
520                   $cgi->h3($title);                   $cgi->h3($title);
# Line 437  Line 668 
668    
669  =head3 PutFeature  =head3 PutFeature
670    
671  C<< $shelp->PutFeature($record, %extraCols); >>  C<< $shelp->PutFeature($fdata); >>
672    
673  Store a feature in the result cache. This is the workhorse method for most  Store a feature in the result cache. This is the workhorse method for most
674  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
675    
676  For each feature, there are certain columns that are standard: the feature name, the  For each feature, there are certain columns that are standard: the feature name, the
677  GBrowse and protein page links, the functional assignment, and so forth. If additional  GBrowse and protein page links, the functional assignment, and so forth. If additional
678  columns are required by a particular search subclass, they should be included in the  columns are required by a particular search subclass, they should be stored in
679  parameters, in key-value form. For example, the following call adds columns for  the feature query object using the B<AddExtraColumns> method. For example, the following
680  essentiality and virulence.  code adds columns for essentiality and virulence.
681    
682      $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
683        $shelp->PutFeature($fd);
684    
685  For correct results, all values should be specified for all extra columns in all calls to  For correct results, all values should be specified for all extra columns in all calls to
686  B<PutFeature>. (In particular, the column header names are computed on the first  B<PutFeature>. (In particular, the column header names are computed on the first
# Line 458  Line 690 
690      if (! $essentialFlag) {      if (! $essentialFlag) {
691          $essentialFlag = undef;          $essentialFlag = undef;
692      }      }
693      $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
694        $shelp->PutFeature($fd);
695    
696  =over 4  =over 4
697    
698  =item record  =item fdata
   
 DBObject record for the feature.  
699    
700  =item extraCols  B<FeatureData> object containing the current feature data.
701    
702  =back  =back
703    
704  =cut  =cut
705    
706  sub PutFeature {  sub PutFeature {
707      # Get the parameters. Note that the extra columns are read in as a list      # Get the parameters.
708      # instead of a hash so that the column order is preserved.      my ($self, $fd) = @_;
709      my ($self, $record, @extraColList) = @_;      # Get the CGI query object.
710        my $cgi = $self->Q();
711        # Get the feature data.
712        my $record = $fd->Feature();
713        my $extraCols = $fd->ExtraCols();
714      # Check for a first-call situation.      # Check for a first-call situation.
715      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
716          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
717          $self->{cols} = $self->DefaultFeatureColumns();          # Tell the user what's happening.
718          # Append the extras. Note we proceed by twos because the columns are          $self->PrintLine("Creating output columns.<br />");
719          # specified in the form name => value.          # Here we need to set up the column information. First we accumulate the extras,
720          for (my $i = 0; $i <= $#extraColList; $i += 2) {          # sorted by column name and separate by whether they go in the beginning or the
721              push @{$self->{cols}}, "X=$extraColList[$i]";          # end.
722            my @xtraNamesFront = ();
723            my @xtraNamesEnd = ();
724            my $xtraPosMap = $self->{extraPos};
725            for my $col (sort keys %{$extraCols}) {
726                if ($xtraPosMap->{$col}) {
727                    push @xtraNamesEnd, "X=$col";
728                } else {
729                    push @xtraNamesFront, "X=$col";
730                }
731          }          }
732          # Write out the column headers. This also prepares the cache file to receive          # Set up the column name array.
733            my @colNames = ();
734            # Put in the extra columns that go in the beginning.
735            push @colNames, @xtraNamesFront;
736            # Add the default columns.
737            push @colNames, $self->DefaultFeatureColumns();
738            # Add any additional columns requested by the feature filter.
739            push @colNames, FeatureQuery::AdditionalColumns($self);
740            # If extras go at the end, put them in here.
741            push @colNames, @xtraNamesEnd;
742            Trace("Full column list determined.") if T(3);
743            # Save the full list.
744            $self->{cols} = \@colNames;
745            # Write out the column names. This also prepares the cache file to receive
746          # output.          # output.
747          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
748            $self->WriteColumnHeaders(@{$self->{cols}});
749            Trace("Column headers written.") if T(3);
750      }      }
751      # Get the feature ID.      # Get the feature ID.
752      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
753      # Now we process the columns themselves. First, convert the extra column list      # Loop through the column headers, producing the desired data. The first column
754      # to a hash.      # is the feature ID. The feature ID does not show up in the output: its purpose
755      my %extraCols = @extraColList;      # is to help the various output formatters.
756      # Loop through the column headers, producing the desired data.      my @output = ($fid);
     my @output = ();  
757      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
758          push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
759      }      }
760      # Compute the sort key. The sort key floats NMPDR organism features to the      # Compute the sort key. The sort key usually floats NMPDR organism features to the
761      # top of the return list.      # top of the return list.
762      my $group = $self->FeatureGroup($fid);      my $key = $self->SortKey($fd);
     my $key = ($group ? "A$group" : "ZZ");  
763      # Write the feature data.      # Write the feature data.
764      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
765  }  }
# Line 583  Line 840 
840      # Check for an open session file.      # Check for an open session file.
841      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
842          # We found one, so close it.          # We found one, so close it.
843            Trace("Closing session file.") if T(2);
844          close $self->{fileHandle};          close $self->{fileHandle};
845            # Tell the user.
846            my $cgi = $self->Q();
847            $self->PrintLine("Output formatting complete.<br />");
848      }      }
849  }  }
850    
# Line 600  Line 861 
861      my $retVal;      my $retVal;
862      # Get a digest encoder.      # Get a digest encoder.
863      my $md5 = Digest::MD5->new();      my $md5 = Digest::MD5->new();
864      # If we have a randomization file, use it to seed the digester.      # Add the PID, the IP, and the time stamp. Note that the time stamp is
865      if (open(R, "/dev/urandom")) {      # actually two numbers, and we get them both because we're in list
866          my $b;      # context.
867          read(R, $b, 1024);      $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
868          $md5->add($b);      # Hash up all this identifying data.
869      }      $retVal = $md5->hexdigest();
870      # Add the PID and the time stamp.      # Return the result.
     $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.  
871      return $retVal;      return $retVal;
872  }  }
873    
# Line 656  Line 911 
911                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
912                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
913                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
914          # Null out the supporting group.          # Format and cache the name and display group.
915          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
916          # If the organism does not exist, format an unknown name.                                                              $strain);
         if (! defined($genus)) {  
             $orgName = "Unknown Genome $genomeID";  
         } else {  
             # It does exist, so format the organism name.  
             $orgName = "$genus $species";  
             if ($strain) {  
                 $orgName .= " $strain";  
             }  
         }  
         # Save this organism in the cache.  
         $cache->{$genomeID} = [$orgName, $group];  
917      }      }
918      # Return the result.      # Return the result.
919      return ($orgName, $group);      return ($orgName, $group);
# Line 771  Line 1015 
1015      } else {      } else {
1016          # Here we can get its genome data.          # Here we can get its genome data.
1017          $retVal = $self->Organism($genomeID);          $retVal = $self->Organism($genomeID);
1018          # Append the type and number.          # Append the FIG ID.
1019          $retVal .= " [$type $num]";          $retVal .= " [$fid]";
1020      }      }
1021      # Return the result.      # Return the result.
1022      return $retVal;      return $retVal;
# Line 780  Line 1024 
1024    
1025  =head3 ComputeFASTA  =head3 ComputeFASTA
1026    
1027  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>
1028    
1029  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.
 that it is possible to convert a DNA sequence into a protein sequence, but the reverse  
 is not possible.  
1030    
1031  =over 4  =over 4
1032    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
1033  =item desiredType  =item desiredType
1034    
1035  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.
 I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.  
1036    
1037  =item sequence  =item sequence
1038    
# Line 817  Line 1054 
1054    
1055  sub ComputeFASTA {  sub ComputeFASTA {
1056      # Get the parameters.      # Get the parameters.
1057      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence) = @_;
1058      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1059      my $retVal;      my $retVal;
1060        # This variable will be cleared if an error is detected.
1061        my $okFlag = 1;
1062      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1063      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1064      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
1065        # Check for a feature specification. The smoking gun for that is a vertical bar.
1066      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1067          # 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
1068          # it.          # it.
1069          my $fid = $1;          my $fid = $1;
1070            Trace("Feature ID for fasta is $fid.") if T(3);
1071          my $sprout = $self->DB();          my $sprout = $self->DB();
1072          # 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
1073          # 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
1074          # exist.          # exist.
1075          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1076          if (! $figID) {          if (! $figID) {
1077              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1078                $okFlag = 0;
1079          } else {          } else {
1080              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1081              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1082                my $favorLen = length $favored;
1083                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1084                if (! $fastaLabel) {
1085                    # In an emergency, fall back to the original ID.
1086                    $fastaLabel = $fid;
1087                }
1088              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1089              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1090                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1091                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1092                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1093              } else {              } else {
1094                  # We want DNA, so get the DNA sequence. This is a two-step process.                  # We want DNA, so get the DNA sequence. This is a two-step process.
1095                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1096                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1097                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1098              }              }
1099          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1100      } else {      } else {
1101            Trace("Analyzing FASTA sequence.") if T(4);
1102          # 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.
1103          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1104                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1105              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1106              $fastaLabel = $1;              $fastaLabel = $1;
1107              $fastaData = $2;              $fastaData = $2;
1108          } else {          } else {
1109                Trace("No label found in match to sequence:\n$sequence") if T(4);
1110              # 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
1111              # as data.              # as data.
1112              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1113              $fastaData = $sequence;              $fastaData = $sequence;
1114          }          }
1115          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1116          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1117          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1118          # Finally, if the user wants to convert to protein, we do it here. Note that          # Finally, verify that it's DNA if we're doing DNA stuff.
1119          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1120          if ($incomingType ne $desiredType) {              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1121              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1122          }          }
1123      }      }
1124      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1125      # in progress.      # Only proceed if no error was detected.
1126      if (defined $fastaLabel) {      if ($okFlag) {
1127          # 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
1128          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1129          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1130          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1131          # the delimiters are what we want.          # the delimiters are what we want.
1132          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1133          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1134      }      }
1135      # Return the result.      # Return the result.
1136      return $retVal;      return $retVal;
1137  }  }
1138    
1139    =head3 SubsystemTree
1140    
1141    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1142    
1143    This method creates a subsystem selection tree suitable for passing to
1144    L</SelectionTree>. Each leaf node in the tree will have a link to the
1145    subsystem display page. In addition, each node can have a radio button. The
1146    radio button alue is either C<classification=>I<string>, where I<string> is
1147    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1148    Thus, it can either be used to filter by a group of related subsystems or a
1149    single subsystem.
1150    
1151    =over 4
1152    
1153    =item sprout
1154    
1155    Sprout database object used to get the list of subsystems.
1156    
1157    =item options
1158    
1159    Hash containing options for building the tree.
1160    
1161    =item RETURN
1162    
1163    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1164    
1165    =back
1166    
1167    The supported options are as follows.
1168    
1169    =over 4
1170    
1171    =item radio
1172    
1173    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1174    
1175    =item links
1176    
1177    TRUE if the tree should be configured for links. The default is TRUE.
1178    
1179    =back
1180    
1181    =cut
1182    
1183    sub SubsystemTree {
1184        # Get the parameters.
1185        my ($sprout, %options) = @_;
1186        # Process the options.
1187        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1188        # Read in the subsystems.
1189        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1190                                   ['Subsystem(classification)', 'Subsystem(id)']);
1191        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1192        # is at the end, ALL subsystems are unclassified and we don't bother.
1193        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1194            while ($subs[0]->[0] eq '') {
1195                my $classLess = shift @subs;
1196                push @subs, $classLess;
1197            }
1198        }
1199        # Declare the return variable.
1200        my @retVal = ();
1201        # Each element in @subs represents a leaf node, so as we loop through it we will be
1202        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1203        # first element is a semi-colon-delimited list of the classifications for the
1204        # subsystem. There will be a stack of currently-active classifications, which we will
1205        # compare to the incoming classifications from the end backward. A new classification
1206        # requires starting a new branch. A different classification requires closing an old
1207        # branch and starting a new one. Each classification in the stack will also contain
1208        # that classification's current branch. We'll add a fake classification at the
1209        # beginning that we can use to represent the tree as a whole.
1210        my $rootName = '<root>';
1211        # Create the classification stack. Note the stack is a pair of parallel lists,
1212        # one containing names and the other containing content.
1213        my @stackNames = ($rootName);
1214        my @stackContents = (\@retVal);
1215        # Add a null entry at the end of the subsystem list to force an unrolling.
1216        push @subs, ['', undef];
1217        # Loop through the subsystems.
1218        for my $sub (@subs) {
1219            # Pull out the classification list and the subsystem ID.
1220            my ($classString, $id) = @{$sub};
1221            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1222            # Convert the classification string to a list with the root classification in
1223            # the front.
1224            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1225            # Find the leftmost point at which the class list differs from the stack.
1226            my $matchPoint = 0;
1227            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1228                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1229                $matchPoint++;
1230            }
1231            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1232                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1233            # Unroll the stack to the matchpoint.
1234            while ($#stackNames >= $matchPoint) {
1235                my $popped = pop @stackNames;
1236                pop @stackContents;
1237                Trace("\"$popped\" popped from stack.") if T(4);
1238            }
1239            # Start branches for any new classifications.
1240            while ($#stackNames < $#classList) {
1241                # The branch for a new classification contains its radio button
1242                # data and then a list of children. So, at this point, if radio buttons
1243                # are desired, we put them into the content.
1244                my $newLevel = scalar(@stackNames);
1245                my @newClassContent = ();
1246                if ($optionThing->{radio}) {
1247                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1248                    push @newClassContent, { value => "classification=$newClassString%" };
1249                }
1250                # The new classification node is appended to its parent's content
1251                # and then pushed onto the stack. First, we need the node name.
1252                my $nodeName = $classList[$newLevel];
1253                # Add the classification to its parent. This makes it part of the
1254                # tree we'll be returning to the user.
1255                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1256                # Push the classification onto the stack.
1257                push @stackContents, \@newClassContent;
1258                push @stackNames, $nodeName;
1259                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1260            }
1261            # Now the stack contains all our parent branches. We add the subsystem to
1262            # the branch at the top of the stack, but only if it's NOT the dummy node.
1263            if (defined $id) {
1264                # Compute the node name from the ID.
1265                my $nodeName = $id;
1266                $nodeName =~ s/_/ /g;
1267                # Create the node's leaf hash. This depends on the value of the radio
1268                # and link options.
1269                my $nodeContent = {};
1270                if ($optionThing->{links}) {
1271                    # Compute the link value.
1272                    my $linkable = uri_escape($id);
1273                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1274                }
1275                if ($optionThing->{radio}) {
1276                    # Compute the radio value.
1277                    $nodeContent->{value} = "id=$id";
1278                }
1279                # Push the node into its parent branch.
1280                Trace("\"$nodeName\" added to node list.") if T(4);
1281                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1282            }
1283        }
1284        # Return the result.
1285        return \@retVal;
1286    }
1287    
1288    
1289  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1290    
1291  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1292    
1293  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
1294  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 900  Line 1300 
1300    
1301  Name to give to the menu.  Name to give to the menu.
1302    
1303  =item options  =item multiple
1304    
1305  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.  
1306    
1307  =item selected  =item selected
1308    
# Line 913  Line 1310 
1310  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
1311  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1312    
1313    =item rows (optional)
1314    
1315    Number of rows to display. If omitted, the default is 1 for a single-select list
1316    and 10 for a multi-select list.
1317    
1318    =item crossMenu (optional)
1319    
1320    If specified, is presumed to be the name of another genome menu whose contents
1321    are to be mutually exclusive with the contents of this menu. As a result, instead
1322    of the standard onChange event, the onChange event will deselect any entries in
1323    the other menu.
1324    
1325  =item RETURN  =item RETURN
1326    
1327  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 923  Line 1332 
1332    
1333  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1334      # Get the parameters.      # Get the parameters.
1335      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1336      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1337      my $sprout = $self->DB();      my $sprout = $self->DB();
1338      my $cgi = $self->Q();      my $cgi = $self->Q();
1339        # Compute the row count.
1340        if (! defined $rows) {
1341            $rows = ($multiple ? 10 : 1);
1342        }
1343        # Create the multiple tag.
1344        my $multipleTag = ($multiple ? " multiple" : "");
1345      # Get the form name.      # Get the form name.
1346      my $formName = $self->FormName();      my $formName = $self->FormName();
1347        # Check to see if we already have a genome list in memory.
1348        my $genomes = $self->{genomeList};
1349        my $groupHash;
1350        if (defined $genomes) {
1351            # We have a list ready to use.
1352            $groupHash = $genomes;
1353        } else {
1354      # 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
1355      # 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
1356      # take advantage of an existing index.      # take advantage of an existing index.
# Line 940  Line 1362 
1362      # 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
1363      # 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
1364      # name.      # name.
1365      my %groupHash = ();          my %gHash = ();
1366      for my $genome (@genomeList) {      for my $genome (@genomeList) {
1367          # Get the genome data.          # Get the genome data.
1368          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1369          # Form the genome name.              # Compute and cache its name and display group.
1370          my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1371          if ($strain) {                                                                  $strain);
1372              $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1373          }              # name here, not the display group name.
1374          # Push the genome into the group's list.              push @{$gHash{$group}}, [$genomeID, $name];
1375          push @{$groupHash{$group}}, [$genomeID, $name];          }
1376            # Save the genome list for future use.
1377            $self->{genomeList} = \%gHash;
1378            $groupHash = \%gHash;
1379      }      }
1380      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1381      # the supporting-genome group last.      # the supporting-genome group last.
1382      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1383      push @groups, $FIG_Config::otherGroup;      push @groups, $FIG_Config::otherGroup;
1384      # Next, create a hash that specifies the pre-selected entries.      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1385      my %selectedHash = map { $_ => 1 } @{$selected};      # with the possibility of undefined values in the incoming list.
1386      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      my %selectedHash = ();
1387        if (defined $selected) {
1388            %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1389        }
1390        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1391        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1392        # and use that to make the selections.
1393        my $nmpdrCount = 0;
1394      # Create the type counters.      # Create the type counters.
1395      my $groupCount = 1;      my $groupCount = 1;
1396      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 967  Line 1399 
1399      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1400      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1401      my $onChange = "";      my $onChange = "";
1402      if ($options->{multiple}) {      if ($cross) {
1403            # Here we have a paired menu. Selecting something in our menu unselects it in the
1404            # other and redisplays the status of both.
1405            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1406        } elsif ($multiple) {
1407            # This is an unpaired menu, so all we do is redisplay our status.
1408          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1409      }      }
1410      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1411      my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1412      # Loop through the groups.      # Loop through the groups.
1413      for my $group (@groups) {      for my $group (@groups) {
1414          # Create the option group tag.          # Create the option group tag.
1415          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1416          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");  
1417          # Get the genomes in the group.          # Get the genomes in the group.
1418          for my $genome (@{$groupHash{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1419                # Count this organism if it's NMPDR.
1420                if ($group ne $FIG_Config::otherGroup) {
1421                    $nmpdrCount++;
1422                }
1423                # Get the organism ID and name.
1424              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1425              # See if it's selected.              # See if it's selected.
1426              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1427              # Generate the option tag.              # Generate the option tag.
1428              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1429              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1430          }          }
1431          # Close the option group.          # Close the option group.
# Line 999  Line 1434 
1434      # Close the SELECT tag.      # Close the SELECT tag.
1435      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1436      # Check for multiple selection.      # Check for multiple selection.
1437      if ($options->{multiple}) {      if ($multiple) {
1438          # 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
1439            # the search box. This allows the user to type text and have all genomes containing
1440            # the text selected automatically.
1441            my $searchThingName = "${menuName}_SearchThing";
1442            push @lines, "<br />" .
1443                         "<INPUT type=\"button\" name=\"Search\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1444                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1445            # Next are the buttons to set and clear selections.
1446          push @lines, "<br />";          push @lines, "<br />";
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
1447          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\" />";
1448          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\" />";
1449          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\" />";
1450            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1451          # Add the status display, too.          # Add the status display, too.
1452          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1453          # 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 1014  Line 1456 
1456          # in case we decide to twiddle the parameters.          # in case we decide to twiddle the parameters.
1457          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1458          $self->QueueFormScript($showSelect);          $self->QueueFormScript($showSelect);
1459            # Finally, add this parameter to the list of genome parameters. This enables us to
1460            # easily find all the parameters used to select one or more genomes.
1461            push @{$self->{genomeParms}}, $menuName;
1462      }      }
1463      # Assemble all the lines into a string.      # Assemble all the lines into a string.
1464      my $retVal = join("\n", @lines, "");      my $retVal = join("\n", @lines, "");
# Line 1021  Line 1466 
1466      return $retVal;      return $retVal;
1467  }  }
1468    
1469    =head3 PropertyMenu
1470    
1471    C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1472    
1473    Generate a property name dropdown menu.
1474    
1475    =over 4
1476    
1477    =item menuName
1478    
1479    Name to give to the menu.
1480    
1481    =item selected
1482    
1483    Value of the property name to pre-select.
1484    
1485    =item force (optional)
1486    
1487    If TRUE, then the user will be forced to choose a property name. If FALSE,
1488    then an additional menu choice will be provided to select nothing.
1489    
1490    =item RETURN
1491    
1492    Returns a dropdown menu box that allows the user to select a property name. An additional
1493    selection entry will be provided for selecting no property name
1494    
1495    =back
1496    
1497    =cut
1498    
1499    sub PropertyMenu {
1500        # Get the parameters.
1501        my ($self, $menuName, $selected, $force) = @_;
1502        # Get the CGI and Sprout objects.
1503        my $sprout = $self->DB();
1504        my $cgi = $self->Q();
1505        # Create the property name list.
1506        my @propNames = ();
1507        if (! $force) {
1508            push @propNames, "";
1509        }
1510        # Get all the property names, putting them after the null choice if one exists.
1511        push @propNames, $sprout->GetChoices('Property', 'property-name');
1512        # Create a menu from them.
1513        my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1514                                      -default => $selected);
1515        # Return the result.
1516        return $retVal;
1517    }
1518    
1519  =head3 MakeTable  =head3 MakeTable
1520    
1521  C<< my $htmlText = $shelp->MakeTable(\@rows); >>  C<< my $htmlText = $shelp->MakeTable(\@rows); >>
# Line 1039  Line 1534 
1534  =item rows  =item rows
1535    
1536  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
1537  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
1538  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1539    
1540  =item RETURN  =item RETURN
1541    
# Line 1055  Line 1550 
1550      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1551      # Get the CGI object.      # Get the CGI object.
1552      my $cgi = $self->Q();      my $cgi = $self->Q();
1553      # 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.
1554        # This flag will be set to FALSE when that happens.
1555        my $needWidth = 1;
1556      # 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
1557      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1558      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1559          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1560            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1561                # Here we have a first cell and its tag parameters are in $2.
1562                my $elements = $2;
1563                if ($elements !~ /colspan/i) {
1564                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1565                    # Here there's no colspan, so we plug in the width. We
1566                    # eschew the "g" modifier on the substitution because we
1567                    # only want to update the first cell.
1568                    $row =~ s/(<(td|th))/$1 width="150"/i;
1569                    # Denote we don't need this any more.
1570                    $needWidth = 0;
1571                }
1572            }
1573      }      }
1574      # Create the table.      # Create the table.
1575      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1071  Line 1581 
1581    
1582  =head3 SubmitRow  =head3 SubmitRow
1583    
1584  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1585    
1586  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1587  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1588  near the top of the form.  near the top of the form.
1589    
1590    =over 4
1591    
1592    =item caption (optional)
1593    
1594    Caption to be put on the search button. The default is C<Go>.
1595    
1596    =item RETURN
1597    
1598    Returns a table row containing the controls for submitting the search
1599    and tuning the results.
1600    
1601    =back
1602    
1603  =cut  =cut
1604    
1605  sub SubmitRow {  sub SubmitRow {
1606      # Get the parameters.      # Get the parameters.
1607      my ($self) = @_;      my ($self, $caption) = @_;
1608      my $cgi = $self->Q();      my $cgi = $self->Q();
1609      # Declare the return variable.      # Compute the button caption.
1610        my $realCaption = (defined $caption ? $caption : 'Go');
1611        # Get the current page size.
1612        my $pageSize = $cgi->param('PageSize');
1613        # Get the incoming external-link flag.
1614        my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1615        # Create the row.
1616      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1617                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1618                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1619                                                      -default => $cgi->param('PageSize'))),                                                      -default => $pageSize)),
1620                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1621                                                  -name => 'Search',                                                  -name => 'Search',
1622                                                  -value => 'Go')));                                                  -value => $realCaption)));
1623      # Return the result.      # Return the result.
1624      return $retVal;      return $retVal;
1625  }  }
1626    
1627    =head3 FeatureFilterRows
1628    
1629    C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1630    
1631    This method creates table rows that can be used to filter features. The form
1632    values can be used to select features by genome using the B<FeatureQuery>
1633    object.
1634    
1635    =over 4
1636    
1637    =item subset
1638    
1639    List of rows to display. The default (C<all>) is to display all rows.
1640    C<words> displays the word search box, C<subsys> displays the subsystem
1641    selector, and C<options> displays the options row.
1642    
1643    =item RETURN
1644    
1645    Returns the html text for table rows containing the desired feature filtering controls.
1646    
1647    =back
1648    
1649    =cut
1650    
1651    sub FeatureFilterRows {
1652        # Get the parameters.
1653        my ($self, @subset) = @_;
1654        if (@subset == 0 || $subset[0] eq 'all') {
1655            @subset = qw(words subsys options);
1656        }
1657        # Return the result.
1658        return FeatureQuery::FilterRows($self, @subset);
1659    }
1660    
1661  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
1662    
1663  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
# Line 1133  Line 1697 
1697          # Get the feature location string.          # Get the feature location string.
1698          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1699          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1700          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1701            Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1702          # Now we need to do some goofiness to insure that the location is not too          # Now we need to do some goofiness to insure that the location is not too
1703          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
1704          my $mid = int(($start + $stop) / 2);          my $mid = int(($start + $stop) / 2);
# Line 1163  Line 1728 
1728          }          }
1729          my $seg_id = $contig;          my $seg_id = $contig;
1730          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1731            Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1732          # Assemble all the pieces.          # Assemble all the pieces.
1733          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id;start=$show_start;stop=$show_stop";
1734      }      }
1735      # Return the result.      # Return the result.
1736      return $retVal;      return $retVal;
1737  }  }
1738    
1739  =head2 Feature Column Methods  =head3 GetGenomes
1740    
1741  The methods in this column manage feature column data. If you want to provide the  C<< my @genomeList = $shelp->GetGenomes($parmName); >>
 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.  
1742    
1743  There is one special column name syntax for extra columns (that is, nonstandard  Return the list of genomes specified by the specified CGI query parameter.
1744  feature columns). If the column name begins with C<X=>, then it is presumed to be  If the request method is POST, then the list of genome IDs is returned
1745  an extra column. The column title is the text after the C<X=>, and its value is  without preamble. If the request method is GET and the parameter is not
1746  pulled from the extra column hash.  specified, then it is treated as a request for all genomes. This makes it
1747    easier for web pages to link to a search that wants to specify all genomes.
1748    
1749  =head3 DefaultFeatureColumns  =over 4
1750    
1751    =item parmName
1752    
1753    Name of the parameter containing the list of genomes. This will be the
1754    first parameter passed to the L</NmpdrGenomeMenu> call that created the
1755    genome selection control on the form.
1756    
1757    =item RETURN
1758    
1759  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Returns a list of the genomes to process.
1760    
1761  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.  
1762    
1763  =cut  =cut
1764    
1765  sub DefaultFeatureColumns {  sub GetGenomes {
1766        # Get the parameters.
1767        my ($self, $parmName) = @_;
1768        # Get the CGI query object.
1769        my $cgi = $self->Q();
1770        # Get the list of genome IDs in the request header.
1771        my @retVal = $cgi->param($parmName);
1772        Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1773        # Check for the special GET case.
1774        if ($cgi->request_method() eq "GET" && ! @retVal) {
1775            # Here the caller wants all the genomes.
1776            my $sprout = $self->DB();
1777            @retVal = $sprout->Genomes();
1778        }
1779        # Return the result.
1780        return @retVal;
1781    }
1782    
1783    =head3 GetHelpText
1784    
1785    C<< my $htmlText = $shelp->GetHelpText(); >>
1786    
1787    Get the help text for this search. The help text is stored in files on the template
1788    server. The help text for a specific search is taken from a file named
1789    C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1790    There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1791    feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1792    describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1793    describes the standard controls for a search, such as page size, URL display, and
1794    external alias display.
1795    
1796    =cut
1797    
1798    sub GetHelpText {
1799      # Get the parameters.      # Get the parameters.
1800      my ($self) = @_;      my ($self) = @_;
1801        # Create a list to hold the pieces of the help.
1802        my @helps = ();
1803        # Get the template directory URL.
1804        my $urlBase = $FIG_Config::template_url;
1805        # Start with the specific help.
1806        my $class = $self->{class};
1807        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1808        # Add the genome control help if needed.
1809        if (scalar @{$self->{genomeParms}}) {
1810            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1811        }
1812        # Next the filter help.
1813        if ($self->{filtered}) {
1814            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1815        }
1816        # Finally, the standard help.
1817        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1818        # Assemble the pieces.
1819        my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1820      # Return the result.      # Return the result.
1821      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
1822  }  }
1823    
1824  =head3 FeatureColumnTitle  =head3 ComputeSearchURL
1825    
1826  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1827    
1828  Return the column heading title to be used for the specified feature column.  Compute the GET-style URL for the current search. In order for this to work, there
1829    must be a copy of the search form on the current page. This will always be the
1830    case if the search is coming from C<SearchSkeleton.cgi>.
1831    
1832    A little expense is involved in order to make the URL as smart as possible. The
1833    main complication is that if the user specified all genomes, we'll want to
1834    remove the parameter entirely from a get-style URL.
1835    
1836  =over 4  =over 4
1837    
1838  =item name  =item overrides
1839    
1840  Name of the desired feature column.  Hash containing override values for the parameters, where the parameter name is
1841    the key and the parameter value is the override value. If the override value is
1842    C<undef>, the parameter will be deleted from the result.
1843    
1844  =item RETURN  =item RETURN
1845    
1846  Returns the title to be used as the column header for the named feature column.  Returns a GET-style URL for invoking the search with the specified overrides.
1847    
1848  =back  =back
1849    
1850  =cut  =cut
1851    
1852  sub FeatureColumnTitle {  sub ComputeSearchURL {
1853      # Get the parameters.      # Get the parameters.
1854      my ($self, $colName) = @_;      my ($self, %overrides) = @_;
1855      # Declare the return variable. We default to a blank column name.      # Get the database and CGI query object.
1856      my $retVal = "&nbsp;";      my $cgi = $self->Q();
1857      # Process the column name.      my $sprout = $self->DB();
1858      if ($colName =~ /^X=(.+)$/) {      # Start with the full URL.
1859          # Here we have an extra column.      my $retVal = $cgi->url(-full => 1);
1860          $retVal = $1;      # Get all the query parameters in a hash.
1861      } elsif ($colName eq 'orgName') {      my %parms = $cgi->Vars();
1862          $retVal = "Name";      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1863      } elsif ($colName eq 'fid') {      # characters separating the individual values. We have to convert those to lists. In addition,
1864          $retVal = "FIG ID";      # the multiple-selection genome parameters and the feature type parameter must be checked to
1865        # determine whether or not they can be removed from the URL. First, we get a list of the
1866        # genome parameters and a list of all genomes. Note that we only need the list if a
1867        # multiple-selection genome parameter has been found on the form.
1868        my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1869        my @genomeList;
1870        if (keys %genomeParms) {
1871            @genomeList = $sprout->Genomes();
1872        }
1873        # Create a list to hold the URL parameters we find.
1874        my @urlList = ();
1875        # Now loop through the parameters in the hash, putting them into the output URL.
1876        for my $parmKey (keys %parms) {
1877            # Get a list of the parameter values. If there's only one, we'll end up with
1878            # a singleton list, but that's okay.
1879            my @values = split (/\0/, $parms{$parmKey});
1880            # Check for special cases.
1881            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1882                # These are bookkeeping parameters we don't need to start a search.
1883                @values = ();
1884            } elsif ($parmKey =~ /_SearchThing$/) {
1885                # Here the value coming in is from a genome control's search thing. It does
1886                # not affect the results of the search, so we clear it.
1887                @values = ();
1888            } elsif ($genomeParms{$parmKey}) {
1889                # Here we need to see if the user wants all the genomes. If he does,
1890                # we erase all the values just like with features.
1891                my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1892                if ($allFlag) {
1893                    @values = ();
1894                }
1895            } elsif (exists $overrides{$parmKey}) {
1896                # Here the value is being overridden, so we skip it for now.
1897                @values = ();
1898            }
1899            # If we still have values, create the URL parameters.
1900            if (@values) {
1901                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1902            }
1903        }
1904        # Now do the overrides.
1905        for my $overKey (keys %overrides) {
1906            # Only use this override if it's not a delete marker.
1907            if (defined $overrides{$overKey}) {
1908                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1909            }
1910        }
1911        # Add the parameters to the URL.
1912        $retVal .= "?" . join(";", @urlList);
1913        # Return the result.
1914        return $retVal;
1915    }
1916    
1917    =head3 GetRunTimeValue
1918    
1919    C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1920    
1921    Compute a run-time column value.
1922    
1923    =over 4
1924    
1925    =item text
1926    
1927    The run-time column text. It consists of 2 percent signs, a column type, an equal
1928    sign, and the data for the current row.
1929    
1930    =item RETURN
1931    
1932    Returns the fully-formatted HTML text to go into the current column of the current row.
1933    
1934    =back
1935    
1936    =cut
1937    
1938    sub GetRunTimeValue {
1939        # Get the parameters.
1940        my ($self, $text) = @_;
1941        # Declare the return variable.
1942        my $retVal;
1943        # Parse the incoming text.
1944        if ($text =~ /^%%([^=]+)=(.*)$/) {
1945            $retVal = $self->RunTimeColumns($1, $2);
1946        } else {
1947            Confess("Invalid run-time column string \"$text\" encountered in session file.");
1948        }
1949        # Return the result.
1950        return $retVal;
1951    }
1952    
1953    =head3 AdvancedClassList
1954    
1955    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1956    
1957    Return a list of advanced class names. This list is used to generate the directory
1958    of available searches on the search page.
1959    
1960    We use the %INC variable to accomplish this.
1961    
1962    =cut
1963    
1964    sub AdvancedClassList {
1965        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1966        return sort @retVal;
1967    }
1968    
1969    =head3 SelectionTree
1970    
1971    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1972    
1973    Display a selection tree.
1974    
1975    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1976    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1977    addition, some of the tree nodes can contain hyperlinks.
1978    
1979    The tree itself is passed in as a multi-level list containing node names followed by
1980    contents. Each content element is a reference to a similar list. The first element of
1981    each list may be a hash reference. If so, it should contain one or both of the following
1982    keys.
1983    
1984    =over 4
1985    
1986    =item link
1987    
1988    The navigation URL to be popped up if the user clicks on the node name.
1989    
1990    =item value
1991    
1992    The form value to be returned if the user selects the tree node.
1993    
1994    =back
1995    
1996    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1997    a C<value> key indicates the node name will have a radio button. If a node has no children,
1998    you may pass it a hash reference instead of a list reference.
1999    
2000    The following example shows the hash for a three-level tree with links on the second level and
2001    radio buttons on the third.
2002    
2003        [   Objects => [
2004                Entities => [
2005                    {link => "../docs/WhatIsAnEntity.html"},
2006                    Genome => {value => 'GenomeData'},
2007                    Feature => {value => 'FeatureData'},
2008                    Contig => {value => 'ContigData'},
2009                ],
2010                Relationships => [
2011                    {link => "../docs/WhatIsARelationShip.html"},
2012                    HasFeature => {value => 'GenomeToFeature'},
2013                    IsOnContig => {value => 'FeatureToContig'},
2014                ]
2015            ]
2016        ]
2017    
2018    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
2019    all have list references.
2020    
2021    This next example shows how to set up a taxonomy selection field. The value returned
2022    by the tree control will be the taxonomy string for the selected node ready for use
2023    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
2024    reasons of space.
2025    
2026        [   All => [
2027                {value => "%"},
2028                Bacteria => [
2029                    {value => "Bacteria%"},
2030                    Proteobacteria => [
2031                        {value => "Bacteria; Proteobacteria%"},
2032                        Epsilonproteobacteria => [
2033                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
2034                            Campylobacterales => [
2035                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
2036                                Campylobacteraceae =>
2037                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
2038                                ...
2039                            ]
2040                            ...
2041                        ]
2042                        ...
2043                    ]
2044                    ...
2045                ]
2046                ...
2047            ]
2048        ]
2049    
2050    
2051    This method of tree storage allows the caller to control the order in which the tree nodes
2052    are displayed and to completely control value selection and use of hyperlinks. It is, however
2053    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
2054    
2055    The parameters to this method are as follows.
2056    
2057    =over 4
2058    
2059    =item cgi
2060    
2061    CGI object used to generate the HTML.
2062    
2063    =item tree
2064    
2065    Reference to a hash describing a tree. See the description above.
2066    
2067    =item options
2068    
2069    Hash containing options for the tree display.
2070    
2071    =back
2072    
2073    The allowable options are as follows
2074    
2075    =over 4
2076    
2077    =item nodeImageClosed
2078    
2079    URL of the image to display next to the tree nodes when they are collapsed. Clicking
2080    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
2081    
2082    =item nodeImageOpen
2083    
2084    URL of the image to display next to the tree nodes when they are expanded. Clicking
2085    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
2086    
2087    =item style
2088    
2089    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
2090    as nested lists, the key components of this style are the definitions for the C<ul> and
2091    C<li> tags. The default style file contains the following definitions.
2092    
2093        .tree ul {
2094           margin-left: 0; padding-left: 22px
2095        }
2096        .tree li {
2097            list-style-type: none;
2098        }
2099    
2100    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
2101    parent by the width of the node image. This use of styles limits the things we can do in formatting
2102    the tree, but it has the advantage of vastly simplifying the tree creation.
2103    
2104    =item name
2105    
2106    Field name to give to the radio buttons in the tree. The default is C<selection>.
2107    
2108    =item target
2109    
2110    Frame target for links. The default is C<_self>.
2111    
2112    =item selected
2113    
2114    If specified, the value of the radio button to be pre-selected.
2115    
2116    =back
2117    
2118    =cut
2119    
2120    sub SelectionTree {
2121        # Get the parameters.
2122        my ($cgi, $tree, %options) = @_;
2123        # Get the options.
2124        my $optionThing = Tracer::GetOptions({ name => 'selection',
2125                                               nodeImageClosed => '../FIG/Html/plus.gif',
2126                                               nodeImageOpen => '../FIG/Html/minus.gif',
2127                                               style => 'tree',
2128                                               target => '_self',
2129                                               selected => undef},
2130                                             \%options);
2131        # Declare the return variable. We'll do the standard thing with creating a list
2132        # of HTML lines and rolling them together at the end.
2133        my @retVal = ();
2134        # Only proceed if the tree is present.
2135        if (defined($tree)) {
2136            # Validate the tree.
2137            if (ref $tree ne 'ARRAY') {
2138                Confess("Selection tree is not a list reference.");
2139            } elsif (scalar @{$tree} == 0) {
2140                # The tree is empty, so we do nothing.
2141            } elsif ($tree->[0] eq 'HASH') {
2142                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2143            } else {
2144                # Here we have a real tree. Apply the tree style.
2145                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2146                # Give us a DIV ID.
2147                my $divID = GetDivID($optionThing->{name});
2148                # Show the tree.
2149                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2150                # Close the DIV block.
2151                push @retVal, $cgi->end_div();
2152            }
2153        }
2154        # Return the result.
2155        return join("\n", @retVal, "");
2156    }
2157    
2158    =head3 ShowBranch
2159    
2160    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2161    
2162    This is a recursive method that displays a branch of the tree.
2163    
2164    =over 4
2165    
2166    =item cgi
2167    
2168    CGI object used to format HTML.
2169    
2170    =item label
2171    
2172    Label of this tree branch. It is only used in error messages.
2173    
2174    =item id
2175    
2176    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2177    tree nodes.
2178    
2179    =item branch
2180    
2181    Reference to a list containing the content of the tree branch. The list contains an optional
2182    hash reference that is ignored and the list of children, each child represented by a name
2183    and then its contents. The contents could by a hash reference (indicating the attributes
2184    of a leaf node), or another tree branch.
2185    
2186    =item options
2187    
2188    Options from the original call to L</SelectionTree>.
2189    
2190    =item displayType
2191    
2192    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2193    hidden.
2194    
2195    =item RETURN
2196    
2197    Returns one or more HTML lines that can be used to display the tree branch.
2198    
2199    =back
2200    
2201    =cut
2202    
2203    sub ShowBranch {
2204        # Get the parameters.
2205        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2206        # Declare the return variable.
2207        my @retVal = ();
2208        # Start the branch.
2209        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2210        # Check for the hash and choose the start location accordingly.
2211        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2212        # Get the list length.
2213        my $i1 = scalar(@{$branch});
2214        # Verify we have an even number of elements.
2215        if (($i1 - $i0) % 2 != 0) {
2216            Trace("Branch elements are from $i0 to $i1.") if T(3);
2217            Confess("Odd number of elements in tree branch $label.");
2218        } else {
2219            # Loop through the elements.
2220            for (my $i = $i0; $i < $i1; $i += 2) {
2221                # Get this node's label and contents.
2222                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2223                # Get an ID for this node's children (if any).
2224                my $myID = GetDivID($options->{name});
2225                # Now we need to find the list of children and the options hash.
2226                # This is a bit ugly because we allow the shortcut of a hash without an
2227                # enclosing list. First, we need some variables.
2228                my $attrHash = {};
2229                my @childHtml = ();
2230                my $hasChildren = 0;
2231                if (! ref $myContent) {
2232                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2233                } elsif (ref $myContent eq 'HASH') {
2234                    # Here the node is a leaf and its content contains the link/value hash.
2235                    $attrHash = $myContent;
2236                } elsif (ref $myContent eq 'ARRAY') {
2237                    # Here the node may be a branch. Its content is a list.
2238                    my $len = scalar @{$myContent};
2239                    if ($len >= 1) {
2240                        # Here the first element of the list could by the link/value hash.
2241                        if (ref $myContent->[0] eq 'HASH') {
2242                            $attrHash = $myContent->[0];
2243                            # If there's data in the list besides the hash, it's our child list.
2244                            # We can pass the entire thing as the child list, because the hash
2245                            # is ignored.
2246                            if ($len > 1) {
2247                                $hasChildren = 1;
2248                            }
2249                        } else {
2250                            $hasChildren = 1;
2251                        }
2252                        # If we have children, create the child list with a recursive call.
2253                        if ($hasChildren) {
2254                            Trace("Processing children of $myLabel.") if T(4);
2255                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2256                            Trace("Children of $myLabel finished.") if T(4);
2257                        }
2258                    }
2259                }
2260                # Okay, it's time to pause and take stock. We have the label of the current node
2261                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2262                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2263                # Compute the image HTML. It's tricky, because we have to deal with the open and
2264                # closed images.
2265                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2266                my $image = $images[$hasChildren];
2267                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2268                if ($hasChildren) {
2269                    # If there are children, we wrap the image in a toggle hyperlink.
2270                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2271                                          $prefixHtml);
2272                }
2273                # Now the radio button, if any. Note we use "defined" in case the user wants the
2274                # value to be 0.
2275                if (defined $attrHash->{value}) {
2276                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2277                    # hash for the "input" method. If the item is pre-selected, we add
2278                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2279                    # at all.
2280                    my $radioParms = { type => 'radio',
2281                                       name => $options->{name},
2282                                       value => $attrHash->{value},
2283                                     };
2284                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2285                        $radioParms->{checked} = undef;
2286                    }
2287                    $prefixHtml .= $cgi->input($radioParms);
2288                }
2289                # Next, we format the label.
2290                my $labelHtml = $myLabel;
2291                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2292                # Apply a hyperlink if necessary.
2293                if (defined $attrHash->{link}) {
2294                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2295                                         $labelHtml);
2296                }
2297                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2298                # here.
2299                my $childHtml = join("\n", @childHtml);
2300                # Now we have all the pieces, so we can put them together.
2301                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2302            }
2303        }
2304        # Close the tree branch.
2305        push @retVal, $cgi->end_ul();
2306        # Return the result.
2307        return @retVal;
2308    }
2309    
2310    =head3 GetDivID
2311    
2312    C<< my $idString = SearchHelper::GetDivID($name); >>
2313    
2314    Return a new HTML ID string.
2315    
2316    =over 4
2317    
2318    =item name
2319    
2320    Name to be prefixed to the ID string.
2321    
2322    =item RETURN
2323    
2324    Returns a hopefully-unique ID string.
2325    
2326    =back
2327    
2328    =cut
2329    
2330    sub GetDivID {
2331        # Get the parameters.
2332        my ($name) = @_;
2333        # Compute the ID.
2334        my $retVal = "elt_$name$divCount";
2335        # Increment the counter to make sure this ID is not re-used.
2336        $divCount++;
2337        # Return the result.
2338        return $retVal;
2339    }
2340    
2341    =head2 Feature Column Methods
2342    
2343    The methods in this section manage feature column data. If you want to provide the
2344    capability to include new types of data in feature columns, then all the changes
2345    are made to this section of the source file. Technically, this should be implemented
2346    using object-oriented methods, but this is simpler for non-programmers to maintain.
2347    To add a new column of feature data, you must first give it a name. For example,
2348    the name for the protein page link column is C<protlink>. If the column is to appear
2349    in the default list of feature columns, add it to the list returned by
2350    L</DefaultFeatureColumns>. Then add code to produce the column title to
2351    L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2352    feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2353    hash. Everything else will happen automatically.
2354    
2355    There is a special column name syntax for extra columns (that is, nonstandard
2356    feature columns). If the column name begins with C<X=>, then it is presumed to be
2357    an extra column. The column title is the text after the C<X=>, and its value is
2358    pulled from the extra column hash.
2359    
2360    =cut
2361    
2362    # This hash is used to determine which columns should not be included in downloads.
2363    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2364    
2365    =head3 DefaultFeatureColumns
2366    
2367    C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2368    
2369    Return a list of the default feature column identifiers. These identifiers can
2370    be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2371    produce the column titles and row values.
2372    
2373    =cut
2374    
2375    sub DefaultFeatureColumns {
2376        # Get the parameters.
2377        my ($self) = @_;
2378        # Return the result.
2379        return qw(orgName function gblink protlink);
2380    }
2381    
2382    =head3 FeatureColumnTitle
2383    
2384    C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2385    
2386    Return the column heading title to be used for the specified feature column.
2387    
2388    =over 4
2389    
2390    =item name
2391    
2392    Name of the desired feature column.
2393    
2394    =item RETURN
2395    
2396    Returns the title to be used as the column header for the named feature column.
2397    
2398    =back
2399    
2400    =cut
2401    
2402    sub FeatureColumnTitle {
2403        # Get the parameters.
2404        my ($self, $colName) = @_;
2405        # Declare the return variable. We default to a blank column name.
2406        my $retVal = "&nbsp;";
2407        # Process the column name.
2408        if ($colName =~ /^X=(.+)$/) {
2409            # Here we have an extra column.
2410            $retVal = $1;
2411      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2412          $retVal = "External Aliases";          $retVal = "External Aliases";
2413        } elsif ($colName eq 'fid') {
2414            $retVal = "FIG ID";
2415      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2416          $retVal = "Functional Assignment";          $retVal = "Functional Assignment";
2417      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2418          $retVal = "GBrowse";          $retVal = "GBrowse";
     } elsif ($colName eq 'protlink') {  
         $retVal = "NMPDR Protein Page";  
2419      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2420          $retVal = "NMDPR Group";          $retVal = "NMDPR Group";
2421        } elsif ($colName =~ /^keyword:(.+)$/) {
2422            $retVal = ucfirst $1;
2423        } elsif ($colName eq 'orgName') {
2424            $retVal = "Organism and Gene ID";
2425        } elsif ($colName eq 'protlink') {
2426            $retVal = "NMPDR Protein Page";
2427        } elsif ($colName eq 'viewerlink') {
2428            $retVal = "Annotation Page";
2429        } elsif ($colName eq 'subsystem') {
2430            $retVal = "Subsystems";
2431      }      }
2432      # Return the result.      # Return the result.
2433      return $retVal;      return $retVal;
2434  }  }
2435    
2436    =head3 FeatureColumnDownload
2437    
2438    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2439    
2440    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2441    
2442    =over 4
2443    
2444    =item colName
2445    
2446    Name of the relevant feature column.
2447    
2448    =item RETURN
2449    
2450    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2451    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2452    
2453    =back
2454    
2455    =cut
2456    
2457    sub FeatureColumnDownload {
2458        # Get the parameters.
2459        my ($self, $colName) = @_;
2460        # Return the determination. We download the column if it's not in the skip-hash.
2461        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2462        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2463    }
2464    
2465    
2466  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2467    
2468  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
# Line 1267  Line 2477 
2477    
2478  =item record  =item record
2479    
2480  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2481    
2482  =item extraCols  =item extraCols
2483    
# Line 1303  Line 2513 
2513          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2514              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2515          }          }
2516      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'alias') {
2517          # Here we want the formatted organism name and feature number.          # In this case, the user wants a list of external aliases for the feature.
2518          $retVal = $self->FeatureName($fid);          # These are very expensive, so we compute them when the row is displayed.
2519            # To do the computation, we need to know the favored alias type and the
2520            # feature ID.
2521            my $favored = $cgi->param("FavoredAlias") || "fig";
2522            $retVal = "%%alias=$fid,$favored";
2523      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2524          # Here we have the raw feature ID. We hyperlink it to the protein page.          # Here we have the raw feature ID. We hyperlink it to the protein page.
2525          $retVal = HTML::set_prot_links($fid);          $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);  
         }  
2526      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2527          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2528          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2529      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2530          # Here we want a link to the GBrowse page using the official GBrowse button.          # Here we want a link to the GBrowse page using the official GBrowse button.
2531          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2532          $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },                            fid => $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 })  
                          );  
2533      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2534          # Get the NMPDR group name.          # Get the NMPDR group name.
2535          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1345  Line 2537 
2537          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2538          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2539                            $group);                            $group);
2540        } elsif ($colName =~ /^keyword:(.+)$/) {
2541            # Here we want keyword-related values. This is also expensive, so
2542            # we compute them when the row is displayed.
2543            $retVal = "%%$colName=$fid";
2544        } elsif ($colName eq 'orgName') {
2545            # Here we want the formatted organism name and feature number.
2546            $retVal = $self->FeatureName($fid);
2547        } elsif ($colName eq 'protlink') {
2548            # Here we want a link to the protein page using the official NMPDR button.
2549            $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2550                              prot => $fid, SPROUT => 1, new_framework => 0,
2551                              user => '');
2552        } elsif ($colName eq 'viewerlink') {
2553            # Here we want a link to the SEED viewer page using the official viewer button.
2554            $retVal = FakeButton('Annotation', "index.cgi", undef,
2555                                 action => 'ShowAnnotation', prot => $fid);
2556        } elsif ($colName eq 'subsystem') {
2557            # Another run-time column: subsystem list.
2558            $retVal = "%%subsystem=$fid";
2559        }
2560        # Return the result.
2561        return $retVal;
2562    }
2563    
2564    =head3 RunTimeColumns
2565    
2566    C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2567    
2568    Return the HTML text for a run-time column. Run-time columns are evaluated when the
2569    list is displayed, rather than when it is generated.
2570    
2571    =over 4
2572    
2573    =item type
2574    
2575    Type of column.
2576    
2577    =item text
2578    
2579    Data relevant to this row of the column.
2580    
2581    =item RETURN
2582    
2583    Returns the fully-formatted HTML text to go in the specified column.
2584    
2585    =back
2586    
2587    =cut
2588    
2589    sub RunTimeColumns {
2590        # Get the parameters.
2591        my ($self, $type, $text) = @_;
2592        # Declare the return variable.
2593        my $retVal = "";
2594        # Get the Sprout and CGI objects.
2595        my $sprout = $self->DB();
2596        my $cgi = $self->Q();
2597        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2598        # Separate the text into a type and data.
2599        if ($type eq 'alias') {
2600            # Here the caller wants external alias links for a feature. The text
2601            # parameter for computing the alias is the feature ID followed by
2602            # the favored alias type.
2603            my ($fid, $favored) = split /\s*,\s*/, $text;
2604            # The complicated part is we have to hyperlink them and handle the
2605            # favorites. First, get the aliases.
2606            Trace("Generating aliases for feature $fid.") if T(4);
2607            my @aliases = sort $sprout->FeatureAliases($fid);
2608            # Only proceed if we found some.
2609            if (@aliases) {
2610                # Split the aliases into favored and unfavored.
2611                my @favored = ();
2612                my @unfavored = ();
2613                for my $alias (@aliases) {
2614                    # Use substr instead of pattern match because $favored is specified by the user
2615                    # and we don't want him to put funny meta-characters in there.
2616                    if (substr($alias, 0, length($favored)) eq $favored) {
2617                        push @favored, $alias;
2618                    } else {
2619                        push @unfavored, $alias;
2620                    }
2621                }
2622                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2623                my $aliasList = join(", ", @favored, @unfavored);
2624                # Ask the HTML processor to hyperlink them.
2625                $retVal = HTML::set_prot_links($cgi, $aliasList);
2626            }
2627        } elsif ($type eq 'subsystem') {
2628            # Here the caller wants the subsystems in which this feature participates.
2629            # The text is the feature ID. We will list the subsystem names with links
2630            # to the subsystem's summary page.
2631            my $fid = $text;
2632            # Get the subsystems.
2633            Trace("Generating subsystems for feature $fid.") if T(4);
2634            my %subs = $sprout->SubsystemsOf($fid);
2635            # Extract the subsystem names.
2636            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2637            # String them into a list.
2638            $retVal = join(", ", @names);
2639        } elsif ($type =~ /^keyword:(.+)$/) {
2640            # Here the caller wants the value of the named keyword. The text is the
2641            # feature ID.
2642            my $keywordName = $1;
2643            my $fid = $text;
2644            # Get the attribute values.
2645            Trace("Getting $keywordName values for feature $fid.") if T(4);
2646            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2647                                          "Feature($keywordName)");
2648            # String them into a list.
2649            $retVal = join(", ", @values);
2650      }      }
2651      # Return the result.      # Return the result.
2652      return $retVal;      return $retVal;
2653  }  }
2654    
2655    =head3 SaveOrganismData
2656    
2657    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2658    
2659    Format the name of an organism and the display version of its group name. The incoming
2660    data should be the relevant fields from the B<Genome> record in the database. The
2661    data will also be stored in the genome cache for later use in posting search results.
2662    
2663    =over 4
2664    
2665    =item group
2666    
2667    Name of the genome's group as it appears in the database.
2668    
2669    =item genomeID
2670    
2671    ID of the relevant genome.
2672    
2673    =item genus
2674    
2675    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2676    in the database. In this case, the organism name is derived from the genomeID and the group
2677    is automatically the supporting-genomes group.
2678    
2679    =item species
2680    
2681    Species of the genome's organism.
2682    
2683    =item strain
2684    
2685    Strain of the species represented by the genome.
2686    
2687    =item RETURN
2688    
2689    Returns a two-element list. The first element is the formatted genome name. The second
2690    element is the display name of the genome's group.
2691    
2692    =back
2693    
2694    =cut
2695    
2696    sub SaveOrganismData {
2697        # Get the parameters.
2698        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2699        # Declare the return values.
2700        my ($name, $displayGroup);
2701        # If the organism does not exist, format an unknown name and a blank group.
2702        if (! defined($genus)) {
2703            $name = "Unknown Genome $genomeID";
2704            $displayGroup = "";
2705        } else {
2706            # It does exist, so format the organism name.
2707            $name = "$genus $species";
2708            if ($strain) {
2709                $name .= " $strain";
2710            }
2711            # Compute the display group. This is currently the same as the incoming group
2712            # name unless it's the supporting group, which is nulled out.
2713            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2714        }
2715        # Cache the group and organism data.
2716        my $cache = $self->{orgs};
2717        $cache->{$genomeID} = [$name, $displayGroup];
2718        # Return the result.
2719        return ($name, $displayGroup);
2720    }
2721    
2722    =head3 ValidateKeywords
2723    
2724    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2725    
2726    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2727    set.
2728    
2729    =over 4
2730    
2731    =item keywordString
2732    
2733    Keyword string specified as a parameter to the current search.
2734    
2735    =item required
2736    
2737    TRUE if there must be at least one keyword specified, else FALSE.
2738    
2739    =item RETURN
2740    
2741    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2742    is acceptable if the I<$required> parameter is not specified.
2743    
2744    =back
2745    
2746    =cut
2747    
2748    sub ValidateKeywords {
2749        # Get the parameters.
2750        my ($self, $keywordString, $required) = @_;
2751        # Declare the return variable.
2752        my $retVal = 0;
2753        my @wordList = split /\s+/, $keywordString;
2754        # Right now our only real worry is a list of all minus words. The problem with it is that
2755        # it will return an incorrect result.
2756        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2757        if (! @wordList) {
2758            if ($required) {
2759                $self->SetMessage("No search words specified.");
2760            } else {
2761                $retVal = 1;
2762            }
2763        } elsif (! @plusWords) {
2764            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2765        } else {
2766            $retVal = 1;
2767        }
2768        # Return the result.
2769        return $retVal;
2770    }
2771    
2772    =head3 FakeButton
2773    
2774    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2775    
2776    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2777    Unlike a real button, this one won't visibly click, but it will take the user to the
2778    correct place.
2779    
2780    The parameters of this method are deliberately identical to L</Formlet> so that we
2781    can switch easily from real buttons to fake ones in the code.
2782    
2783    =over 4
2784    
2785    =item caption
2786    
2787    Caption to be put on the button.
2788    
2789    =item url
2790    
2791    URL for the target page or script.
2792    
2793    =item target
2794    
2795    Frame or target in which the new page should appear. If C<undef> is specified,
2796    the default target will be used.
2797    
2798    =item parms
2799    
2800    Hash containing the parameter names as keys and the parameter values as values.
2801    These will be appended to the URL.
2802    
2803    =back
2804    
2805    =cut
2806    
2807    sub FakeButton {
2808        # Get the parameters.
2809        my ($caption, $url, $target, %parms) = @_;
2810        # Declare the return variable.
2811        my $retVal;
2812        # Compute the target URL.
2813        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2814        # Compute the target-frame HTML.
2815        my $targetHtml = ($target ? " target=\"$target\"" : "");
2816        # Assemble the result.
2817        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2818    }
2819    
2820    =head3 Formlet
2821    
2822    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
2823    
2824    Create a mini-form that posts to the specified URL with the specified parameters. The
2825    parameters will be stored in hidden fields, and the form's only visible control will
2826    be a submit button with the specified caption.
2827    
2828    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
2829    and tags that we don't want to deal with.
2830    
2831    =over 4
2832    
2833    =item caption
2834    
2835    Caption to be put on the form button.
2836    
2837    =item url
2838    
2839    URL to be put in the form's action parameter.
2840    
2841    =item target
2842    
2843    Frame or target in which the form results should appear. If C<undef> is specified,
2844    the default target will be used.
2845    
2846    =item parms
2847    
2848    Hash containing the parameter names as keys and the parameter values as values.
2849    
2850    =back
2851    
2852    =cut
2853    
2854    sub Formlet {
2855        # Get the parameters.
2856        my ($caption, $url, $target, %parms) = @_;
2857        # Compute the target HTML.
2858        my $targetHtml = ($target ? " target=\"$target\"" : "");
2859        # Start the form.
2860        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
2861        # Add the parameters.
2862        for my $parm (keys %parms) {
2863            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
2864        }
2865        # Put in the button.
2866        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
2867        # Close the form.
2868        $retVal .= "</form>";
2869        # Return the result.
2870        return $retVal;
2871    }
2872    
2873    =head3 TuningParameters
2874    
2875    C<< my $options = $shelp->TuningParameters(%parmHash); >>
2876    
2877    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2878    to their default values. The parameters and their values will be returned as a hash reference.
2879    
2880    =over 4
2881    
2882    =item parmHash
2883    
2884    Hash mapping parameter names to their default values.
2885    
2886    =item RETURN
2887    
2888    Returns a reference to a hash containing the parameter names mapped to their actual values.
2889    
2890    =back
2891    
2892    =cut
2893    
2894    sub TuningParameters {
2895        # Get the parameters.
2896        my ($self, %parmHash) = @_;
2897        # Declare the return variable.
2898        my $retVal = {};
2899        # Get the CGI Query Object.
2900        my $cgi = $self->Q();
2901        # Loop through the parameter names.
2902        for my $parm (keys %parmHash) {
2903            # Get the incoming value for this parameter.
2904            my $value = $cgi->param($parm);
2905            # Zero might be a valid value, so we do an is-defined check rather than an OR.
2906            if (defined($value)) {
2907                $retVal->{$parm} = $value;
2908            } else {
2909                $retVal->{$parm} = $parmHash{$parm};
2910            }
2911        }
2912        # Return the result.
2913        return $retVal;
2914    }
2915    
2916    =head2 Virtual Methods
2917    
2918    =head3 Form
2919    
2920    C<< my $html = $shelp->Form(); >>
2921    
2922    Generate the HTML for a form to request a new search.
2923    
2924    =head3 Find
2925    
2926    C<< my $resultCount = $shelp->Find(); >>
2927    
2928    Conduct a search based on the current CGI query parameters. The search results will
2929    be written to the session cache file and the number of results will be
2930    returned. If the search parameters are invalid, a result count of C<undef> will be
2931    returned and a result message will be stored in this object describing the problem.
2932    
2933    =head3 Description
2934    
2935    C<< my $htmlText = $shelp->Description(); >>
2936    
2937    Return a description of this search. The description is used for the table of contents
2938    on the main search tools page. It may contain HTML, but it should be character-level,
2939    not block-level, since the description is going to appear in a list.
2940    
2941    =head3 SortKey
2942    
2943    C<< my $key = $shelp->SortKey($fdata); >>
2944    
2945    Return the sort key for the specified feature data. The default is to sort by feature name,
2946    floating NMPDR organisms to the top. If a full-text search is used, then the default
2947    sort is by relevance followed by feature name. This sort may be overridden by the
2948    search class to provide fancier functionality. This method is called by
2949    B<PutFeature>, so it is only used for feature searches. A non-feature search
2950    would presumably have its own sort logic.
2951    
2952    =over 4
2953    
2954    =item record
2955    
2956    The C<FeatureData> containing the current feature.
2957    
2958    =item RETURN
2959    
2960    Returns a key field that can be used to sort this row in among the results.
2961    
2962    =back
2963    
2964    =cut
2965    
2966    sub SortKey {
2967        # Get the parameters.
2968        my ($self, $fdata) = @_;
2969        # Get the feature ID from the record.
2970        my $fid = $fdata->FID();
2971        # Get the group from the feature ID.
2972        my $group = $self->FeatureGroup($fid);
2973        # Ask the feature query object to form the sort key.
2974        my $retVal = $fdata->SortKey($self, $group);
2975        # Return the result.
2976        return $retVal;
2977    }
2978    
2979    =head3 PrintLine
2980    
2981    C<< $shelp->PrintLine($message); >>
2982    
2983    Print a line of CGI output. This is used during the operation of the B<Find> method while
2984    searching, so the user sees progress in real-time.
2985    
2986    =over 4
2987    
2988    =item message
2989    
2990    HTML text to display.
2991    
2992    =back
2993    
2994    =cut
2995    
2996    sub PrintLine {
2997        # Get the parameters.
2998        my ($self, $message) = @_;
2999        # Send them to the output.
3000        print "$message\n";
3001    }
3002    
3003    
3004  1;  1;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.30

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3