[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.24, Fri Dec 15 03:27:20 2006 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    =back
92    
93    =head2 Adding a new Search Tool
94    
95    To add a new search tool to the system, you must
96    
97    =over 4
98    
99    =item 1
100    
101    Choose a class name for your search tool.
102    
103    =item 2
104    
105    Create a new subclass of this object and implement each of the virtual methods. The
106    name of the subclass must be C<SH>I<className>.
107    
108    =item 3
109    
110    Create an include file among the web server pages that describes how to use
111    the search tool. The include file must be in the B<includes> directory, and
112    its name must be C<SearchHelp_>I<className>C<.inc>.
113    
114    =item 4
115    
116    In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
117    
118    =back
119    
120    =head3 Building a Search Form
121    
122    All search forms are three-column tables. In general, you want one form
123    variable per table row. The first column should contain the label and
124    the second should contain the form control for specifying the variable
125    value. If the control is wide, you should use C<colspan="2"> to give it
126    extra room. B<Do not> specify a width in any of your table cells, as
127    width management is handled by this class.
128    
129    The general code for creating the form should be
130    
131        sub Form {
132            my ($self) = @_;
133            # Get the CGI object.
134            my $cgi = @self->Q();
135            # Start the form.
136            my $retVal = $self->FormStart("form title");
137            # Assemble the table rows.
138            my @rows = ();
139            ... push table row Html into @rows ...
140            push @rows, $self->SubmitRow();
141            ... push more Html into @rows ...
142            # Build the table from the rows.
143            $retVal .= $self->MakeTable(\@rows);
144            # Close the form.
145            $retVal .= $self->FormEnd();
146            # Return the form Html.
147            return $retVal;
148        }
149    
150    Several helper methods are provided for particular purposes.
151    
152    =over 4
153    
154    =item 1
155    
156    L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
157    L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
158    name. Note that as an assist to people working with GET-style links, if no
159    genomes are specified and the incoming request style is GET, all genomes will
160    be returned.
161    
162    =item 2
163    
164    L</FeatureFilterRow> formats several rows of controls for filtering features.
165    When you start building the code for the L</Find> method, you can use a
166    B<FeatureQuery> object to automatically filter each genome's features using
167    the values from the filter controls.
168    
169    =item 3
170    
171    L</QueueFormScript> allows you to queue JavaScript statements for execution
172    after the form is fully generated. If you are using very complicated
173    form controls, the L</QueueFormScript> method allows you to perform
174    JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
175    facility to display a list of the pre-selected genomes.
176    
177  =back  =back
178    
179    If you are doing a feature search, you can also change the list of feature
180    columns displayed and their display order by overriding
181    L</DefaultFeatureColumns>.
182    
183    Finally, when generating the code for your controls, be sure to use any incoming
184    query parameters as default values so that the search request is persistent.
185    
186    =head3 Finding Search Results
187    
188    The L</Find> method is used to create the search results. For a search that
189    wants to return features (which is most of them), the basic code structure
190    would work as follows. It is assumed that the L</FeatureFilterRows> method
191    has been used to create feature filtering parameters.
192    
193        sub Find {
194            my ($self) = @_;
195            # Get the CGI and Sprout objects.
196            my $cgi = $self->Q();
197            my $sprout = $self->DB();
198            # Declare the return variable. If it remains undefined, the caller will
199            # know that an error occurred.
200            my $retVal;
201            ... validate the parameters ...
202            if (... invalid parameters...) {
203                $self->SetMessage(...appropriate message...);
204            } elsif (FeatureQuery::Valid($self)) {
205                # Initialize the session file.
206                $self->OpenSession();
207                # Initialize the result counter.
208                $retVal = 0;
209                ... get a list of genomes ...
210                for my $genomeID (... each genome ...) {
211                    my $fq = FeatureQuery->new($self, $genomeID);
212                    while (my $feature = $fq->Fetch()) {
213                        ... examine the feature ...
214                        if (... we want to keep it ...) {
215                            $self->PutFeature($fq);
216                            $retVal++;
217                        }
218                    }
219                }
220                # Close the session file.
221                $self->CloseSession();
222            }
223            # Return the result count.
224            return $retVal;
225        }
226    
227    A Find method is of course much more complicated than generating a form, and there
228    are variations on the above theme. For example, you could eschew feature filtering
229    entirely in favor of your own custom filtering, you could include extra columns
230    in the output, or you could search for something that's not a feature at all. The
231    above code is just a loose framework.
232    
233    If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
234    method of the feature query object.
235    
236        $fq->AddExtraColumns(score => $sc);
237    
238    The L</Find> method must return C<undef> if the search parameters are invalid. If this
239    is the case, then a message describing the problem should be passed to the framework
240    by calling L</SetMessage>. If the parameters are valid, then the method must return
241    the number of items found.
242    
243  =cut  =cut
244    
245  # 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.
246  my $formCount = 0;  my $formCount = 0;
247    # This counter is used to generate unique DIV IDs.
248    my $divCount = 0;
249    
250  =head2 Public Methods  =head2 Public Methods
251    
# Line 89  Line 257 
257    
258  =over 4  =over 4
259    
260  =item query  =item cgi
261    
262  The CGI query object for the current script.  The CGI query object for the current script.
263    
# Line 99  Line 267 
267    
268  sub new {  sub new {
269      # Get the parameters.      # Get the parameters.
270      my ($class, $query) = @_;      my ($class, $cgi) = @_;
271      # Check for a session ID.      # Check for a session ID.
272      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
273      my $type = "old";      my $type = "old";
274      if (! $session_id) {      if (! $session_id) {
275          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
276          # store it in the query object.          # store it in the query object.
277          $session_id = NewSessionID();          $session_id = NewSessionID();
278          $type = "new";          $type = "new";
279          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
280      }      }
281      # Compute the subclass name.      # Compute the subclass name.
282      $class =~ /SH(.+)$/;      my $subClass;
283      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
284      # Create the Sprout object.          # Here we have a real search class.
285      my $sprout = SFXlate->new_sprout_only();          $subClass = $1;
286        } else {
287            # Here we have a bare class. The bare class cannot search, but it can
288            # process search results.
289            $subClass = 'SearchHelper';
290        }
291      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
292      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
293      # Generate the form name.      # Generate the form name.
294      my $formName = "$class$formCount";      my $formName = "$class$formCount";
295      $formCount++;      $formCount++;
296      # 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)
297      # 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
298      # class name and the Sprout object.      # class name and a placeholder for the Sprout object.
299      my $retVal = {      my $retVal = {
300                    query => $query,                    query => $cgi,
301                    type => $type,                    type => $type,
302                    class => $subClass,                    class => $subClass,
303                    sprout => $sprout,                    sprout => undef,
304                    orgs => {},                    orgs => {},
305                    name => $formName,                    name => $formName,
306                    scriptQueue => [],                    scriptQueue => [],
307                      genomeList => undef,
308                      genomeParms => [],
309                      filtered => 0,
310                   };                   };
311      # Bless and return it.      # Bless and return it.
312      bless $retVal, $class;      bless $retVal, $class;
# Line 152  Line 328 
328      return $self->{query};      return $self->{query};
329  }  }
330    
331    
332    
333  =head3 DB  =head3 DB
334    
335  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 163  Line 341 
341  sub DB {  sub DB {
342      # Get the parameters.      # Get the parameters.
343      my ($self) = @_;      my ($self) = @_;
344        # Insure we have a database.
345        my $retVal = $self->{sprout};
346        if (! defined $retVal) {
347            $retVal = SFXlate->new_sprout_only();
348            $self->{sprout} = $retVal;
349        }
350      # Return the result.      # Return the result.
351      return $self->{sprout};      return $retVal;
352  }  }
353    
354  =head3 IsNew  =head3 IsNew
# Line 277  Line 461 
461      my ($self, $title) = @_;      my ($self, $title) = @_;
462      # Get the CGI object.      # Get the CGI object.
463      my $cgi = $self->Q();      my $cgi = $self->Q();
464      # Start the form.      # Start the form. Note we use the override option on the Class value, in
465        # case the Advanced button was used.
466      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
467                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
468                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
469                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
470                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
471                                -value => $self->{class}) .                                -value => $self->{class},
472                                  -override => 1) .
473                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
474                                -value => 1) .                                -value => 1) .
475                   $cgi->h3($title);                   $cgi->h3($title);
# Line 437  Line 623 
623    
624  =head3 PutFeature  =head3 PutFeature
625    
626  C<< $shelp->PutFeature($record, %extraCols); >>  C<< $shelp->PutFeature($fdata); >>
627    
628  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
629  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
630    
631  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
632  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
633  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
634  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
635  essentiality and virulence.  code adds columns for essentiality and virulence.
636    
637      $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
638        $shelp->PutFeature($fd);
639    
640  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
641  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 645 
645      if (! $essentialFlag) {      if (! $essentialFlag) {
646          $essentialFlag = undef;          $essentialFlag = undef;
647      }      }
648      $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
649        $shelp->PutFeature($fd);
650    
651  =over 4  =over 4
652    
653  =item record  =item fdata
   
 DBObject record for the feature.  
