[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.9, Sat Oct 7 13:18:11 2006 UTC revision 1.32, Thu May 17 23:43:30 2007 UTC
# Line 88  Line 88 
88  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89  field is updated by the B<FeatureQuery> object.  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 113  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 177  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 222  Line 231 
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 241  Line 260 
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 262  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 285  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,
# Line 295  Line 326 
326                    genomeList => undef,                    genomeList => undef,
327                    genomeParms => [],                    genomeParms => [],
328                    filtered => 0,                    filtered => 0,
329                      extraPos => {},
330                   };                   };
331      # Bless and return it.      # Bless and return it.
332      bless $retVal, $class;      bless $retVal, $class;
# Line 355  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 449  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 609  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 620  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 631  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 646  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.      # Get the CGI query object.
710      my $cgi = $self->Q();      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          # Add the externals if they were requested.          $self->PrintLine("Creating output columns.<br />");
719          if ($cgi->param('ShowAliases')) {          # Here we need to set up the column information. First we accumulate the extras,
720              push @{$self->{cols}}, 'alias';          # sorted by column name and separate by whether they go in the beginning or the
721          }          # end.
722          # Append the extras, sorted by column name.          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 usually 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 $key = $self->SortKey($record);      my $key = $self->SortKey($fd);
763      # Write the feature data.      # Write the feature data.
764      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
765  }  }
# Line 709  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 742  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 760  Line 844 
844          # We found one, so close it.          # We found one, so close it.
845          Trace("Closing session file.") if T(2);          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 802  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 814  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 870  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 950  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 975  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 987  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, $multiple, \@selected, $rows); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
# Line 1115  Line 1387 
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.      # Check to see if we already have a genome list in memory.
     my $genomes = $self->{genomeList};  
1390      my $groupHash;      my $groupHash;
1391        my @groups;
1392        my $nmpdrGroupCount;
1393        my $genomes = $self->{genomeList};
1394      if (defined $genomes) {      if (defined $genomes) {
1395          # We have a list ready to use.          # We have a list ready to use.
1396          $groupHash = $genomes;          $groupHash = $genomes;
1397            @groups = @{$self->{groupList}};
1398            $nmpdrGroupCount = $self->{groupCount};
1399      } else {      } 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
# Line 1128  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 %gHash = ();          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 @{$gHash{$group}}, [$genomeID, $name];  
1440          }          }
1441            # Add the domain groups at the end of the main group list. The main group list will now
1442            # contain all the categories we need to display the genomes.
1443            push @groups, sort @domains;
1444            # Delete the supporting group.
1445            delete $gHash{$FIG_Config::otherGroup};
1446          # Save the genome list for future use.          # Save the genome list for future use.
1447          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1448            $self->{groupList} = \@groups;
1449            $self->{groupCount} = $nmpdrGroupCount;
1450          $groupHash = \%gHash;          $groupHash = \%gHash;
1451      }      }
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};  
     push @groups, $FIG_Config::otherGroup;  
