[Bio] / Sprout / SearchHelper.pm Repository:
ViewVC logotype

Diff of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3