654    
655  =item extraCols  B<FeatureData> object containing the current feature data.
656    
657  =back  =back
658    
659  =cut  =cut
660    
661  sub PutFeature {  sub PutFeature {
662      # Get the parameters. Note that the extra columns are read in as a list      # Get the parameters.
663      # instead of a hash so that the column order is preserved.      my ($self, $fd) = @_;
664      my ($self, $record, @extraColList) = @_;      # Get the CGI query object.
665        my $cgi = $self->Q();
666        # Get the feature data.
667        my $record = $fd->Feature();
668        my $extraCols = $fd->ExtraCols();
669      # Check for a first-call situation.      # Check for a first-call situation.
670      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
671          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
672          $self->{cols} = $self->DefaultFeatureColumns();          # Here we need to set up the column information. Start with the extras,
673          # Append the extras. Note we proceed by twos because the columns are          # sorted by column name.
674          # specified in the form name => value.          my @colNames = ();
675          for (my $i = 0; $i <= $#extraColList; $i += 2) {          for my $col (sort keys %{$extraCols}) {
676              push @{$self->{cols}}, "X=$extraColList[$i]";              push @colNames, "X=$col";
677          }          }
678            # Add the default columns.
679            push @colNames, $self->DefaultFeatureColumns();
680            # Add any additional columns requested by the feature filter.
681            push @colNames, FeatureQuery::AdditionalColumns($self);
682            Trace("Full column list determined.") if T(3);
683            # Save the full list.
684            $self->{cols} = \@colNames;
685          # Write out the column headers. This also prepares the cache file to receive          # Write out the column headers. This also prepares the cache file to receive
686          # output.          # output.
687            Trace("Writing column headers.") if T(3);
688          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
689            Trace("Column headers written.") if T(3);
690      }      }
691      # Get the feature ID.      # Get the feature ID.
692      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
     # Now we process the columns themselves. First, convert the extra column list  
     # to a hash.  
     my %extraCols = @extraColList;  
693      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data.
694      my @output = ();      my @output = ();
695      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
696          push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
697      }      }
698      # 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
699      # top of the return list.      # top of the return list.
700      my $group = $self->FeatureGroup($fid);      my $key = $self->SortKey($fd);
     my $key = ($group ? "A$group" : "ZZ");  