1452      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1453      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1454      my %selectedHash = ();      my %selectedHash = ();
1455      if (defined $selected) {      if (defined $selected) {
1456          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1457      }      }
1458      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
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 1168  Line 1468 
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 ($cross) {      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)\"";          $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1474      } elsif ($multiple) {      } 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 = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";      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, so we can't use it.  
         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 ($multiple) {      if ($multiple) {
1509          # Since multi-select is on, we set up some buttons to set and clear selections.          # Multi-select is on, so we need to add some selection helpers. First is
1510          push @lines, "<br />";          # the search box. This allows the user to type text and have all genomes containing
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";  
         # Now add the search box. This allows the user to type text and have all genomes containing  
1511          # the text selected automatically.          # the text selected automatically.
1512          my $searchThingName = "${menuName}_SearchThing";          my $searchThingName = "${menuName}_SearchThing";
1513          push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .          push @lines, "<br />" .
1514                       "<INPUT type=\"button\" name=\"Select\" class=\"button\" value=\"Search\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";                       "<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 />";
1518            push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1519            push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1520            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 1299  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 1315  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 1331  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        # Compute the button caption.
1681        my $realCaption = (defined $caption ? $caption : 'Go');
1682      # Get the current page size.      # Get the current page size.
1683      my $pageSize = $cgi->param('PageSize');      my $pageSize = $cgi->param('PageSize');
1684      # Get the incoming external-link flag.      # Get the incoming external-link flag.
# Line 1351  Line 1687 
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, 50, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1690                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
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    =over 4
1707    
1708    =item subset
1709    
1710  This method creates table rows that can be used to filter features. There are  List of rows to display. The default (C<all>) is to display all rows.
1711  two rows returned, and the values can be used to select features by genome  C<words> displays the word search box, C<subsys> displays the subsystem
1712  using the B<FeatureQuery> object.  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 1451  Line 1801 
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);          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;
# Line 1544  Line 1894 
1894    
1895  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1896    
1897  C<< my $url = $shelp->ComputeSearchURL(); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1898    
1899  Compute the GET-style URL for the current search. In order for this to work, there  Compute the GET-style URL for the current search. In order for this to work, there
1900  must be a copy of the search form on the current page. This will always be the  must be a copy of the search form on the current page. This will always be the
# Line 1554  Line 1904 
1904  main complication is that if the user specified all genomes, we'll want to  main complication is that if the user specified all genomes, we'll want to
1905  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1906    
1907    =over 4
1908    
1909    =item overrides
1910    
1911    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
1916    
1917    Returns a GET-style URL for invoking the search with the specified overrides.
1918    
1919    =back
1920    
1921  =cut  =cut
1922    
1923  sub ComputeSearchURL {  sub ComputeSearchURL {
1924      # Get the parameters.      # Get the parameters.
1925      my ($self) = @_;      my ($self, %overrides) = @_;
1926      # Get the database and CGI query object.      # Get the database and CGI query object.
1927      my $cgi = $self->Q();      my $cgi = $self->Q();
1928      my $sprout = $self->DB();      my $sprout = $self->DB();
# Line 1585  Line 1949 
1949          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1950          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1951          # Check for special cases.          # Check for special cases.
1952          if ($parmKey eq 'featureTypes') {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
             # Here we need to see if the user wants all the feature types. If he  
             # does, we erase all the values so that the parameter is not output.  
             my %valueCheck = map { $_ => 1 } @values;  
             my @list = FeatureQuery::AllFeatureTypes();  
             my $okFlag = 1;  
             for (my $i = 0; $okFlag && $i <= $#list; $i++) {  
                 if (! $valueCheck{$list[$i]}) {  
                     $okFlag = 0;  
                 }  
             }  
             if ($okFlag) {  
                 @values = ();  
             }  
         } elsif (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {  
1953              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1954              @values = ();              @values = ();
1955          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1613  Line 1963 
1963              if ($allFlag) {              if ($allFlag) {
1964                  @values = ();                  @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.          # If we still have values, create the URL parameters.
1971          if (@values) {          if (@values) {
1972              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              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.      # Add the parameters to the URL.
1983      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1984      # Return the result.      # Return the result.
# Line 1661  Line 2021 
2021      return $retVal;      return $retVal;
2022  }  }
2023    
2024  =head3 FeatureTypeMap  =head3 AdvancedClassList
2025    
2026  C<< my %features = SearchHelper::FeatureTypeMap(); >>  C<< my @classes = SearchHelper::AdvancedClassList(); >>
2027    
2028  Return a map of feature types to descriptions. The feature type data is stored  Return a list of advanced class names. This list is used to generate the directory
2029  in the B<FIG_Config> file. Currently, it only contains a space-delimited list of  of available searches on the search page.
 feature types. The map returned by this method is a hash mapping the type codes to  
 descriptive names.  
2030    
2031  The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>  We use the %INC variable to accomplish this.
 script is only able to insert strings into the generated B<FIG_Config> file.  
2032    
2033  =cut  =cut
2034    
2035  sub FeatureTypeMap {  sub AdvancedClassList {
2036      my @list = split /\s+/, $FIG_Config::feature_types;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2037      my %retVal = map { $_ => $_ } @list;      return sort @retVal;
     return %retVal;  
2038  }  }
2039    
2040  =head3 AdvancedClassList  =head3 SelectionTree
2041    
2042  C<< my @classes = SearchHelper::AdvancedClassList(); >>  C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
2043    
2044  Return a list of advanced class names. This list is used to generate the directory  Display a selection tree.
 of available searches on the search page.  
2045    
2046  The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>  This method creates the HTML for a tree selection control. The tree is implemented as a set of
2047  script is only able to insert strings into the generated B<FIG_Config> file.  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  =cut  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  sub AdvancedClassList {  =over 4
     return split /\s+/, $FIG_Config::advanced_classes;  
 }  
2056    
2057  =head2 Feature Column Methods  =item link
2058    
2059  The methods in this column manage feature column data. If you want to provide the  The navigation URL to be popped up if the user clicks on the node name.
 capability to include new types of data in feature columns, then all the changes  
 are made to this section of the source file. Technically, this should be implemented  
 using object-oriented methods, but this is simpler for non-programmers to maintain.  
 To add a new column of feature data, you must first give it a name. For example,  
 the name for the protein page link column is C<protlink>. If the column is to appear  
 in the default list of feature columns, add it to the list returned by  
 L</DefaultFeatureColumns>. Then add code to produce the column title to  
 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  
 everything else will happen automatically.  
2060    
2061  There is one special column name syntax for extra columns (that is, nonstandard  =item value
 feature columns). If the column name begins with C<X=>, then it is presumed to be  
 an extra column. The column title is the text after the C<X=>, and its value is  
 pulled from the extra column hash.  
2062    
2063  =head3 DefaultFeatureColumns  The form value to be returned if the user selects the tree node.
2064    
2065  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  =back
2066    
2067  Return a reference to a list of the default feature column identifiers. These  The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
2068  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  a C<value> key indicates the node name will have a radio button. If a node has no children,
2069  order to produce the column titles and row values.  you may pass it a hash reference instead of a list reference.
2070    
2071  =cut  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  sub DefaultFeatureColumns {      [   Objects => [
2075      # Get the parameters.              Entities => [
2076      my ($self) = @_;                  {link => "../docs/WhatIsAnEntity.html"},
2077      # Return the result.                  Genome => {value => 'GenomeData'},
2078      return ['orgName', 'function', 'gblink', 'protlink',                  Feature => {value => 'FeatureData'},
2079              FeatureQuery::AdditionalColumns($self)];                  Contig => {value => 'ContigData'},
2080  }              ],
2081                Relationships => [
2082                    {link => "../docs/WhatIsARelationShip.html"},
2083                    HasFeature => {value => 'GenomeToFeature'},
2084                    IsOnContig => {value => 'FeatureToContig'},
2085                ]
2086            ]
2087        ]
2088    
2089  =head3 FeatureColumnTitle  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  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  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  Return the column heading title to be used for the specified feature column.      [   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  =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  =item name
2176    
2177  Name of the desired feature column.  Field name to give to the radio buttons in the tree. The default is C<selection>.
2178    
2179  =item RETURN  =item target
2180    
2181  Returns the title to be used as the column header for the named feature column.  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  =back
2188    
2189  =cut  =cut
2190    
2191  sub FeatureColumnTitle {  sub SelectionTree {
2192      # Get the parameters.      # Get the parameters.
2193      my ($self, $colName) = @_;      my ($cgi, $tree, %options) = @_;
2194      # Declare the return variable. We default to a blank column name.      # Get the options.
2195      my $retVal = "&nbsp;";      my $optionThing = Tracer::GetOptions({ name => 'selection',
2196      # Process the column name.                                             nodeImageClosed => '../FIG/Html/plus.gif',
2197      if ($colName =~ /^X=(.+)$/) {                                             nodeImageOpen => '../FIG/Html/minus.gif',
2198          # Here we have an extra column.                                             style => 'tree',
2199          $retVal = $1;                                             target => '_self',
2200      } elsif ($colName eq 'orgName') {                                             selected => undef},
2201          $retVal = "Name";                                           \%options);
2202      } elsif ($colName eq 'fid') {      # Declare the return variable. We'll do the standard thing with creating a list
2203          $retVal = "FIG ID";      # of HTML lines and rolling them together at the end.
2204      } elsif ($colName eq 'alias') {      my @retVal = ();
2205          $retVal = "External Aliases";      # Only proceed if the tree is present.
2206      } elsif ($colName eq 'function') {      if (defined($tree)) {
2207          $retVal = "Functional Assignment";          # Validate the tree.
2208      } elsif ($colName eq 'gblink') {          if (ref $tree ne 'ARRAY') {
2209          $retVal = "GBrowse";              Confess("Selection tree is not a list reference.");
2210      } elsif ($colName eq 'protlink') {          } elsif (scalar @{$tree} == 0) {
2211          $retVal = "NMPDR Protein Page";              # The tree is empty, so we do nothing.
2212      } elsif ($colName eq 'group') {          } elsif ($tree->[0] eq 'HASH') {
2213          $retVal = "NMDPR Group";              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.      # Return the result.
2226      return $retVal;      return join("\n", @retVal, "");
2227  }  }
2228    
2229  =head3 FeatureColumnValue  =head3 ShowBranch
2230    
2231  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2232    
2233  Return the value to be displayed in the specified feature column.  This is a recursive method that displays a branch of the tree.
2234    
2235  =over 4  =over 4
2236    
2237  =item colName  =item cgi
2238    
2239  Name of the column to be displayed.  CGI object used to format HTML.
2240    
2241  =item record  =item label
2242    
2243  DBObject record for the feature being displayed in the current row.  Label of this tree branch. It is only used in error messages.
2244    
2245  =item extraCols  =item id
2246    
2247  Reference to a hash of extra column names to values. If the incoming column name  ID to be given to this tree branch. The ID is used in the code that expands and collapses
2248  begins with C<X=>, its value will be taken from this hash.  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  =item RETURN
2267    
2268  Returns the HTML to be displayed in the named column for the specified feature.  Returns one or more HTML lines that can be used to display the tree branch.
2269    
2270  =back  =back
2271    
2272  =cut  =cut
2273    
2274  sub FeatureColumnValue {  sub ShowBranch {
2275      # Get the parameters.      # Get the parameters.
2276      my ($self, $colName, $record, $extraCols) = @_;      my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2277      # Get the sprout and CGI objects.      # Declare the return variable.
2278      my $cgi = $self->Q();      my @retVal = ();
2279      my $sprout = $self->DB();      # Start the branch.
2280      # Get the feature ID.      push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2281      my ($fid) = $record->Value('Feature(id)');      # Check for the hash and choose the start location accordingly.
2282      # Declare the return variable. Denote that we default to a non-breaking space,      my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2283      # which will translate to an empty table cell (rather than a table cell with no      # Get the list length.
2284      # interior, which is what you get for a null string).      my $i1 = scalar(@{$branch});
2285      my $retVal = "&nbsp;";      # Verify we have an even number of elements.
2286      # Process according to the column name.      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
2581    
2582    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.
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=(.+)$/) {      if ($colName =~ /^X=(.+)$/) {
2607          # Here we have an extra column. Only update if the value exists. Note that          # 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          # a value of C<undef> is treated as a non-existent value, because the
# Line 1831  Line 2611 
2611          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2612              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2613          }          }
     } 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);  
2614      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2615          # In this case, the user wants a list of external aliases for the feature.          # 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.          # These are very expensive, so we compute them when the row is displayed.
2617          $retVal = "%%aliases=$fid";          # 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') {      } elsif ($colName eq 'function') {
2625          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2626          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2627      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2628          # Here we want a link to the GBrowse page using the official GBrowse button.          # Here we want a link to the GBrowse page using the official GBrowse button.
2629          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2630          $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },                            fid => $fid);
                           $cgi->img({ src => "../images/button-gbrowse.png",  
                                       border => 0 })  
                          );  
     } elsif ($colName eq 'protlink') {  
         # Here we want a link to the protein page using the official NMPDR button.  
         my $hurl = HTML::fid_link($cgi, $fid, 0, 1);  
         $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },  
                           $cgi->img({ src => "../images/button-nmpdr.png",  
                                      border => 0 })  
                          );  
2631      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2632          # Get the NMPDR group name.          # Get the NMPDR group name.
2633          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1865  Line 2635 
2635          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2636          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2637                            $group);                            $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.      # Return the result.
2661      return $retVal;      return $retVal;
# Line 1903  Line 2694 
2694      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
2695      my $sprout = $self->DB();      my $sprout = $self->DB();
2696      my $cgi = $self->Q();      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.      # Separate the text into a type and data.
2699      if ($type eq 'aliases') {      if ($type eq 'alias') {
2700          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2701          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2702          my $fid = $text;          # the favored alias type.
2703          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2704          # aliases.          # 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);          Trace("Generating aliases for feature $fid.") if T(4);
2707          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2708          # Only proceed if we found some.          # Only proceed if we found some.
2709          if (@aliases) {          if (@aliases) {
2710              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2711              my $aliasList = join(", ", @aliases);              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.              # Ask the HTML processor to hyperlink them.
2725              $retVal = HTML::set_prot_links($cgi, $aliasList);              $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
2819    
2820    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
2824    
2825    =cut
2826    
2827    sub SaveOrganismData {
2828        # Get the parameters.
2829        my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2830        # 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();
3034        # Loop through the parameter names.
3035        for my $parm (keys %parmHash) {
3036            # Get the incoming value for this parameter.
3037            my $value = $cgi->param($parm);
3038            # Zero might be a valid value, so we do an is-defined check rather than an OR.
3039            if (defined($value)) {
3040                $retVal->{$parm} = $value;
3041            } else {
3042                $retVal->{$parm} = $parmHash{$parm};
3043            }
3044      }      }
3045      # Return the result.      # Return the result.
3046      return $retVal;      return $retVal;
# Line 1951  Line 3073 
3073    
3074  =head3 SortKey  =head3 SortKey
3075    
3076  C<< my $key = $shelp->SortKey($record); >>  C<< my $key = $shelp->SortKey($fdata); >>
3077    
3078  Return the sort key for the specified record. The default is to sort by feature name,  Return the sort key for the specified feature data. The default is to sort by feature name,
3079  floating NMPDR organisms to the top. This sort may be overridden by the search class  floating NMPDR organisms to the top. If a full-text search is used, then the default
3080  to provide fancier functionality. This method is called by B<PutFeature>, so it  sort is by relevance followed by feature name. This sort may be overridden by the
3081  is only used for feature searches. A non-feature search would presumably have its  search class to provide fancier functionality. This method is called by
3082  own sort logic.  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  =over 4
3086    
3087  =item record  =item record
3088    
3089  The C<DBObject> from which the current row of data is derived.  The C<FeatureData> containing the current feature.
3090    
3091  =item RETURN  =item RETURN
3092    
# Line 1975  Line 3098 
3098    
3099  sub SortKey {  sub SortKey {
3100      # Get the parameters.      # Get the parameters.
3101      my ($self, $record) = @_;      my ($self, $fdata) = @_;
3102      # Get the feature ID from the record.      # Get the feature ID from the record.
3103      my ($fid) = $record->Value('Feature(id)');      my $fid = $fdata->FID();
3104      # Get the group from the feature ID.      # Get the group from the feature ID.
3105      my $group = $self->FeatureGroup($fid);      my $group = $self->FeatureGroup($fid);
3106      # Ask the feature query object to form the sort key.      # Ask the feature query object to form the sort key.
3107      my $retVal = FeatureQuery::SortKey($self, $group, $record);      my $retVal = $fdata->SortKey($self, $group);
3108      # Return the result.      # Return the result.
3109      return $retVal;      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.
3159        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.9  
changed lines
  Added in v.1.32

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3