701      # Write the feature data.      # Write the feature data.
702      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
703  }  }
# Line 583  Line 778 
778      # Check for an open session file.      # Check for an open session file.
779      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
780          # We found one, so close it.          # We found one, so close it.
781            Trace("Closing session file.") if T(2);
782          close $self->{fileHandle};          close $self->{fileHandle};
783      }      }
784  }  }
# Line 600  Line 796 
796      my $retVal;      my $retVal;
797      # Get a digest encoder.      # Get a digest encoder.
798      my $md5 = Digest::MD5->new();      my $md5 = Digest::MD5->new();
799      # 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
800      if (open(R, "/dev/urandom")) {      # actually two numbers, and we get them both because we're in list
801          my $b;      # context.
802          read(R, $b, 1024);      $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
803          $md5->add($b);      # Hash up all this identifying data.
804      }      $retVal = $md5->hexdigest();
805      # 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.  
806      return $retVal;      return $retVal;
807  }  }
808    
# Line 656  Line 846 
846                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
847                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
848                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
849          # Null out the supporting group.          # Format and cache the name and display group.
850          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
851          # 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];  
852      }      }
853      # Return the result.      # Return the result.
854      return ($orgName, $group);      return ($orgName, $group);
# Line 771  Line 950 
950      } else {      } else {
951          # Here we can get its genome data.          # Here we can get its genome data.
952          $retVal = $self->Organism($genomeID);          $retVal = $self->Organism($genomeID);
953          # Append the type and number.          # Append the FIG ID.
954          $retVal .= " [$type $num]";          $retVal .= " [$fid]";
955      }      }
956      # Return the result.      # Return the result.
957      return $retVal;      return $retVal;
# Line 780  Line 959 
959    
960  =head3 ComputeFASTA  =head3 ComputeFASTA
961    
962  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>
963    
964  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.  
965    
966  =over 4  =over 4
967    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
968  =item desiredType  =item desiredType
969    
970  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.  
971    
972  =item sequence  =item sequence
973    
# Line 817  Line 989 
989    
990  sub ComputeFASTA {  sub ComputeFASTA {
991      # Get the parameters.      # Get the parameters.
992      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence) = @_;
993      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
994      my $retVal;      my $retVal;
995        # This variable will be cleared if an error is detected.
996        my $okFlag = 1;
997      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
998      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
999        Trace("FASTA desired type is $desiredType.") if T(4);
1000      # Check for a feature specification.      # Check for a feature specification.
1001      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1002          # 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
1003          # it.          # it.
1004          my $fid = $1;          my $fid = $1;
1005            Trace("Feature ID for fasta is $fid.") if T(3);
1006          my $sprout = $self->DB();          my $sprout = $self->DB();
1007          # 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
1008          # 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
1009          # exist.          # exist.
1010          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1011          if (! $figID) {          if (! $figID) {
1012              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1013                $okFlag = 0;
1014          } else {          } else {
1015              # Set the FASTA label.              # Set the FASTA label.
1016              my $fastaLabel = $fid;              my $fastaLabel = $fid;
1017              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1018              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1019                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1020                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1021                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1022              } else {              } else {
1023                  # 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.
1024                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1025                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1026                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1027              }              }
1028          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1029      } else {      } else {
1030            Trace("Analyzing FASTA sequence.") if T(4);
1031          # 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.
1032          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1033                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1034              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1035              $fastaLabel = $1;              $fastaLabel = $1;
1036              $fastaData = $2;              $fastaData = $2;
1037          } else {          } else {
1038                Trace("No label found in match to sequence:\n$sequence") if T(4);
1039              # 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
1040              # as data.              # as data.
1041              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1042              $fastaData = $sequence;              $fastaData = $sequence;
1043          }          }
1044          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1045          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1046          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1047          # 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.
1048          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1049          if ($incomingType ne $desiredType) {              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1050              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1051          }          }
1052      }      }
1053      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1054      # in progress.      # Only proceed if no error was detected.
1055      if (defined $fastaLabel) {      if ($okFlag) {
1056          # 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
1057          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1058          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1059          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1060          # the delimiters are what we want.          # the delimiters are what we want.
1061          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1062          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1063      }      }
1064      # Return the result.      # Return the result.
1065      return $retVal;      return $retVal;
1066  }  }
1067    
1068    =head3 SubsystemTree
1069    
1070    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1071    
1072    This method creates a subsystem selection tree suitable for passing to
1073    L</SelectionTree>. Each leaf node in the tree will have a link to the
1074    subsystem display page. In addition, each node can have a radio button. The
1075    radio button alue is either C<classification=>I<string>, where I<string> is
1076    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1077    Thus, it can either be used to filter by a group of related subsystems or a
1078    single subsystem.
1079    
1080    =over 4
1081    
1082    =item sprout
1083    
1084    Sprout database object used to get the list of subsystems.
1085    
1086    =item options
1087    
1088    Hash containing options for building the tree.
1089    
1090    =item RETURN
1091    
1092    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1093    
1094    =back
1095    
1096    The supported options are as follows.
1097    
1098    =over 4
1099    
1100    =item radio
1101    
1102    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1103    
1104    =item links
1105    
1106    TRUE if the tree should be configured for links. The default is TRUE.
1107    
1108    =back
1109    
1110    =cut
1111    
1112    sub SubsystemTree {
1113        # Get the parameters.
1114        my ($sprout, %options) = @_;
1115        # Process the options.
1116        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1117        # Read in the subsystems.
1118        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1119                                   ['Subsystem(classification)', 'Subsystem(id)']);
1120        # Declare the return variable.
1121        my @retVal = ();
1122        # Each element in @subs represents a leaf node, so as we loop through it we will be
1123        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1124        # first element is a semi-colon-delimited list of the classifications for the
1125        # subsystem. There will be a stack of currently-active classifications, which we will
1126        # compare to the incoming classifications from the end backward. A new classification
1127        # requires starting a new branch. A different classification requires closing an old
1128        # branch and starting a new one. Each classification in the stack will also contain
1129        # that classification's current branch. We'll add a fake classification at the
1130        # beginning that we can use to represent the tree as a whole.
1131        my $rootName = '<root>';
1132        # Create the classification stack. Note the stack is a pair of parallel lists,
1133        # one containing names and the other containing content.
1134        my @stackNames = ($rootName);
1135        my @stackContents = (\@retVal);
1136        # Add a null entry at the end of the subsystem list to force an unrolling.
1137        push @subs, ['', undef];
1138        # Loop through the subsystems.
1139        for my $sub (@subs) {
1140            # Pull out the classification list and the subsystem ID.
1141            my ($classString, $id) = @{$sub};
1142            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1143            # Convert the classification string to a list with the root classification in
1144            # the front.
1145            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1146            # Find the leftmost point at which the class list differs from the stack.
1147            my $matchPoint = 0;
1148            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1149                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1150                $matchPoint++;
1151            }
1152            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1153                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1154            # Unroll the stack to the matchpoint.
1155            while ($#stackNames >= $matchPoint) {
1156                my $popped = pop @stackNames;
1157                pop @stackContents;
1158                Trace("\"$popped\" popped from stack.") if T(4);
1159            }
1160            # Start branches for any new classifications.
1161            while ($#stackNames < $#classList) {
1162                # The branch for a new classification contains its radio button
1163                # data and then a list of children. So, at this point, if radio buttons
1164                # are desired, we put them into the content.
1165                my $newLevel = scalar(@stackNames);
1166                my @newClassContent = ();
1167                if ($optionThing->{radio}) {
1168                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1169                    push @newClassContent, { value => "classification=$newClassString%" };
1170                }
1171                # The new classification node is appended to its parent's content
1172                # and then pushed onto the stack. First, we need the node name.
1173                my $nodeName = $classList[$newLevel];
1174                # Add the classification to its parent. This makes it part of the
1175                # tree we'll be returning to the user.
1176                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1177                # Push the classification onto the stack.
1178                push @stackContents, \@newClassContent;
1179                push @stackNames, $nodeName;
1180                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1181            }
1182            # Now the stack contains all our parent branches. We add the subsystem to
1183            # the branch at the top of the stack, but only if it's NOT the dummy node.
1184            if (defined $id) {
1185                # Compute the node name from the ID.
1186                my $nodeName = $id;
1187                $nodeName =~ s/_/ /g;
1188                # Create the node's leaf hash. This depends on the value of the radio
1189                # and link options.
1190                my $nodeContent = {};
1191                if ($optionThing->{links}) {
1192                    # Compute the link value.
1193                    my $linkable = uri_escape($id);
1194                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";
1195                }
1196                if ($optionThing->{radio}) {
1197                    # Compute the radio value.
1198                    $nodeContent->{value} = "id=$id";
1199                }
1200                # Push the node into its parent branch.
1201                Trace("\"$nodeName\" added to node list.") if T(4);
1202                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1203            }
1204        }
1205        # Return the result.
1206        return \@retVal;
1207    }
1208    
1209    
1210  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1211    
1212  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1213    
1214  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
1215  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 1221 
1221    
1222  Name to give to the menu.  Name to give to the menu.
1223    
1224  =item options  =item multiple
1225    
1226  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.  
1227    
1228  =item selected  =item selected
1229    
# Line 913  Line 1231 
1231  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
1232  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1233    
1234    =item rows (optional)
1235    
1236    Number of rows to display. If omitted, the default is 1 for a single-select list
1237    and 10 for a multi-select list.
1238    
1239    =item crossMenu (optional)
1240    
1241    If specified, is presumed to be the name of another genome menu whose contents
1242    are to be mutually exclusive with the contents of this menu. As a result, instead
1243    of the standard onChange event, the onChange event will deselect any entries in
1244    the other menu.
1245    
1246  =item RETURN  =item RETURN
1247    
1248  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 1253 
1253    
1254  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1255      # Get the parameters.      # Get the parameters.
1256      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1257      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1258      my $sprout = $self->DB();      my $sprout = $self->DB();
1259      my $cgi = $self->Q();      my $cgi = $self->Q();
1260        # Compute the row count.
1261        if (! defined $rows) {
1262            $rows = ($multiple ? 10 : 1);
1263        }
1264        # Create the multiple tag.
1265        my $multipleTag = ($multiple ? " multiple" : "");
1266      # Get the form name.      # Get the form name.
1267      my $formName = $self->FormName();      my $formName = $self->FormName();
1268        # Check to see if we already have a genome list in memory.
1269        my $genomes = $self->{genomeList};
1270        my $groupHash;
1271        if (defined $genomes) {
1272            # We have a list ready to use.
1273            $groupHash = $genomes;
1274        } else {
1275      # 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
1276      # 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
1277      # take advantage of an existing index.      # take advantage of an existing index.
# Line 940  Line 1283 
1283      # 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
1284      # 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
1285      # name.      # name.
1286      my %groupHash = ();          my %gHash = ();
1287      for my $genome (@genomeList) {      for my $genome (@genomeList) {
1288          # Get the genome data.          # Get the genome data.
1289          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1290          # Form the genome name.              # Compute and cache its name and display group.
1291          my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1292          if ($strain) {                                                                  $strain);
1293              $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1294          }              # name here, not the display group name.
1295          # Push the genome into the group's list.              push @{$gHash{$group}}, [$genomeID, $name];
1296          push @{$groupHash{$group}}, [$genomeID, $name];          }
1297            # Save the genome list for future use.
1298            $self->{genomeList} = \%gHash;
1299            $groupHash = \%gHash;
1300      }      }
1301      # 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
1302      # the supporting-genome group last.      # the supporting-genome group last.
1303      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1304      push @groups, $FIG_Config::otherGroup;      push @groups, $FIG_Config::otherGroup;
1305      # 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
1306      my %selectedHash = map { $_ => 1 } @{$selected};      # with the possibility of undefined values in the incoming list.
1307      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      my %selectedHash = ();
1308        if (defined $selected) {
1309            %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1310        }
1311        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1312        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1313        # and use that to make the selections.
1314        my $nmpdrCount = 0;
1315      # Create the type counters.      # Create the type counters.
1316      my $groupCount = 1;      my $groupCount = 1;
1317      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 967  Line 1320 
1320      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1321      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1322      my $onChange = "";      my $onChange = "";
1323      if ($options->{multiple}) {      if ($cross) {
1324            # Here we have a paired menu. Selecting something in our menu unselects it in the
1325            # other and redisplays the status of both.
1326            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1327        } elsif ($multiple) {
1328            # This is an unpaired menu, so all we do is redisplay our status.
1329          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1330      }      }
1331      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1332      my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1333      # Loop through the groups.      # Loop through the groups.
1334      for my $group (@groups) {      for my $group (@groups) {
1335          # Create the option group tag.          # Create the option group tag.
1336          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1337          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");  
1338          # Get the genomes in the group.          # Get the genomes in the group.
1339          for my $genome (@{$groupHash{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1340                # Count this organism if it's NMPDR.
1341                if ($group ne $FIG_Config::otherGroup) {
1342                    $nmpdrCount++;
1343                }
1344                # Get the organism ID and name.
1345              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1346              # See if it's selected.              # See if it's selected.
1347              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1348              # Generate the option tag.              # Generate the option tag.
1349              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1350              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1351          }          }
1352          # Close the option group.          # Close the option group.
# Line 999  Line 1355 
1355      # Close the SELECT tag.      # Close the SELECT tag.
1356      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1357      # Check for multiple selection.      # Check for multiple selection.
1358      if ($options->{multiple}) {      if ($multiple) {
1359          # 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
1360            # the search box. This allows the user to type text and have all genomes containing
1361            # the text selected automatically.
1362            my $searchThingName = "${menuName}_SearchThing";
1363            push @lines, "<br />" .
1364                         "<INPUT type=\"button\" name=\"Search\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1365                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1366            # Next are the buttons to set and clear selections.
1367          push @lines, "<br />";          push @lines, "<br />";
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
1368          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\" />";
1369          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\" />";
1370          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\" />";
1371            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1372          # Add the status display, too.          # Add the status display, too.
1373          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1374          # 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 1377 
1377          # in case we decide to twiddle the parameters.          # in case we decide to twiddle the parameters.
1378          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1379          $self->QueueFormScript($showSelect);          $self->QueueFormScript($showSelect);
1380            # Finally, add this parameter to the list of genome parameters. This enables us to
1381            # easily find all the parameters used to select one or more genomes.
1382            push @{$self->{genomeParms}}, $menuName;
1383      }      }
1384      # Assemble all the lines into a string.      # Assemble all the lines into a string.
1385      my $retVal = join("\n", @lines, "");      my $retVal = join("\n", @lines, "");
# Line 1021  Line 1387 
1387      return $retVal;      return $retVal;
1388  }  }
1389    
1390    =head3 PropertyMenu
1391    
1392    C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1393    
1394    Generate a property name dropdown menu.
1395    
1396    =over 4
1397    
1398    =item menuName
1399    
1400    Name to give to the menu.
1401    
1402    =item selected
1403    
1404    Value of the property name to pre-select.
1405    
1406    =item force (optional)
1407    
1408    If TRUE, then the user will be forced to choose a property name. If FALSE,
1409    then an additional menu choice will be provided to select nothing.
1410    
1411    =item RETURN
1412    
1413    Returns a dropdown menu box that allows the user to select a property name. An additional
1414    selection entry will be provided for selecting no property name
1415    
1416    =back
1417    
1418    =cut
1419    
1420    sub PropertyMenu {
1421        # Get the parameters.
1422        my ($self, $menuName, $selected, $force) = @_;
1423        # Get the CGI and Sprout objects.
1424        my $sprout = $self->DB();
1425        my $cgi = $self->Q();
1426        # Create the property name list.
1427        my @propNames = ();
1428        if (! $force) {
1429            push @propNames, "";
1430        }
1431        # Get all the property names, putting them after the null choice if one exists.
1432        push @propNames, $sprout->GetChoices('Property', 'property-name');
1433        # Create a menu from them.
1434        my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1435                                      -default => $selected);
1436        # Return the result.
1437        return $retVal;
1438    }
1439    
1440  =head3 MakeTable  =head3 MakeTable
1441    
1442  C<< my $htmlText = $shelp->MakeTable(\@rows); >>  C<< my $htmlText = $shelp->MakeTable(\@rows); >>
# Line 1071  Line 1487 
1487    
1488  =head3 SubmitRow  =head3 SubmitRow
1489    
1490  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1491    
1492  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1493  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1494  near the top of the form.  near the top of the form.
1495    
1496    =over 4
1497    
1498    =item caption (optional)
1499    
1500    Caption to be put on the search button. The default is C<Go>.
1501    
1502    =item RETURN
1503    
1504    Returns a table row containing the controls for submitting the search
1505    and tuning the results.
1506    
1507    =back
1508    
1509  =cut  =cut
1510    
1511  sub SubmitRow {  sub SubmitRow {
1512      # Get the parameters.      # Get the parameters.
1513      my ($self) = @_;      my ($self, $caption) = @_;
1514      my $cgi = $self->Q();      my $cgi = $self->Q();
1515      # Declare the return variable.      # Compute the button caption.
1516        my $realCaption = (defined $caption ? $caption : 'Go');
1517        # Get the current page size.
1518        my $pageSize = $cgi->param('PageSize');
1519        # Get the incoming external-link flag.
1520        my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1521        # Create the row.
1522      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1523                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1524                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1525                                                      -default => $cgi->param('PageSize'))),                                                      -default => $pageSize) . " " .
1526                                       $cgi->checkbox(-name => 'ShowURL',
1527                                                      -value => 1,
1528                                                      -label => 'Show URL',
1529                                                      -checked => 1)),
1530                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1531                                                  -name => 'Search',                                                  -name => 'Search',
1532                                                  -value => 'Go')));                                                  -value => $realCaption)));
1533      # Return the result.      # Return the result.
1534      return $retVal;      return $retVal;
1535  }  }
1536    
1537    =head3 FeatureFilterRows
1538    
1539    C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1540    
1541    This method creates table rows that can be used to filter features. The form
1542    values can be used to select features by genome using the B<FeatureQuery>
1543    object.
1544    
1545    =cut
1546    
1547    sub FeatureFilterRows {
1548        # Get the parameters.
1549        my ($self) = @_;
1550        # Return the result.
1551        return FeatureQuery::FilterRows($self);
1552    }
1553    
1554  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
1555    
1556  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
# Line 1133  Line 1590 
1590          # Get the feature location string.          # Get the feature location string.
1591          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1592          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1593          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1594            Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1595          # 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
1596          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
1597          my $mid = int(($start + $stop) / 2);          my $mid = int(($start + $stop) / 2);
# Line 1163  Line 1621 
1621          }          }
1622          my $seg_id = $contig;          my $seg_id = $contig;
1623          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1624            Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1625          # Assemble all the pieces.          # Assemble all the pieces.
1626          $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";
1627      }      }
1628      # Return the result.      # Return the result.
1629      return $retVal;      return $retVal;
1630  }  }
1631    
1632  =head2 Feature Column Methods  =head3 GetGenomes
1633    
1634  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.  
1635    
1636  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.
1637  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
1638  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
1639  pulled from the extra column hash.  specified, then it is treated as a request for all genomes. This makes it
1640    easier for web pages to link to a search that wants to specify all genomes.
1641    
1642  =head3 DefaultFeatureColumns  =over 4
1643    
1644    =item parmName
1645    
1646  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Name of the parameter containing the list of genomes. This will be the
1647    first parameter passed to the L</NmpdrGenomeMenu> call that created the
1648    genome selection control on the form.
1649    
1650  Return a reference to a list of the default feature column identifiers. These  =item RETURN
1651  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
1652  order to produce the column titles and row values.  Returns a list of the genomes to process.
1653    
1654    =back
1655    
1656  =cut  =cut
1657    
1658  sub DefaultFeatureColumns {  sub GetGenomes {
1659        # Get the parameters.
1660        my ($self, $parmName) = @_;
1661        # Get the CGI query object.
1662        my $cgi = $self->Q();
1663        # Get the list of genome IDs in the request header.
1664        my @retVal = $cgi->param($parmName);
1665        Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1666        # Check for the special GET case.
1667        if ($cgi->request_method() eq "GET" && ! @retVal) {
1668            # Here the caller wants all the genomes.
1669            my $sprout = $self->DB();
1670            @retVal = $sprout->Genomes();
1671        }
1672        # Return the result.
1673        return @retVal;
1674    }
1675    
1676    =head3 GetHelpText
1677    
1678    C<< my $htmlText = $shelp->GetHelpText(); >>
1679    
1680    Get the help text for this search. The help text is stored in files on the template
1681    server. The help text for a specific search is taken from a file named
1682    C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1683    There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1684    feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1685    describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1686    describes the standard controls for a search, such as page size, URL display, and
1687    external alias display.
1688    
1689    =cut
1690    
1691    sub GetHelpText {
1692      # Get the parameters.      # Get the parameters.
1693      my ($self) = @_;      my ($self) = @_;
1694        # Create a list to hold the pieces of the help.
1695        my @helps = ();
1696        # Get the template directory URL.
1697        my $urlBase = $FIG_Config::template_url;
1698        # Start with the specific help.
1699        my $class = $self->{class};
1700        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1701        # Add the genome control help if needed.
1702        if (scalar @{$self->{genomeParms}}) {
1703            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1704        }
1705        # Next the filter help.
1706        if ($self->{filtered}) {
1707            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1708        }
1709        # Finally, the standard help.
1710        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1711        # Assemble the pieces.
1712        my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1713      # Return the result.      # Return the result.
1714      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
1715  }  }
1716    
1717  =head3 FeatureColumnTitle  =head3 ComputeSearchURL
1718    
1719  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1720    
1721  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
1722    must be a copy of the search form on the current page. This will always be the
1723    case if the search is coming from C<SearchSkeleton.cgi>.
1724    
1725    A little expense is involved in order to make the URL as smart as possible. The
1726    main complication is that if the user specified all genomes, we'll want to
1727    remove the parameter entirely from a get-style URL.
1728    
1729  =over 4  =over 4
1730    
1731  =item name  =item overrides
1732    
1733  Name of the desired feature column.  Hash containing override values for the parameters, where the parameter name is
1734    the key and the parameter value is the override value. If the override value is
1735    C<undef>, the parameter will be deleted from the result.
1736    
1737  =item RETURN  =item RETURN
1738    
1739  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.
1740    
1741  =back  =back
1742    
1743  =cut  =cut
1744    
1745  sub FeatureColumnTitle {  sub ComputeSearchURL {
1746      # Get the parameters.      # Get the parameters.
1747      my ($self, $colName) = @_;      my ($self, %overrides) = @_;
1748      # Declare the return variable. We default to a blank column name.      # Get the database and CGI query object.
1749      my $retVal = "&nbsp;";      my $cgi = $self->Q();
1750      # Process the column name.      my $sprout = $self->DB();
1751      if ($colName =~ /^X=(.+)$/) {      # Start with the full URL.
1752          # Here we have an extra column.      my $retVal = $cgi->url(-full => 1);
1753          $retVal = $1;      # Get all the query parameters in a hash.
1754      } elsif ($colName eq 'orgName') {      my %parms = $cgi->Vars();
1755          $retVal = "Name";      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1756      } elsif ($colName eq 'fid') {      # characters separating the individual values. We have to convert those to lists. In addition,
1757          $retVal = "FIG ID";      # the multiple-selection genome parameters and the feature type parameter must be checked to
1758      } elsif ($colName eq 'alias') {      # determine whether or not they can be removed from the URL. First, we get a list of the
1759          $retVal = "External Aliases";      # genome parameters and a list of all genomes. Note that we only need the list if a
1760      } elsif ($colName eq 'function') {      # multiple-selection genome parameter has been found on the form.
1761          $retVal = "Functional Assignment";      my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1762      } elsif ($colName eq 'gblink') {      my @genomeList;
1763          $retVal = "GBrowse";      if (keys %genomeParms) {
1764      } elsif ($colName eq 'protlink') {          @genomeList = $sprout->Genomes();
1765          $retVal = "NMPDR Protein Page";      }
1766      } elsif ($colName eq 'group') {      # Create a list to hold the URL parameters we find.
1767          $retVal = "NMDPR Group";      my @urlList = ();
1768        # Now loop through the parameters in the hash, putting them into the output URL.
1769        for my $parmKey (keys %parms) {
1770            # Get a list of the parameter values. If there's only one, we'll end up with
1771            # a singleton list, but that's okay.
1772            my @values = split (/\0/, $parms{$parmKey});
1773            # Check for special cases.
1774            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {
1775                # These are bookkeeping parameters we don't need to start a search.
1776                @values = ();
1777            } elsif ($parmKey =~ /_SearchThing$/) {
1778                # Here the value coming in is from a genome control's search thing. It does
1779                # not affect the results of the search, so we clear it.
1780                @values = ();
1781            } elsif ($genomeParms{$parmKey}) {
1782                # Here we need to see if the user wants all the genomes. If he does,
1783                # we erase all the values just like with features.
1784                my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1785                if ($allFlag) {
1786                    @values = ();
1787                }
1788            } elsif (exists $overrides{$parmKey}) {
1789                # Here the value is being overridden, so we skip it for now.
1790                @values = ();
1791            }
1792            # If we still have values, create the URL parameters.
1793            if (@values) {
1794                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1795            }
1796        }
1797        # Now do the overrides.
1798        for my $overKey (keys %overrides) {
1799            # Only use this override if it's not a delete marker.
1800            if (defined $overrides{$overKey}) {
1801                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1802      }      }
1803        }
1804        # Add the parameters to the URL.
1805        $retVal .= "?" . join(";", @urlList);
1806      # Return the result.      # Return the result.
1807      return $retVal;      return $retVal;
1808  }  }
1809    
1810  =head3 FeatureColumnValue  =head3 GetRunTimeValue
1811    
1812  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1813    
1814  Return the value to be displayed in the specified feature column.  Compute a run-time column value.
1815    
1816  =over 4  =over 4
1817    
1818  =item colName  =item text
   
 Name of the column to be displayed.  
   
 =item record  
   
 DBObject record for the feature being displayed in the current row.  
   
 =item extraCols  
1819    
1820  Reference to a hash of extra column names to values. If the incoming column name  The run-time column text. It consists of 2 percent signs, a column type, an equal
1821  begins with C<X=>, its value will be taken from this hash.  sign, and the data for the current row.
1822    
1823  =item RETURN  =item RETURN
1824    
1825  Returns the HTML to be displayed in the named column for the specified feature.  Returns the fully-formatted HTML text to go into the current column of the current row.
1826    
1827    =back
1828    
1829    =cut
1830    
1831    sub GetRunTimeValue {
1832        # Get the parameters.
1833        my ($self, $text) = @_;
1834        # Declare the return variable.
1835        my $retVal;
1836        # Parse the incoming text.
1837        if ($text =~ /^%%([^=]+)=(.*)$/) {
1838            $retVal = $self->RunTimeColumns($1, $2);
1839        } else {
1840            Confess("Invalid run-time column string \"$text\" encountered in session file.");
1841        }
1842        # Return the result.
1843        return $retVal;
1844    }
1845    
1846    =head3 AdvancedClassList
1847    
1848    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1849    
1850    Return a list of advanced class names. This list is used to generate the directory
1851    of available searches on the search page.
1852    
1853    We use the %INC variable to accomplish this.
1854    
1855    =cut
1856    
1857    sub AdvancedClassList {
1858        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1859        return @retVal;
1860    }
1861    
1862    =head3 SelectionTree
1863    
1864    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1865    
1866    Display a selection tree.
1867    
1868    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1869    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1870    addition, some of the tree nodes can contain hyperlinks.
1871    
1872    The tree itself is passed in as a multi-level list containing node names followed by
1873    contents. Each content element is a reference to a similar list. The first element of
1874    each list may be a hash reference. If so, it should contain one or both of the following
1875    keys.
1876    
1877    =over 4
1878    
1879    =item link
1880    
1881    The navigation URL to be popped up if the user clicks on the node name.
1882    
1883    =item value
1884    
1885    The form value to be returned if the user selects the tree node.
1886    
1887    =back
1888    
1889    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1890    a C<value> key indicates the node name will have a radio button. If a node has no children,
1891    you may pass it a hash reference instead of a list reference.
1892    
1893    The following example shows the hash for a three-level tree with links on the second level and
1894    radio buttons on the third.
1895    
1896        [   Objects => [
1897                Entities => [
1898                    {link => "../docs/WhatIsAnEntity.html"},
1899                    Genome => {value => 'GenomeData'},
1900                    Feature => {value => 'FeatureData'},
1901                    Contig => {value => 'ContigData'},
1902                ],
1903                Relationships => [
1904                    {link => "../docs/WhatIsARelationShip.html"},
1905                    HasFeature => {value => 'GenomeToFeature'},
1906                    IsOnContig => {value => 'FeatureToContig'},
1907                ]
1908            ]
1909        ]
1910    
1911    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1912    all have list references.
1913    
1914    This next example shows how to set up a taxonomy selection field. The value returned
1915    by the tree control will be the taxonomy string for the selected node ready for use
1916    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1917    reasons of space.
1918    
1919        [   All => [
1920                {value => "%"},
1921                Bacteria => [
1922                    {value => "Bacteria%"},
1923                    Proteobacteria => [
1924                        {value => "Bacteria; Proteobacteria%"},
1925                        Epsilonproteobacteria => [
1926                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1927                            Campylobacterales => [
1928                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1929                                Campylobacteraceae =>
1930                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1931                                ...
1932                            ]
1933                            ...
1934                        ]
1935                        ...
1936                    ]
1937                    ...
1938                ]
1939                ...
1940            ]
1941        ]
1942    
1943    
1944    This method of tree storage allows the caller to control the order in which the tree nodes
1945    are displayed and to completely control value selection and use of hyperlinks. It is, however
1946    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1947    
1948    The parameters to this method are as follows.
1949    
1950    =over 4
1951    
1952    =item cgi
1953    
1954    CGI object used to generate the HTML.
1955    
1956    =item tree
1957    
1958    Reference to a hash describing a tree. See the description above.
1959    
1960    =item options
1961    
1962    Hash containing options for the tree display.
1963    
1964    =back
1965    
1966    The allowable options are as follows
1967    
1968    =over 4
1969    
1970    =item nodeImageClosed
1971    
1972    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1973    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1974    
1975    =item nodeImageOpen
1976    
1977    URL of the image to display next to the tree nodes when they are expanded. Clicking
1978    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1979    
1980    =item style
1981    
1982    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1983    as nested lists, the key components of this style are the definitions for the C<ul> and
1984    C<li> tags. The default style file contains the following definitions.
1985    
1986        .tree ul {
1987           margin-left: 0; padding-left: 22px
1988        }
1989        .tree li {
1990            list-style-type: none;
1991        }
1992    
1993    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1994    parent by the width of the node image. This use of styles limits the things we can do in formatting
1995    the tree, but it has the advantage of vastly simplifying the tree creation.
1996    
1997    =item name
1998    
1999    Field name to give to the radio buttons in the tree. The default is C<selection>.
2000    
2001    =item target
2002    
2003    Frame target for links. The default is C<_self>.
2004    
2005    =item selected
2006    
2007    If specified, the value of the radio button to be pre-selected.
2008    
2009    =back
2010    
2011    =cut
2012    
2013    sub SelectionTree {
2014        # Get the parameters.
2015        my ($cgi, $tree, %options) = @_;
2016        # Get the options.
2017        my $optionThing = Tracer::GetOptions({ name => 'selection',
2018                                               nodeImageClosed => '../FIG/Html/plus.gif',
2019                                               nodeImageOpen => '../FIG/Html/minus.gif',
2020                                               style => 'tree',
2021                                               target => '_self',
2022                                               selected => undef},
2023                                             \%options);
2024        # Declare the return variable. We'll do the standard thing with creating a list
2025        # of HTML lines and rolling them together at the end.
2026        my @retVal = ();
2027        # Only proceed if the tree is present.
2028        if (defined($tree)) {
2029            # Validate the tree.
2030            if (ref $tree ne 'ARRAY') {
2031                Confess("Selection tree is not a list reference.");
2032            } elsif (scalar @{$tree} == 0) {
2033                # The tree is empty, so we do nothing.
2034            } elsif ($tree->[0] eq 'HASH') {
2035                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2036            } else {
2037                # Here we have a real tree. Apply the tree style.
2038                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2039                # Give us a DIV ID.
2040                my $divID = GetDivID($optionThing->{name});
2041                # Show the tree.
2042                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2043                # Close the DIV block.
2044                push @retVal, $cgi->end_div();
2045            }
2046        }
2047        # Return the result.
2048        return join("\n", @retVal, "");
2049    }
2050    
2051    =head3 ShowBranch
2052    
2053    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2054    
2055    This is a recursive method that displays a branch of the tree.
2056    
2057    =over 4
2058    
2059    =item cgi
2060    
2061    CGI object used to format HTML.
2062    
2063    =item label
2064    
2065    Label of this tree branch. It is only used in error messages.
2066    
2067    =item id
2068    
2069    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2070    tree nodes.
2071    
2072    =item branch
2073    
2074    Reference to a list containing the content of the tree branch. The list contains an optional
2075    hash reference that is ignored and the list of children, each child represented by a name
2076    and then its contents. The contents could by a hash reference (indicating the attributes
2077    of a leaf node), or another tree branch.
2078    
2079    =item options
2080    
2081    Options from the original call to L</SelectionTree>.
2082    
2083    =item displayType
2084    
2085    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2086    hidden.
2087    
2088    =item RETURN
2089    
2090    Returns one or more HTML lines that can be used to display the tree branch.
2091    
2092    =back
2093    
2094    =cut
2095    
2096    sub ShowBranch {
2097        # Get the parameters.
2098        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2099        # Declare the return variable.
2100        my @retVal = ();
2101        # Start the branch.
2102        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2103        # Check for the hash and choose the start location accordingly.
2104        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2105        # Get the list length.
2106        my $i1 = scalar(@{$branch});
2107        # Verify we have an even number of elements.
2108        if (($i1 - $i0) % 2 != 0) {
2109            Trace("Branch elements are from $i0 to $i1.") if T(3);
2110            Confess("Odd number of elements in tree branch $label.");
2111        } else {
2112            # Loop through the elements.
2113            for (my $i = $i0; $i < $i1; $i += 2) {
2114                # Get this node's label and contents.
2115                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2116                # Get an ID for this node's children (if any).
2117                my $myID = GetDivID($options->{name});
2118                # Now we need to find the list of children and the options hash.
2119                # This is a bit ugly because we allow the shortcut of a hash without an
2120                # enclosing list. First, we need some variables.
2121                my $attrHash = {};
2122                my @childHtml = ();
2123                my $hasChildren = 0;
2124                if (! ref $myContent) {
2125                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2126                } elsif (ref $myContent eq 'HASH') {
2127                    # Here the node is a leaf and its content contains the link/value hash.
2128                    $attrHash = $myContent;
2129                } elsif (ref $myContent eq 'ARRAY') {
2130                    # Here the node may be a branch. Its content is a list.
2131                    my $len = scalar @{$myContent};
2132                    if ($len >= 1) {
2133                        # Here the first element of the list could by the link/value hash.
2134                        if (ref $myContent->[0] eq 'HASH') {
2135                            $attrHash = $myContent->[0];
2136                            # If there's data in the list besides the hash, it's our child list.
2137                            # We can pass the entire thing as the child list, because the hash
2138                            # is ignored.
2139                            if ($len > 1) {
2140                                $hasChildren = 1;
2141                            }
2142                        } else {
2143                            $hasChildren = 1;
2144                        }
2145                        # If we have children, create the child list with a recursive call.
2146                        if ($hasChildren) {
2147                            Trace("Processing children of $myLabel.") if T(4);
2148                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2149                        }
2150                    }
2151                }
2152                # Okay, it's time to pause and take stock. We have the label of the current node
2153                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2154                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2155                # Compute the image HTML. It's tricky, because we have to deal with the open and
2156                # closed images.
2157                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2158                my $image = $images[$hasChildren];
2159                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2160                if ($hasChildren) {
2161                    # If there are children, we wrap the image in a toggle hyperlink.
2162                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2163                                          $prefixHtml);
2164                }
2165                # Now the radio button, if any. Note we use "defined" in case the user wants the
2166                # value to be 0.
2167                if (defined $attrHash->{value}) {
2168                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2169                    # hash for the "input" method. If the item is pre-selected, we add
2170                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2171                    # at all.
2172                    my $radioParms = { type => 'radio',
2173                                       name => $options->{name},
2174                                       value => $attrHash->{value},
2175                                     };
2176                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2177                        $radioParms->{checked} = undef;
2178                    }
2179                    $prefixHtml .= $cgi->input($radioParms);
2180                }
2181                # Next, we format the label.
2182                my $labelHtml = $myLabel;
2183                Trace("Formatting tree node for $myLabel.") if T(4);
2184                # Apply a hyperlink if necessary.
2185                if (defined $attrHash->{link}) {
2186                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2187                                         $labelHtml);
2188                }
2189                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2190                # here.
2191                my $childHtml = join("\n", @childHtml);
2192                # Now we have all the pieces, so we can put them together.
2193                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2194            }
2195        }
2196        # Close the tree branch.
2197        push @retVal, $cgi->end_ul();
2198        # Return the result.
2199        return @retVal;
2200    }
2201    
2202    =head3 GetDivID
2203    
2204    C<< my $idString = SearchHelper::GetDivID($name); >>
2205    
2206    Return a new HTML ID string.
2207    
2208    =over 4
2209    
2210    =item name
2211    
2212    Name to be prefixed to the ID string.
2213    
2214    =item RETURN
2215    
2216    Returns a hopefully-unique ID string.
2217    
2218    =back
2219    
2220    =cut
2221    
2222    sub GetDivID {
2223        # Get the parameters.
2224        my ($name) = @_;
2225        # Compute the ID.
2226        my $retVal = "elt_$name$divCount";
2227        # Increment the counter to make sure this ID is not re-used.
2228        $divCount++;
2229        # Return the result.
2230        return $retVal;
2231    }
2232    
2233    =head2 Feature Column Methods
2234    
2235    The methods in this section manage feature column data. If you want to provide the
2236    capability to include new types of data in feature columns, then all the changes
2237    are made to this section of the source file. Technically, this should be implemented
2238    using object-oriented methods, but this is simpler for non-programmers to maintain.
2239    To add a new column of feature data, you must first give it a name. For example,
2240    the name for the protein page link column is C<protlink>. If the column is to appear
2241    in the default list of feature columns, add it to the list returned by
2242    L</DefaultFeatureColumns>. Then add code to produce the column title to
2243    L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
2244    everything else will happen automatically.
2245    
2246    There is one special column name syntax for extra columns (that is, nonstandard
2247    feature columns). If the column name begins with C<X=>, then it is presumed to be
2248    an extra column. The column title is the text after the C<X=>, and its value is
2249    pulled from the extra column hash.
2250    
2251    =head3 DefaultFeatureColumns
2252    
2253    C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2254    
2255    Return a list of the default feature column identifiers. These identifiers can
2256    be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2257    produce the column titles and row values.
2258    
2259    =cut
2260    
2261    sub DefaultFeatureColumns {
2262        # Get the parameters.
2263        my ($self) = @_;
2264        # Return the result.
2265        return qw(orgName function gblink protlink);
2266    }
2267    
2268    =head3 FeatureColumnTitle
2269    
2270    C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2271    
2272    Return the column heading title to be used for the specified feature column.
2273    
2274    =over 4
2275    
2276    =item name
2277    
2278    Name of the desired feature column.
2279    
2280    =item RETURN
2281    
2282    Returns the title to be used as the column header for the named feature column.
2283    
2284    =back
2285    
2286    =cut
2287    
2288    sub FeatureColumnTitle {
2289        # Get the parameters.
2290        my ($self, $colName) = @_;
2291        # Declare the return variable. We default to a blank column name.
2292        my $retVal = "&nbsp;";
2293        # Process the column name.
2294        if ($colName =~ /^X=(.+)$/) {
2295            # Here we have an extra column.
2296            $retVal = $1;
2297        } elsif ($colName eq 'alias') {
2298            $retVal = "External Aliases";
2299        } elsif ($colName eq 'fid') {
2300            $retVal = "FIG ID";
2301        } elsif ($colName eq 'function') {
2302            $retVal = "Functional Assignment";
2303        } elsif ($colName eq 'gblink') {
2304            $retVal = "GBrowse";
2305        } elsif ($colName eq 'group') {
2306            $retVal = "NMDPR Group";
2307        } elsif ($colName =~ /^keyword:(.+)$/) {
2308            $retVal = ucfirst $1;
2309        } elsif ($colName eq 'orgName') {
2310            $retVal = "Organism and Gene ID";
2311        } elsif ($colName eq 'protlink') {
2312            $retVal = "NMPDR Protein Page";
2313        } elsif ($colName eq 'subsystem') {
2314            $retVal = "Subsystems";
2315        }
2316        # Return the result.
2317        return $retVal;
2318    }
2319    
2320    
2321    =head3 FeatureColumnValue
2322    
2323    C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
2324    
2325    Return the value to be displayed in the specified feature column.
2326    
2327    =over 4
2328    
2329    =item colName
2330    
2331    Name of the column to be displayed.
2332    
2333    =item record
2334    
2335    DBObject record for the feature being displayed in the current row.
2336    
2337    =item extraCols
2338    
2339    Reference to a hash of extra column names to values. If the incoming column name
2340    begins with C<X=>, its value will be taken from this hash.
2341    
2342    =item RETURN
2343    
2344    Returns the HTML to be displayed in the named column for the specified feature.
2345    
2346  =back  =back
2347    
# Line 1303  Line 2368 
2368          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2369              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2370          }          }
2371      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'alias') {
2372          # Here we want the formatted organism name and feature number.          # In this case, the user wants a list of external aliases for the feature.
2373          $retVal = $self->FeatureName($fid);          # These are very expensive, so we compute them when the row is displayed.
2374            $retVal = "%%alias=$fid";
2375      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2376          # 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.
2377          $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);  
         }  
2378      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2379          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2380          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2381      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2382          # 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.
2383          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2384          $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 })  
                          );  
2385      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2386          # Get the NMPDR group name.          # Get the NMPDR group name.
2387          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1345  Line 2389 
2389          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2390          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2391                            $group);                            $group);
2392        } elsif ($colName =~ /^keyword:(.+)$/) {
2393            # Here we want keyword-related values. This is also expensive, so
2394            # we compute them when the row is displayed.
2395            $retVal = "%%$colName=$fid";
2396        } elsif ($colName eq 'orgName') {
2397            # Here we want the formatted organism name and feature number.
2398            $retVal = $self->FeatureName($fid);
2399        } elsif ($colName eq 'protlink') {
2400            # Here we want a link to the protein page using the official NMPDR button.
2401            $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2402                              prot => $fid, SPROUT => 1, new_framework => 0,
2403                              user => '');
2404        }elsif ($colName eq 'subsystem') {
2405            # Another run-time column: subsystem list.
2406            $retVal = "%%subsystem=$fid";
2407        }
2408        # Return the result.
2409        return $retVal;
2410      }      }
2411    
2412    =head3 RunTimeColumns
2413    
2414    C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2415    
2416    Return the HTML text for a run-time column. Run-time columns are evaluated when the
2417    list is displayed, rather than when it is generated.
2418    
2419    =over 4
2420    
2421    =item type
2422    
2423    Type of column.
2424    
2425    =item text
2426    
2427    Data relevant to this row of the column.
2428    
2429    =item RETURN
2430    
2431    Returns the fully-formatted HTML text to go in the specified column.
2432    
2433    =back
2434    
2435    =cut
2436    
2437    sub RunTimeColumns {
2438        # Get the parameters.
2439        my ($self, $type, $text) = @_;
2440        # Declare the return variable.
2441        my $retVal = "";
2442        # Get the Sprout and CGI objects.
2443        my $sprout = $self->DB();
2444        my $cgi = $self->Q();
2445        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2446        # Separate the text into a type and data.
2447        if ($type eq 'alias') {
2448            # Here the caller wants external alias links for a feature. The text
2449            # is the feature ID.
2450            my $fid = $text;
2451            # The complicated part is we have to hyperlink them. First, get the
2452            # aliases.
2453            Trace("Generating aliases for feature $fid.") if T(4);
2454            my @aliases = $sprout->FeatureAliases($fid);
2455            # Only proceed if we found some.
2456            if (@aliases) {
2457                # Join the aliases into a comma-delimited list.
2458                my $aliasList = join(", ", @aliases);
2459                # Ask the HTML processor to hyperlink them.
2460                $retVal = HTML::set_prot_links($cgi, $aliasList);
2461            }
2462        } elsif ($type eq 'subsystem') {
2463            # Here the caller wants the subsystems in which this feature participates.
2464            # The text is the feature ID. We will list the subsystem names with links
2465            # to the subsystem's summary page.
2466            my $fid = $text;
2467            # Get the subsystems.
2468            Trace("Generating subsystems for feature $fid.") if T(4);
2469            my %subs = $sprout->SubsystemsOf($fid);
2470            # Extract the subsystem names.
2471            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2472            # String them into a list.
2473            $retVal = join(", ", @names);
2474        } elsif ($type =~ /^keyword:(.+)$/) {
2475            # Here the caller wants the value of the named keyword. The text is the
2476            # feature ID.
2477            my $keywordName = $1;
2478            my $fid = $text;
2479            # Get the attribute values.
2480            Trace("Getting $keywordName values for feature $fid.") if T(4);
2481            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2482                                          "Feature($keywordName)");
2483            # String them into a list.
2484            $retVal = join(", ", @values);
2485        }
2486        # Return the result.
2487        return $retVal;
2488    }
2489    
2490    =head3 SaveOrganismData
2491    
2492    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2493    
2494    Format the name of an organism and the display version of its group name. The incoming
2495    data should be the relevant fields from the B<Genome> record in the database. The
2496    data will also be stored in the genome cache for later use in posting search results.
2497    
2498    =over 4
2499    
2500    =item group
2501    
2502    Name of the genome's group as it appears in the database.
2503    
2504    =item genomeID
2505    
2506    ID of the relevant genome.
2507    
2508    =item genus
2509    
2510    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2511    in the database. In this case, the organism name is derived from the genomeID and the group
2512    is automatically the supporting-genomes group.
2513    
2514    =item species
2515    
2516    Species of the genome's organism.
2517    
2518    =item strain
2519    
2520    Strain of the species represented by the genome.
2521    
2522    =item RETURN
2523    
2524    Returns a two-element list. The first element is the formatted genome name. The second
2525    element is the display name of the genome's group.
2526    
2527    =back
2528    
2529    =cut
2530    
2531    sub SaveOrganismData {
2532        # Get the parameters.
2533        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2534        # Declare the return values.
2535        my ($name, $displayGroup);
2536        # If the organism does not exist, format an unknown name and a blank group.
2537        if (! defined($genus)) {
2538            $name = "Unknown Genome $genomeID";
2539            $displayGroup = "";
2540        } else {
2541            # It does exist, so format the organism name.
2542            $name = "$genus $species";
2543            if ($strain) {
2544                $name .= " $strain";
2545            }
2546            # Compute the display group. This is currently the same as the incoming group
2547            # name unless it's the supporting group, which is nulled out.
2548            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2549        }
2550        # Cache the group and organism data.
2551        my $cache = $self->{orgs};
2552        $cache->{$genomeID} = [$name, $displayGroup];
2553        # Return the result.
2554        return ($name, $displayGroup);
2555    }
2556    
2557    =head3 ValidateKeywords
2558    
2559    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2560    
2561    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2562    set.
2563    
2564    =over 4
2565    
2566    =item keywordString
2567    
2568    Keyword string specified as a parameter to the current search.
2569    
2570    =item required
2571    
2572    TRUE if there must be at least one keyword specified, else FALSE.
2573    
2574    =item RETURN
2575    
2576    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2577    is acceptable if the I<$required> parameter is not specified.
2578    
2579    =back
2580    
2581    =cut
2582    
2583    sub ValidateKeywords {
2584        # Get the parameters.
2585        my ($self, $keywordString, $required) = @_;
2586        # Declare the return variable.
2587        my $retVal = 0;
2588        my @wordList = split /\s+/, $keywordString;
2589        # Right now our only real worry is a list of all minus words. The problem with it is that
2590        # it will return an incorrect result.
2591        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2592        if (! @wordList) {
2593            if ($required) {
2594                $self->SetMessage("No search words specified.");
2595            } else {
2596                $retVal = 1;
2597            }
2598        } elsif (! @plusWords) {
2599            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2600        } else {
2601            $retVal = 1;
2602        }
2603        # Return the result.
2604        return $retVal;
2605    }
2606    
2607    =head3 FakeButton
2608    
2609    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2610    
2611    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2612    Unlike a real button, this one won't visibly click, but it will take the user to the
2613    correct place.
2614    
2615    The parameters of this method are deliberately identical to L</Formlet> so that we
2616    can switch easily from real buttons to fake ones in the code.
2617    
2618    =over 4
2619    
2620    =item caption
2621    
2622    Caption to be put on the button.
2623    
2624    =item url
2625    
2626    URL for the target page or script.
2627    
2628    =item target
2629    
2630    Frame or target in which the new page should appear. If C<undef> is specified,
2631    the default target will be used.
2632    
2633    =item parms
2634    
2635    Hash containing the parameter names as keys and the parameter values as values.
2636    These will be appended to the URL.
2637    
2638    =back
2639    
2640    =cut
2641    
2642    sub FakeButton {
2643        # Get the parameters.
2644        my ($caption, $url, $target, %parms) = @_;
2645        # Declare the return variable.
2646        my $retVal;
2647        # Compute the target URL.
2648        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2649        # Compute the target-frame HTML.
2650        my $targetHtml = ($target ? " target=\"$target\"" : "");
2651        # Assemble the result.
2652        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2653    }
2654    
2655    =head3 Formlet
2656    
2657    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
2658    
2659    Create a mini-form that posts to the specified URL with the specified parameters. The
2660    parameters will be stored in hidden fields, and the form's only visible control will
2661    be a submit button with the specified caption.
2662    
2663    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
2664    and tags that we don't want to deal with.
2665    
2666    =over 4
2667    
2668    =item caption
2669    
2670    Caption to be put on the form button.
2671    
2672    =item url
2673    
2674    URL to be put in the form's action parameter.
2675    
2676    =item target
2677    
2678    Frame or target in which the form results should appear. If C<undef> is specified,
2679    the default target will be used.
2680    
2681    =item parms
2682    
2683    Hash containing the parameter names as keys and the parameter values as values.
2684    
2685    =back
2686    
2687    =cut
2688    
2689    sub Formlet {
2690        # Get the parameters.
2691        my ($caption, $url, $target, %parms) = @_;
2692        # Compute the target HTML.
2693        my $targetHtml = ($target ? " target=\"$target\"" : "");
2694        # Start the form.
2695        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
2696        # Add the parameters.
2697        for my $parm (keys %parms) {
2698            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
2699        }
2700        # Put in the button.
2701        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
2702        # Close the form.
2703        $retVal .= "</form>";
2704        # Return the result.
2705        return $retVal;
2706    }
2707    
2708    =head2 Virtual Methods
2709    
2710    =head3 Form
2711    
2712    C<< my $html = $shelp->Form(); >>
2713    
2714    Generate the HTML for a form to request a new search.
2715    
2716    =head3 Find
2717    
2718    C<< my $resultCount = $shelp->Find(); >>
2719    
2720    Conduct a search based on the current CGI query parameters. The search results will
2721    be written to the session cache file and the number of results will be
2722    returned. If the search parameters are invalid, a result count of C<undef> will be
2723    returned and a result message will be stored in this object describing the problem.
2724    
2725    =head3 Description
2726    
2727    C<< my $htmlText = $shelp->Description(); >>
2728    
2729    Return a description of this search. The description is used for the table of contents
2730    on the main search tools page. It may contain HTML, but it should be character-level,
2731    not block-level, since the description is going to appear in a list.
2732    
2733    =head3 SortKey
2734    
2735    C<< my $key = $shelp->SortKey($fdata); >>
2736    
2737    Return the sort key for the specified feature data. The default is to sort by feature name,
2738    floating NMPDR organisms to the top. If a full-text search is used, then the default
2739    sort is by relevance followed by feature name. This sort may be overridden by the
2740    search class to provide fancier functionality. This method is called by
2741    B<PutFeature>, so it is only used for feature searches. A non-feature search
2742    would presumably have its own sort logic.
2743    
2744    =over 4
2745    
2746    =item record
2747    
2748    The C<FeatureData> containing the current feature.
2749    
2750    =item RETURN
2751    
2752    Returns a key field that can be used to sort this row in among the results.
2753    
2754    =back
2755    
2756    =cut
2757    
2758    sub SortKey {
2759        # Get the parameters.
2760        my ($self, $fdata) = @_;
2761        # Get the feature ID from the record.
2762        my $fid = $fdata->FID();
2763        # Get the group from the feature ID.
2764        my $group = $self->FeatureGroup($fid);
2765        # Ask the feature query object to form the sort key.
2766        my $retVal = $fdata->SortKey($self, $group);
2767      # Return the result.      # Return the result.
2768      return $retVal;      return $retVal;
2769  }  }

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3