[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.5, Mon Oct 2 06:35:31 2006 UTC revision 1.33, Tue Jun 19 21:28:21 2007 UTC
# Line 19  Line 19 
19      use FeatureQuery;      use FeatureQuery;
20      use URI::Escape;      use URI::Escape;
21      use PageBuilder;      use PageBuilder;
22        use POSIX;
23    
24  =head1 Search Helper Base Class  =head1 Search Helper Base Class
25    
# Line 88  Line 89 
89  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
90  field is updated by the B<FeatureQuery> object.  field is updated by the B<FeatureQuery> object.
91    
92    =item extraPos
93    
94    Hash indicating which extra columns should be put at the end. Extra columns
95    not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
96    method to change this option.
97    
98  =back  =back
99    
100  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 113  Line 120 
120    
121  =item 4  =item 4
122    
123  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.  
124    
125  =back  =back
126    
# Line 177  Line 183 
183    
184  =back  =back
185    
186    If you are doing a feature search, you can also change the list of feature
187    columns displayed and their display order by overriding
188    L</DefaultFeatureColumns>.
189    
190  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
191  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
192    
# Line 214  Line 224 
224                      }                      }
225                  }                  }
226              }              }
         }  
227          # Close the session file.          # Close the session file.
228          $self->CloseSession();          $self->CloseSession();
229            }
230          # Return the result count.          # Return the result count.
231          return $retVal;          return $retVal;
232      }      }
233    
234  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
235  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
236  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
237  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
238  above code is just a loose framework.  above code is just a loose framework.
239    
240    In addition to the finding and filtering, it is necessary to send status messages
241    to the output so that the user does not get bored waiting for results. The L</PrintLine>
242    method performs this function. The single parameter should be text to be
243    output to the browser. In general, you'll invoke it as follows.
244    
245        $self->PrintLine("...my message text...<br />");
246    
247    The break tag is optional. When the Find method gets control, a paragraph will
248    have been started so that everything is XHTML-compliant.
249    
250  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>
251  method of the feature query object.  method of the feature query object.
252    
# Line 241  Line 261 
261    
262  # 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.
263  my $formCount = 0;  my $formCount = 0;
264    # This counter is used to generate unique DIV IDs.
265    my $divCount = 0;
266    
267  =head2 Public Methods  =head2 Public Methods
268    
269  =head3 new  =head3 new
270    
271  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
272    
273  Construct a new SearchHelper object.  Construct a new SearchHelper object.
274    
275  =over 4  =over 4
276    
277  =item query  =item cgi
278    
279  The CGI query object for the current script.  The CGI query object for the current script.
280    
# Line 262  Line 284 
284    
285  sub new {  sub new {
286      # Get the parameters.      # Get the parameters.
287      my ($class, $query) = @_;      my ($class, $cgi) = @_;
288      # Check for a session ID.      # Check for a session ID.
289      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
290      my $type = "old";      my $type = "old";
291      if (! $session_id) {      if (! $session_id) {
292            Trace("No session ID found.") if T(3);
293          # 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
294          # store it in the query object.          # store it in the query object.
295          $session_id = NewSessionID();          $session_id = NewSessionID();
296          $type = "new";          $type = "new";
297          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
298        } else {
299            Trace("Session ID is $session_id.") if T(3);
300      }      }
301      # Compute the subclass name.      # Compute the subclass name.
302      $class =~ /SH(.+)$/;      my $subClass;
303      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
304            # Here we have a real search class.
305            $subClass = $1;
306        } else {
307            # Here we have a bare class. The bare class cannot search, but it can
308            # process search results.
309            $subClass = 'SearchHelper';
310        }
311      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
312      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
313      # Generate the form name.      # Generate the form name.
314      my $formName = "$class$formCount";      my $formName = "$class$formCount";
315      $formCount++;      $formCount++;
# Line 285  Line 317 
317      # 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
318      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
319      my $retVal = {      my $retVal = {
320                    query => $query,                    query => $cgi,
321                    type => $type,                    type => $type,
322                    class => $subClass,                    class => $subClass,
323                    sprout => undef,                    sprout => undef,
# Line 295  Line 327 
327                    genomeList => undef,                    genomeList => undef,
328                    genomeParms => [],                    genomeParms => [],
329                    filtered => 0,                    filtered => 0,
330                      extraPos => {},
331                   };                   };
332      # Bless and return it.      # Bless and return it.
333      bless $retVal, $class;      bless $retVal, $class;
# Line 316  Line 349 
349      return $self->{query};      return $self->{query};
350  }  }
351    
352    
353    
354  =head3 DB  =head3 DB
355    
356  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 353  Line 388 
388      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
389  }  }
390    
391    =head3 SetExtraPos
392    
393    C<< $shelp->SetExtraPos(@columnMap); >>
394    
395    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
396    
397    =over 4
398    
399    =item columnMap
400    
401    A list of extra columns to display at the end.
402    
403    =back
404    
405    =cut
406    
407    sub SetExtraPos {
408        # Get the parameters.
409        my ($self, @columnMap) = @_;
410        # Convert the column map to a hash.
411        my %map = map { $_ => 1 } @columnMap;
412        # Save a reference to it.
413        $self->{extraPos} = \%map;
414    }
415    
416  =head3 ID  =head3 ID
417    
418  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 447  Line 507 
507      my ($self, $title) = @_;      my ($self, $title) = @_;
508      # Get the CGI object.      # Get the CGI object.
509      my $cgi = $self->Q();      my $cgi = $self->Q();
510      # Start the form.      # Start the form. Note we use the override option on the Class value, in
511        # case the Advanced button was used.
512      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
513                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
514                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
515                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
516                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
517                                -value => $self->{class}) .                                -value => $self->{class},
518                                  -override => 1) .
519                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
520                                -value => 1) .                                -value => 1) .
521                   $cgi->h3($title);                   $cgi->h3($title);
# Line 607  Line 669 
669    
670  =head3 PutFeature  =head3 PutFeature
671    
672  C<< $shelp->PutFeature($fquery); >>  C<< $shelp->PutFeature($fdata); >>
673    
674  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
675  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
# Line 618  Line 680 
680  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
681  code adds columns for essentiality and virulence.  code adds columns for essentiality and virulence.
682    
683      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
684      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
685    
686  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
687  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 629  Line 691 
691      if (! $essentialFlag) {      if (! $essentialFlag) {
692          $essentialFlag = undef;          $essentialFlag = undef;
693      }      }
694      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
695      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
696    
697  =over 4  =over 4
698    
699  =item fquery  =item fdata
700    
701  FeatureQuery object containing the current feature data.  B<FeatureData> object containing the current feature data.
702    
703  =back  =back
704    
# Line 644  Line 706 
706    
707  sub PutFeature {  sub PutFeature {
708      # Get the parameters.      # Get the parameters.
709      my ($self, $fq) = @_;      my ($self, $fd) = @_;
710      # Get the CGI query object.      # Get the CGI query object.
711      my $cgi = $self->Q();      my $cgi = $self->Q();
712      # Get the feature data.      # Get the feature data.
713      my $record = $fq->Feature();      my $record = $fd->Feature();
714      my $extraCols = $fq->ExtraCols();      my $extraCols = $fd->ExtraCols();
715      # Check for a first-call situation.      # Check for a first-call situation.
716      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
717          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
718          $self->{cols} = $self->DefaultFeatureColumns();          # Tell the user what's happening.
719          # Add the externals if they were requested.          $self->PrintLine("Creating output columns.<br />");
720          if ($cgi->param('ShowAliases')) {          # Here we need to set up the column information. First we accumulate the extras,
721              push @{$self->{cols}}, 'alias';          # sorted by column name and separate by whether they go in the beginning or the
722          }          # end.
723          # Append the extras, sorted by column name.          my @xtraNamesFront = ();
724            my @xtraNamesEnd = ();
725            my $xtraPosMap = $self->{extraPos};
726          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
727              push @{$self->{cols}}, "X=$col";              if ($xtraPosMap->{$col}) {
728                    push @xtraNamesEnd, "X=$col";
729                } else {
730                    push @xtraNamesFront, "X=$col";
731                }
732          }          }
733          # Write out the column headers. This also prepares the cache file to receive          # Set up the column name array.
734            my @colNames = ();
735            # Put in the extra columns that go in the beginning.
736            push @colNames, @xtraNamesFront;
737            # Add the default columns.
738            push @colNames, $self->DefaultFeatureColumns();
739            # Add any additional columns requested by the feature filter.
740            push @colNames, FeatureQuery::AdditionalColumns($self);
741            # If extras go at the end, put them in here.
742            push @colNames, @xtraNamesEnd;
743            Trace("Full column list determined.") if T(3);
744            # Save the full list.
745            $self->{cols} = \@colNames;
746            # Write out the column names. This also prepares the cache file to receive
747          # output.          # output.
748          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
749            $self->WriteColumnHeaders(@{$self->{cols}});
750            Trace("Column headers written.") if T(3);
751      }      }
752      # Get the feature ID.      # Get the feature ID.
753      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
754      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
755      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
756        # is to help the various output formatters.
757        my @output = ($fid);
758      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
759          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
760      }      }
761      # Compute the sort key. The sort key floats NMPDR organism features to the      # Compute the sort key. The sort key usually floats NMPDR organism features to the
762      # top of the return list.      # top of the return list.
763      my $key = $self->SortKey($record);      my $key = $self->SortKey($fd);
764      # Write the feature data.      # Write the feature data.
765      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
766  }  }
# Line 707  Line 792 
792      # Write the column headers and close the file.      # Write the column headers and close the file.
793      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colNames);
794      close $handle1;      close $handle1;
795        Trace("Column headers are: " . join("; ", @colNames) . ".") if T(3);
796      # 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
797      # 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
798      # 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 740  Line 826 
826      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
827      # Write them to the cache file.      # Write them to the cache file.
828      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
829        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
830  }  }
831    
832  =head3 CloseSession  =head3 CloseSession
# Line 756  Line 843 
843      # Check for an open session file.      # Check for an open session file.
844      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
845          # We found one, so close it.          # We found one, so close it.
846            Trace("Closing session file.") if T(2);
847          close $self->{fileHandle};          close $self->{fileHandle};
848            # Tell the user.
849            my $cgi = $self->Q();
850            $self->PrintLine("Output formatting complete.<br />");
851      }      }
852  }  }
853    
# Line 785  Line 876 
876    
877  =head3 OrganismData  =head3 OrganismData
878    
879  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>  C<< my ($orgName, $group, $domain) = $shelp->Organism($genomeID); >>
880    
881  Return the name and status of the organism corresponding to the specified genome ID.  Return the name and status of the organism corresponding to the specified genome ID.
882  For performance reasons, this information is cached in a special hash table, so we  For performance reasons, this information is cached in a special hash table, so we
# Line 799  Line 890 
890    
891  =item RETURN  =item RETURN
892    
893  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,
894  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
895  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
896    
897  =back  =back
898    
# Line 811  Line 902 
902      # Get the parameters.      # Get the parameters.
903      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
904      # Declare the return variables.      # Declare the return variables.
905      my ($orgName, $group);      my ($orgName, $group, $domain);
906      # Check the cache.      # Check the cache.
907      my $cache = $self->{orgs};      my $cache = $self->{orgs};
908      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
909          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
910      } else {      } else {
911          # Here we have to use the database.          # Here we have to use the database.
912          my $sprout = $self->DB();          my $sprout = $self->DB();
913          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
914                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
915                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
916                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
917          # Null out the supporting group.                                                                   'Genome(taxonomy)']);
918          $group = "" if ($group eq $FIG_Config::otherGroup);          # Format and cache the name and display group.
919          # If the organism does not exist, format an unknown name.          ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
920          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];  
921      }      }
922      # Return the result.      # Return the result.
923      return ($orgName, $group);      return ($orgName, $group, $domain);
924  }  }
925    
926  =head3 Organism  =head3 Organism
# Line 867  Line 948 
948      # Get the parameters.      # Get the parameters.
949      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
950      # Get the organism data.      # Get the organism data.
951      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
952      # Return the result.      # Return the result.
953      return $retVal;      return $retVal;
954  }  }
# Line 947  Line 1028 
1028    
1029  =head3 ComputeFASTA  =head3 ComputeFASTA
1030    
1031  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
1032    
1033  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
1034  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
1035    
1036  =over 4  =over 4
1037    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
1038  =item desiredType  =item desiredType
1039    
1040  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.  
1041    
1042  =item sequence  =item sequence
1043    
# Line 972  Line 1047 
1047  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
1048  line will be provided.  line will be provided.
1049    
1050    =item flankingWidth
1051    
1052    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
1053    feature that should be included. Currently we can't do this for Proteins because the
1054    protein translation of a feature doesn't always match the DNA and is taken directly
1055    from the database.
1056    
1057  =item RETURN  =item RETURN
1058    
1059  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 984  Line 1066 
1066    
1067  sub ComputeFASTA {  sub ComputeFASTA {
1068      # Get the parameters.      # Get the parameters.
1069      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
1070      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1071      my $retVal;      my $retVal;
1072        # This variable will be cleared if an error is detected.
1073        my $okFlag = 1;
1074      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1075      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1076      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
1077        # Check for a feature specification. The smoking gun for that is a vertical bar.
1078      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1079          # 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
1080          # it.          # it.
1081          my $fid = $1;          my $fid = $1;
1082            Trace("Feature ID for fasta is $fid.") if T(3);
1083          my $sprout = $self->DB();          my $sprout = $self->DB();
1084          # 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
1085          # 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
1086          # exist.          # exist.
1087          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1088          if (! $figID) {          if (! $figID) {
1089              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1090                $okFlag = 0;
1091          } else {          } else {
1092              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1093              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1094                my $favorLen = length $favored;
1095                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1096                if (! $fastaLabel) {
1097                    # In an emergency, fall back to the original ID.
1098                    $fastaLabel = $fid;
1099                }
1100              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1101              if ($desiredType =~ /prot/i) {              if ($desiredType =~ /prot/) {
1102                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1103                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1104                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1105              } else {              } else {
1106                  # 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
1107                    # locations.
1108                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1109                    if ($flankingWidth > 0) {
1110                        # Here we need to add flanking data. Convert the locations to a list
1111                        # of location objects.
1112                        my @locObjects = map { BasicLocation->new($_) } @locList;
1113                        # Initialize the return variable. We will put the DNA in here segment by segment.
1114                        $fastaData = "";
1115                        # Now we widen each location by the flanking width and stash the results. This
1116                        # requires getting the contig length for each contig so we don't fall off the end.
1117                        for my $locObject (@locObjects) {
1118                            Trace("Current location is " . $locObject->String . ".") if T(4);
1119                            # Remember the current start and length.
1120                            my ($start, $len) = ($locObject->Left, $locObject->Length);
1121                            # Get the contig length.
1122                            my $contigLen = $sprout->ContigLength($locObject->Contig);
1123                            # Widen the location and get its DNA.
1124                            $locObject->Widen($flankingWidth, $contigLen);
1125                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
1126                            # Now we need to do some case changing. The main DNA is upper case and
1127                            # the flanking DNA is lower case.
1128                            my $leftFlank = $start - $locObject->Left;
1129                            my $rightFlank = $leftFlank + $len;
1130                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1131                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1132                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1133                                                    lc(substr($fastaSegment, $rightFlank));
1134                            $fastaData .= $fancyFastaSegment;
1135                        }
1136                    } else {
1137                        # Here we have just the raw sequence.
1138                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1139              }              }
1140                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1141                }
1142          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1143      } else {      } else {
1144            Trace("Analyzing FASTA sequence.") if T(4);
1145          # 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.
1146          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1147                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1148              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1149              $fastaLabel = $1;              $fastaLabel = $1;
1150              $fastaData = $2;              $fastaData = $2;
1151          } else {          } else {
1152                Trace("No label found in match to sequence:\n$sequence") if T(4);
1153              # 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
1154              # as data.              # as data.
1155              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1156              $fastaData = $sequence;              $fastaData = $sequence;
1157          }          }
1158          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1159          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1160          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1161          # 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.
1162          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1163          if ($incomingType ne $desiredType) {              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1164              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1165          }          }
1166      }      }
1167      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1168      # in progress.      # Only proceed if no error was detected.
1169      if (defined $fastaLabel) {      if ($okFlag) {
1170            if ($desiredType =~ /pattern/i) {
1171                # We're doing a scan, so only the data is passed in.
1172                $retVal = $fastaData;
1173            } else {
1174          # 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
1175          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1176          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1177          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1178          # the delimiters are what we want.          # the delimiters are what we want.
1179          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1180          my $retVal = join("\n", ">$fastaLabel", @chunks, "");              $retVal = join("\n", ">$fastaLabel", @chunks, "");
1181            }
1182      }      }
1183      # Return the result.      # Return the result.
1184      return $retVal;      return $retVal;
1185  }  }
1186    
1187    =head3 SubsystemTree
1188    
1189    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1190    
1191    This method creates a subsystem selection tree suitable for passing to
1192    L</SelectionTree>. Each leaf node in the tree will have a link to the
1193    subsystem display page. In addition, each node can have a radio button. The
1194    radio button alue is either C<classification=>I<string>, where I<string> is
1195    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1196    Thus, it can either be used to filter by a group of related subsystems or a
1197    single subsystem.
1198    
1199    =over 4
1200    
1201    =item sprout
1202    
1203    Sprout database object used to get the list of subsystems.
1204    
1205    =item options
1206    
1207    Hash containing options for building the tree.
1208    
1209    =item RETURN
1210    
1211    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1212    
1213    =back
1214    
1215    The supported options are as follows.
1216    
1217    =over 4
1218    
1219    =item radio
1220    
1221    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1222    
1223    =item links
1224    
1225    TRUE if the tree should be configured for links. The default is TRUE.
1226    
1227    =back
1228    
1229    =cut
1230    
1231    sub SubsystemTree {
1232        # Get the parameters.
1233        my ($sprout, %options) = @_;
1234        # Process the options.
1235        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1236        # Read in the subsystems.
1237        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1238                                   ['Subsystem(classification)', 'Subsystem(id)']);
1239        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1240        # is at the end, ALL subsystems are unclassified and we don't bother.
1241        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1242            while ($subs[0]->[0] eq '') {
1243                my $classLess = shift @subs;
1244                push @subs, $classLess;
1245            }
1246        }
1247        # Declare the return variable.
1248        my @retVal = ();
1249        # Each element in @subs represents a leaf node, so as we loop through it we will be
1250        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1251        # first element is a semi-colon-delimited list of the classifications for the
1252        # subsystem. There will be a stack of currently-active classifications, which we will
1253        # compare to the incoming classifications from the end backward. A new classification
1254        # requires starting a new branch. A different classification requires closing an old
1255        # branch and starting a new one. Each classification in the stack will also contain
1256        # that classification's current branch. We'll add a fake classification at the
1257        # beginning that we can use to represent the tree as a whole.
1258        my $rootName = '<root>';
1259        # Create the classification stack. Note the stack is a pair of parallel lists,
1260        # one containing names and the other containing content.
1261        my @stackNames = ($rootName);
1262        my @stackContents = (\@retVal);
1263        # Add a null entry at the end of the subsystem list to force an unrolling.
1264        push @subs, ['', undef];
1265        # Loop through the subsystems.
1266        for my $sub (@subs) {
1267            # Pull out the classification list and the subsystem ID.
1268            my ($classString, $id) = @{$sub};
1269            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1270            # Convert the classification string to a list with the root classification in
1271            # the front.
1272            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1273            # Find the leftmost point at which the class list differs from the stack.
1274            my $matchPoint = 0;
1275            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1276                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1277                $matchPoint++;
1278            }
1279            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1280                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1281            # Unroll the stack to the matchpoint.
1282            while ($#stackNames >= $matchPoint) {
1283                my $popped = pop @stackNames;
1284                pop @stackContents;
1285                Trace("\"$popped\" popped from stack.") if T(4);
1286            }
1287            # Start branches for any new classifications.
1288            while ($#stackNames < $#classList) {
1289                # The branch for a new classification contains its radio button
1290                # data and then a list of children. So, at this point, if radio buttons
1291                # are desired, we put them into the content.
1292                my $newLevel = scalar(@stackNames);
1293                my @newClassContent = ();
1294                if ($optionThing->{radio}) {
1295                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1296                    push @newClassContent, { value => "classification=$newClassString%" };
1297                }
1298                # The new classification node is appended to its parent's content
1299                # and then pushed onto the stack. First, we need the node name.
1300                my $nodeName = $classList[$newLevel];
1301                # Add the classification to its parent. This makes it part of the
1302                # tree we'll be returning to the user.
1303                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1304                # Push the classification onto the stack.
1305                push @stackContents, \@newClassContent;
1306                push @stackNames, $nodeName;
1307                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1308            }
1309            # Now the stack contains all our parent branches. We add the subsystem to
1310            # the branch at the top of the stack, but only if it's NOT the dummy node.
1311            if (defined $id) {
1312                # Compute the node name from the ID.
1313                my $nodeName = $id;
1314                $nodeName =~ s/_/ /g;
1315                # Create the node's leaf hash. This depends on the value of the radio
1316                # and link options.
1317                my $nodeContent = {};
1318                if ($optionThing->{links}) {
1319                    # Compute the link value.
1320                    my $linkable = uri_escape($id);
1321                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1322                }
1323                if ($optionThing->{radio}) {
1324                    # Compute the radio value.
1325                    $nodeContent->{value} = "id=$id";
1326                }
1327                # Push the node into its parent branch.
1328                Trace("\"$nodeName\" added to node list.") if T(4);
1329                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1330            }
1331        }
1332        # Return the result.
1333        return \@retVal;
1334    }
1335    
1336    
1337  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1338    
1339  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
# Line 1082  Line 1363 
1363  Number of rows to display. If omitted, the default is 1 for a single-select list  Number of rows to display. If omitted, the default is 1 for a single-select list
1364  and 10 for a multi-select list.  and 10 for a multi-select list.
1365    
1366    =item crossMenu (optional)
1367    
1368    If specified, is presumed to be the name of another genome menu whose contents
1369    are to be mutually exclusive with the contents of this menu. As a result, instead
1370    of the standard onChange event, the onChange event will deselect any entries in
1371    the other menu.
1372    
1373  =item RETURN  =item RETURN
1374    
1375  Returns the HTML text to generate a C<SELECT> menu inside a form.  Returns the HTML text to generate a C<SELECT> menu inside a form.
# Line 1092  Line 1380 
1380    
1381  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1382      # Get the parameters.      # Get the parameters.
1383      my ($self, $menuName, $multiple, $selected, $rows) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1384      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1385      my $sprout = $self->DB();      my $sprout = $self->DB();
1386      my $cgi = $self->Q();      my $cgi = $self->Q();
# Line 1105  Line 1393 
1393      # Get the form name.      # Get the form name.
1394      my $formName = $self->FormName();      my $formName = $self->FormName();
1395      # 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};  
1396      my $groupHash;      my $groupHash;
1397        my @groups;
1398        my $nmpdrGroupCount;
1399        my $genomes = $self->{genomeList};
1400      if (defined $genomes) {      if (defined $genomes) {
1401          # We have a list ready to use.          # We have a list ready to use.
1402          $groupHash = $genomes;          $groupHash = $genomes;
1403            @groups = @{$self->{groupList}};
1404            $nmpdrGroupCount = $self->{groupCount};
1405      } else {      } else {
1406          # 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
1407          # 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 1118  Line 1410 
1410                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1411                                           [], ['Genome(primary-group)', 'Genome(id)',                                           [], ['Genome(primary-group)', 'Genome(id)',
1412                                                'Genome(genus)', 'Genome(species)',                                                'Genome(genus)', 'Genome(species)',
1413                                                'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1414                                                  'Genome(taxonomy)']);
1415          # 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
1416          # 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
1417          # name.          # name.
1418          my %gHash = ();          my %gHash = ();
1419          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1420              # Get the genome data.              # Get the genome data.
1421              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1422              # Form the genome name.              # Compute and cache its name and display group.
1423              my $name = "$genus $species";              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1424              if ($strain) {                                                                           $strain, $taxonomy);
1425                  $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1426                # name here, not the display group name.
1427                push @{$gHash{$group}}, [$genomeID, $name, $domain];
1428            }
1429            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1430            # the supporting genomes by domain. First, we sort the NMPDR groups.
1431            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1432            # Remember the number of NMPDR groups.
1433            $nmpdrGroupCount = scalar @groups;
1434            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1435            # of the domains found.
1436            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1437            my @domains = ();
1438            for my $genomeData (@otherGenomes) {
1439                my ($genomeID, $name, $domain) = @{$genomeData};
1440                if (exists $gHash{$domain}) {
1441                    push @{$gHash{$domain}}, $genomeData;
1442                } else {
1443                    $gHash{$domain} = [$genomeData];
1444                    push @domains, $domain;
1445              }              }
             # Push the genome into the group's list.  
             push @{$gHash{$group}}, [$genomeID, $name];  
1446          }          }
1447            # Add the domain groups at the end of the main group list. The main group list will now
1448            # contain all the categories we need to display the genomes.
1449            push @groups, sort @domains;
1450            # Delete the supporting group.
1451            delete $gHash{$FIG_Config::otherGroup};
1452          # Save the genome list for future use.          # Save the genome list for future use.
1453          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1454            $self->{groupList} = \@groups;
1455            $self->{groupCount} = $nmpdrGroupCount;
1456          $groupHash = \%gHash;          $groupHash = \%gHash;
1457      }      }
     # 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;  
1458      # 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
1459      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1460      my %selectedHash = ();      my %selectedHash = ();
1461      if (defined $selected) {      if (defined $selected) {
1462          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1463      }      }
1464      # 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
1465        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1466        # and use that to make the selections.
1467        my $nmpdrCount = 0;
1468      # Create the type counters.      # Create the type counters.
1469      my $groupCount = 1;      my $groupCount = 1;
1470      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 1157  Line 1473 
1473      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1474      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1475      my $onChange = "";      my $onChange = "";
1476      if ($multiple) {      if ($cross) {
1477            # Here we have a paired menu. Selecting something in our menu unselects it in the
1478            # other and redisplays the status of both.
1479            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1480        } elsif ($multiple) {
1481            # This is an unpaired menu, so all we do is redisplay our status.
1482          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1483      }      }
1484      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1485      my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1486      # Loop through the groups.      # Loop through the groups.
1487      for my $group (@groups) {      for my $group (@groups) {
1488          # Create the option group tag.          # Create the option group tag.
1489          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1490          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");  
1491          # Get the genomes in the group.          # Get the genomes in the group.
1492          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1493              my ($genomeID, $name) = @{$genome};              # Count this organism if it's NMPDR.
1494                if ($nmpdrGroupCount > 0) {
1495                    $nmpdrCount++;
1496                }
1497                # Get the organism ID, name, and domain.
1498                my ($genomeID, $name, $domain) = @{$genome};
1499              # See if it's selected.              # See if it's selected.
1500              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1501              # Generate the option tag.              # Generate the option tag.
1502              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>";
1503              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1504          }          }
1505          # Close the option group.          # Close the option group.
1506          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1507            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1508            # groups.
1509            $nmpdrGroupCount--;
1510      }      }
1511      # Close the SELECT tag.      # Close the SELECT tag.
1512      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1513      # Check for multiple selection.      # Check for multiple selection.
1514      if ($multiple) {      if ($multiple) {
1515          # 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
1516          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  
1517          # the text selected automatically.          # the text selected automatically.
1518          my $searchThingName = "${menuName}_SearchThing";          my $searchThingName = "${menuName}_SearchThing";
1519          push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .          push @lines, "<br />" .
1520                       "<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;" .
1521                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1522            # Next are the buttons to set and clear selections.
1523            push @lines, "<br />";
1524            push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1525            push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1526            push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1527            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1528          # Add the status display, too.          # Add the status display, too.
1529          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1530          # 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 1287  Line 1611 
1611  =item rows  =item rows
1612    
1613  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
1614  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
1615  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1616    
1617  =item RETURN  =item RETURN
1618    
# Line 1303  Line 1627 
1627      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1628      # Get the CGI object.      # Get the CGI object.
1629      my $cgi = $self->Q();      my $cgi = $self->Q();
1630      # 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.
1631        # This flag will be set to FALSE when that happens.
1632        my $needWidth = 1;
1633      # 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
1634      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1635      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1636          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1637            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1638                # Here we have a first cell and its tag parameters are in $2.
1639                my $elements = $2;
1640                if ($elements !~ /colspan/i) {
1641                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1642                    # Here there's no colspan, so we plug in the width. We
1643                    # eschew the "g" modifier on the substitution because we
1644                    # only want to update the first cell.
1645                    $row =~ s/(<(td|th))/$1 width="150"/i;
1646                    # Denote we don't need this any more.
1647                    $needWidth = 0;
1648                }
1649            }
1650      }      }
1651      # Create the table.      # Create the table.
1652      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1319  Line 1658 
1658    
1659  =head3 SubmitRow  =head3 SubmitRow
1660    
1661  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1662    
1663  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1664  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1665  near the top of the form.  near the top of the form.
1666    
1667    =over 4
1668    
1669    =item caption (optional)
1670    
1671    Caption to be put on the search button. The default is C<Go>.
1672    
1673    =item RETURN
1674    
1675    Returns a table row containing the controls for submitting the search
1676    and tuning the results.
1677    
1678    =back
1679    
1680  =cut  =cut
1681    
1682  sub SubmitRow {  sub SubmitRow {
1683      # Get the parameters.      # Get the parameters.
1684      my ($self) = @_;      my ($self, $caption) = @_;
1685      my $cgi = $self->Q();      my $cgi = $self->Q();
1686        # Compute the button caption.
1687        my $realCaption = (defined $caption ? $caption : 'Go');
1688      # Get the current page size.      # Get the current page size.
1689      my $pageSize = $cgi->param('PageSize');      my $pageSize = $cgi->param('PageSize');
1690      # Get the incoming external-link flag.      # Get the incoming external-link flag.
# Line 1338  Line 1692 
1692      # Create the row.      # Create the row.
1693      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1694                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1695                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1696                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
1697                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1698                                                  -name => 'Search',                                                  -name => 'Search',
1699                                                  -value => 'Go')));                                                  -value => $realCaption)));
1700      # Return the result.      # Return the result.
1701      return $retVal;      return $retVal;
1702  }  }
1703    
1704  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1705    
1706  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1707    
1708    This method creates table rows that can be used to filter features. The form
1709    values can be used to select features by genome using the B<FeatureQuery>
1710    object.
1711    
1712    =over 4
1713    
1714    =item subset
1715    
1716    List of rows to display. The default (C<all>) is to display all rows.
1717    C<words> displays the word search box, C<subsys> displays the subsystem
1718    selector, and C<options> displays the options row.
1719    
1720    =item RETURN
1721    
1722    Returns the html text for table rows containing the desired feature filtering controls.
1723    
1724  This method creates table rows that can be used to filter features. There are  =back
 two rows returned, and the values can be used to select features by genome  
 using the B<FeatureQuery> object.  
1725    
1726  =cut  =cut
1727    
1728  sub FeatureFilterRows {  sub FeatureFilterRows {
1729      # Get the parameters.      # Get the parameters.
1730      my ($self) = @_;      my ($self, @subset) = @_;
1731        if (@subset == 0 || $subset[0] eq 'all') {
1732            @subset = qw(words subsys options);
1733        }
1734      # Return the result.      # Return the result.
1735      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1736  }  }
1737    
1738  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1406  Line 1774 
1774          # Get the feature location string.          # Get the feature location string.
1775          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1776          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1777          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1778          Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);          Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1779          # Now we need to do some goofiness to insure that the location is not too          # Now we need to do some goofiness to insure that the location is not too
1780          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
# Line 1439  Line 1807 
1807          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1808          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);
1809          # Assemble all the pieces.          # Assemble all the pieces.
1810          $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";
1811      }      }
1812      # Return the result.      # Return the result.
1813      return $retVal;      return $retVal;
# Line 1532  Line 1900 
1900    
1901  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1902    
1903  C<< my $url = $shelp->ComputeSearchURL(); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1904    
1905  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
1906  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 1542  Line 1910 
1910  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
1911  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1912    
1913    =over 4
1914    
1915    =item overrides
1916    
1917    Hash containing override values for the parameters, where the parameter name is
1918    the key and the parameter value is the override value. If the override value is
1919    C<undef>, the parameter will be deleted from the result.
1920    
1921    =item RETURN
1922    
1923    Returns a GET-style URL for invoking the search with the specified overrides.
1924    
1925    =back
1926    
1927  =cut  =cut
1928    
1929  sub ComputeSearchURL {  sub ComputeSearchURL {
1930      # Get the parameters.      # Get the parameters.
1931      my ($self) = @_;      my ($self, %overrides) = @_;
1932      # Get the database and CGI query object.      # Get the database and CGI query object.
1933      my $cgi = $self->Q();      my $cgi = $self->Q();
1934      my $sprout = $self->DB();      my $sprout = $self->DB();
# Line 1573  Line 1955 
1955          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1956          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1957          # Check for special cases.          # Check for special cases.
1958          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)) {  
1959              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1960              @values = ();              @values = ();
1961          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1601  Line 1969 
1969              if ($allFlag) {              if ($allFlag) {
1970                  @values = ();                  @values = ();
1971              }              }
1972            } elsif (exists $overrides{$parmKey}) {
1973                # Here the value is being overridden, so we skip it for now.
1974                @values = ();
1975          }          }
1976          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1977          if (@values) {          if (@values) {
1978              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1979          }          }
1980      }      }
1981        # Now do the overrides.
1982        for my $overKey (keys %overrides) {
1983            # Only use this override if it's not a delete marker.
1984            if (defined $overrides{$overKey}) {
1985                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1986            }
1987        }
1988      # Add the parameters to the URL.      # Add the parameters to the URL.
1989      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1990      # Return the result.      # Return the result.
# Line 1649  Line 2027 
2027      return $retVal;      return $retVal;
2028  }  }
2029    
2030  =head2 Feature Column Methods  =head3 AdvancedClassList
   
 The methods in this column manage feature column data. If you want to provide the  
 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.  
   
 There is one special column name syntax for extra columns (that is, nonstandard  
 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.  
2031    
2032  =head3 DefaultFeatureColumns  C<< my @classes = SearchHelper::AdvancedClassList(); >>
2033    
2034  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Return a list of advanced class names. This list is used to generate the directory
2035    of available searches on the search page.
2036    
2037  Return a reference to a list of the default feature column identifiers. These  We use the %INC variable to accomplish this.
 identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
 order to produce the column titles and row values.  
2038    
2039  =cut  =cut
2040    
2041  sub DefaultFeatureColumns {  sub AdvancedClassList {
2042      # Get the parameters.      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2043      my ($self) = @_;      return sort @retVal;
     # Return the result.  
     return ['orgName', 'function', 'gblink', 'protlink',  
             FeatureQuery::AdditionalColumns($self)];  
2044  }  }
2045    
2046  =head3 FeatureColumnTitle  =head3 SelectionTree
2047    
2048  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
2049    
2050  Return the column heading title to be used for the specified feature column.  Display a selection tree.
2051    
2052    This method creates the HTML for a tree selection control. The tree is implemented as a set of
2053    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
2054    addition, some of the tree nodes can contain hyperlinks.
2055    
2056    The tree itself is passed in as a multi-level list containing node names followed by
2057    contents. Each content element is a reference to a similar list. The first element of
2058    each list may be a hash reference. If so, it should contain one or both of the following
2059    keys.
2060    
2061    =over 4
2062    
2063    =item link
2064    
2065    The navigation URL to be popped up if the user clicks on the node name.
2066    
2067    =item value
2068    
2069    The form value to be returned if the user selects the tree node.
2070    
2071    =back
2072    
2073    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
2074    a C<value> key indicates the node name will have a radio button. If a node has no children,
2075    you may pass it a hash reference instead of a list reference.
2076    
2077    The following example shows the hash for a three-level tree with links on the second level and
2078    radio buttons on the third.
2079    
2080        [   Objects => [
2081                Entities => [
2082                    {link => "../docs/WhatIsAnEntity.html"},
2083                    Genome => {value => 'GenomeData'},
2084                    Feature => {value => 'FeatureData'},
2085                    Contig => {value => 'ContigData'},
2086                ],
2087                Relationships => [
2088                    {link => "../docs/WhatIsARelationShip.html"},
2089                    HasFeature => {value => 'GenomeToFeature'},
2090                    IsOnContig => {value => 'FeatureToContig'},
2091                ]
2092            ]
2093        ]
2094    
2095    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
2096    all have list references.
2097    
2098    This next example shows how to set up a taxonomy selection field. The value returned
2099    by the tree control will be the taxonomy string for the selected node ready for use
2100    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
2101    reasons of space.
2102    
2103        [   All => [
2104                {value => "%"},
2105                Bacteria => [
2106                    {value => "Bacteria%"},
2107                    Proteobacteria => [
2108                        {value => "Bacteria; Proteobacteria%"},
2109                        Epsilonproteobacteria => [
2110                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
2111                            Campylobacterales => [
2112                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
2113                                Campylobacteraceae =>
2114                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
2115                                ...
2116                            ]
2117                            ...
2118                        ]
2119                        ...
2120                    ]
2121                    ...
2122                ]
2123                ...
2124            ]
2125        ]
2126    
2127    
2128    This method of tree storage allows the caller to control the order in which the tree nodes
2129    are displayed and to completely control value selection and use of hyperlinks. It is, however
2130    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
2131    
2132    The parameters to this method are as follows.
2133    
2134    =over 4
2135    
2136    =item cgi
2137    
2138    CGI object used to generate the HTML.
2139    
2140    =item tree
2141    
2142    Reference to a hash describing a tree. See the description above.
2143    
2144    =item options
2145    
2146    Hash containing options for the tree display.
2147    
2148    =back
2149    
2150    The allowable options are as follows
2151    
2152  =over 4  =over 4
2153    
2154    =item nodeImageClosed
2155    
2156    URL of the image to display next to the tree nodes when they are collapsed. Clicking
2157    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
2158    
2159    =item nodeImageOpen
2160    
2161    URL of the image to display next to the tree nodes when they are expanded. Clicking
2162    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
2163    
2164    =item style
2165    
2166    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
2167    as nested lists, the key components of this style are the definitions for the C<ul> and
2168    C<li> tags. The default style file contains the following definitions.
2169    
2170        .tree ul {
2171           margin-left: 0; padding-left: 22px
2172        }
2173        .tree li {
2174            list-style-type: none;
2175        }
2176    
2177    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
2178    parent by the width of the node image. This use of styles limits the things we can do in formatting
2179    the tree, but it has the advantage of vastly simplifying the tree creation.
2180    
2181  =item name  =item name
2182    
2183  Name of the desired feature column.  Field name to give to the radio buttons in the tree. The default is C<selection>.
2184    
2185  =item RETURN  =item target
2186    
2187  Returns the title to be used as the column header for the named feature column.  Frame target for links. The default is C<_self>.
2188    
2189    =item selected
2190    
2191    If specified, the value of the radio button to be pre-selected.
2192    
2193  =back  =back
2194    
2195  =cut  =cut
2196    
2197  sub FeatureColumnTitle {  sub SelectionTree {
2198      # Get the parameters.      # Get the parameters.
2199      my ($self, $colName) = @_;      my ($cgi, $tree, %options) = @_;
2200      # Declare the return variable. We default to a blank column name.      # Get the options.
2201      my $retVal = "&nbsp;";      my $optionThing = Tracer::GetOptions({ name => 'selection',
2202      # Process the column name.                                             nodeImageClosed => '../FIG/Html/plus.gif',
2203      if ($colName =~ /^X=(.+)$/) {                                             nodeImageOpen => '../FIG/Html/minus.gif',
2204          # Here we have an extra column.                                             style => 'tree',
2205          $retVal = $1;                                             target => '_self',
2206      } elsif ($colName eq 'orgName') {                                             selected => undef},
2207          $retVal = "Name";                                           \%options);
2208      } elsif ($colName eq 'fid') {      # Declare the return variable. We'll do the standard thing with creating a list
2209          $retVal = "FIG ID";      # of HTML lines and rolling them together at the end.
2210      } elsif ($colName eq 'alias') {      my @retVal = ();
2211          $retVal = "External Aliases";      # Only proceed if the tree is present.
2212      } elsif ($colName eq 'function') {      if (defined($tree)) {
2213          $retVal = "Functional Assignment";          # Validate the tree.
2214      } elsif ($colName eq 'gblink') {          if (ref $tree ne 'ARRAY') {
2215          $retVal = "GBrowse";              Confess("Selection tree is not a list reference.");
2216      } elsif ($colName eq 'protlink') {          } elsif (scalar @{$tree} == 0) {
2217          $retVal = "NMPDR Protein Page";              # The tree is empty, so we do nothing.
2218      } elsif ($colName eq 'group') {          } elsif ($tree->[0] eq 'HASH') {
2219          $retVal = "NMDPR Group";              Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2220            } else {
2221                # Here we have a real tree. Apply the tree style.
2222                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2223                # Give us a DIV ID.
2224                my $divID = GetDivID($optionThing->{name});
2225                # Show the tree.
2226                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2227                # Close the DIV block.
2228                push @retVal, $cgi->end_div();
2229            }
2230      }      }
2231      # Return the result.      # Return the result.
2232      return $retVal;      return join("\n", @retVal, "");
2233  }  }
2234    
2235  =head3 FeatureColumnValue  =head3 ShowBranch
2236    
2237  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2238    
2239  Return the value to be displayed in the specified feature column.  This is a recursive method that displays a branch of the tree.
2240    
2241  =over 4  =over 4
2242    
2243  =item colName  =item cgi
2244    
2245  Name of the column to be displayed.  CGI object used to format HTML.
2246    
2247  =item record  =item label
2248    
2249  DBObject record for the feature being displayed in the current row.  Label of this tree branch. It is only used in error messages.
2250    
2251  =item extraCols  =item id
2252    
2253  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
2254  begins with C<X=>, its value will be taken from this hash.  tree nodes.
2255    
2256    =item branch
2257    
2258    Reference to a list containing the content of the tree branch. The list contains an optional
2259    hash reference that is ignored and the list of children, each child represented by a name
2260    and then its contents. The contents could by a hash reference (indicating the attributes
2261    of a leaf node), or another tree branch.
2262    
2263    =item options
2264    
2265    Options from the original call to L</SelectionTree>.
2266    
2267    =item displayType
2268    
2269    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2270    hidden.
2271    
2272  =item RETURN  =item RETURN
2273    
2274  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.
2275    
2276    =back
2277    
2278    =cut
2279    
2280    sub ShowBranch {
2281        # Get the parameters.
2282        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2283        # Declare the return variable.
2284        my @retVal = ();
2285        # Start the branch.
2286        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2287        # Check for the hash and choose the start location accordingly.
2288        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2289        # Get the list length.
2290        my $i1 = scalar(@{$branch});
2291        # Verify we have an even number of elements.
2292        if (($i1 - $i0) % 2 != 0) {
2293            Trace("Branch elements are from $i0 to $i1.") if T(3);
2294            Confess("Odd number of elements in tree branch $label.");
2295        } else {
2296            # Loop through the elements.
2297            for (my $i = $i0; $i < $i1; $i += 2) {
2298                # Get this node's label and contents.
2299                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2300                # Get an ID for this node's children (if any).
2301                my $myID = GetDivID($options->{name});
2302                # Now we need to find the list of children and the options hash.
2303                # This is a bit ugly because we allow the shortcut of a hash without an
2304                # enclosing list. First, we need some variables.
2305                my $attrHash = {};
2306                my @childHtml = ();
2307                my $hasChildren = 0;
2308                if (! ref $myContent) {
2309                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2310                } elsif (ref $myContent eq 'HASH') {
2311                    # Here the node is a leaf and its content contains the link/value hash.
2312                    $attrHash = $myContent;
2313                } elsif (ref $myContent eq 'ARRAY') {
2314                    # Here the node may be a branch. Its content is a list.
2315                    my $len = scalar @{$myContent};
2316                    if ($len >= 1) {
2317                        # Here the first element of the list could by the link/value hash.
2318                        if (ref $myContent->[0] eq 'HASH') {
2319                            $attrHash = $myContent->[0];
2320                            # If there's data in the list besides the hash, it's our child list.
2321                            # We can pass the entire thing as the child list, because the hash
2322                            # is ignored.
2323                            if ($len > 1) {
2324                                $hasChildren = 1;
2325                            }
2326                        } else {
2327                            $hasChildren = 1;
2328                        }
2329                        # If we have children, create the child list with a recursive call.
2330                        if ($hasChildren) {
2331                            Trace("Processing children of $myLabel.") if T(4);
2332                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2333                            Trace("Children of $myLabel finished.") if T(4);
2334                        }
2335                    }
2336                }
2337                # Okay, it's time to pause and take stock. We have the label of the current node
2338                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2339                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2340                # Compute the image HTML. It's tricky, because we have to deal with the open and
2341                # closed images.
2342                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2343                my $image = $images[$hasChildren];
2344                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2345                if ($hasChildren) {
2346                    # If there are children, we wrap the image in a toggle hyperlink.
2347                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2348                                          $prefixHtml);
2349                }
2350                # Now the radio button, if any. Note we use "defined" in case the user wants the
2351                # value to be 0.
2352                if (defined $attrHash->{value}) {
2353                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2354                    # hash for the "input" method. If the item is pre-selected, we add
2355                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2356                    # at all.
2357                    my $radioParms = { type => 'radio',
2358                                       name => $options->{name},
2359                                       value => $attrHash->{value},
2360                                     };
2361                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2362                        $radioParms->{checked} = undef;
2363                    }
2364                    $prefixHtml .= $cgi->input($radioParms);
2365                }
2366                # Next, we format the label.
2367                my $labelHtml = $myLabel;
2368                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2369                # Apply a hyperlink if necessary.
2370                if (defined $attrHash->{link}) {
2371                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2372                                         $labelHtml);
2373                }
2374                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2375                # here.
2376                my $childHtml = join("\n", @childHtml);
2377                # Now we have all the pieces, so we can put them together.
2378                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2379            }
2380        }
2381        # Close the tree branch.
2382        push @retVal, $cgi->end_ul();
2383        # Return the result.
2384        return @retVal;
2385    }
2386    
2387    =head3 GetDivID
2388    
2389    C<< my $idString = SearchHelper::GetDivID($name); >>
2390    
2391    Return a new HTML ID string.
2392    
2393    =over 4
2394    
2395    =item name
2396    
2397    Name to be prefixed to the ID string.
2398    
2399    =item RETURN
2400    
2401    Returns a hopefully-unique ID string.
2402    
2403    =back
2404    
2405    =cut
2406    
2407    sub GetDivID {
2408        # Get the parameters.
2409        my ($name) = @_;
2410        # Compute the ID.
2411        my $retVal = "elt_$name$divCount";
2412        # Increment the counter to make sure this ID is not re-used.
2413        $divCount++;
2414        # Return the result.
2415        return $retVal;
2416    }
2417    
2418    
2419    =head3 PrintLine
2420    
2421    C<< $shelp->PrintLine($message); >>
2422    
2423    Print a line of CGI output. This is used during the operation of the B<Find> method while
2424    searching, so the user sees progress in real-time.
2425    
2426    =over 4
2427    
2428    =item message
2429    
2430    HTML text to display.
2431    
2432    =back
2433    
2434    =cut
2435    
2436    sub PrintLine {
2437        # Get the parameters.
2438        my ($self, $message) = @_;
2439        # Send them to the output.
2440        print "$message\n";
2441    }
2442    
2443    =head2 Feature Column Methods
2444    
2445    The methods in this section manage feature column data. If you want to provide the
2446    capability to include new types of data in feature columns, then all the changes
2447    are made to this section of the source file. Technically, this should be implemented
2448    using object-oriented methods, but this is simpler for non-programmers to maintain.
2449    To add a new column of feature data, you must first give it a name. For example,
2450    the name for the protein page link column is C<protlink>. If the column is to appear
2451    in the default list of feature columns, add it to the list returned by
2452    L</DefaultFeatureColumns>. Then add code to produce the column title to
2453    L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2454    feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2455    hash. Everything else will happen automatically.
2456    
2457    There is a special column name syntax for extra columns (that is, nonstandard
2458    feature columns). If the column name begins with C<X=>, then it is presumed to be
2459    an extra column. The column title is the text after the C<X=>, and its value is
2460    pulled from the extra column hash.
2461    
2462    =cut
2463    
2464    # This hash is used to determine which columns should not be included in downloads.
2465    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2466    
2467    =head3 DefaultFeatureColumns
2468    
2469    C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2470    
2471    Return a list of the default feature column identifiers. These identifiers can
2472    be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2473    produce the column titles and row values.
2474    
2475    =cut
2476    
2477    sub DefaultFeatureColumns {
2478        # Get the parameters.
2479        my ($self) = @_;
2480        # Return the result.
2481        return qw(orgName function gblink protlink);
2482    }
2483    
2484    =head3 FeatureColumnTitle
2485    
2486    C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2487    
2488    Return the column heading title to be used for the specified feature column.
2489    
2490    =over 4
2491    
2492    =item name
2493    
2494    Name of the desired feature column.
2495    
2496    =item RETURN
2497    
2498    Returns the title to be used as the column header for the named feature column.
2499    
2500    =back
2501    
2502    =cut
2503    
2504    sub FeatureColumnTitle {
2505        # Get the parameters.
2506        my ($self, $colName) = @_;
2507        # Declare the return variable. We default to a blank column name.
2508        my $retVal = "&nbsp;";
2509        # Process the column name.
2510        if ($colName =~ /^X=(.+)$/) {
2511            # Here we have an extra column.
2512            $retVal = $1;
2513        } elsif ($colName eq 'alias') {
2514            $retVal = "External Aliases";
2515        } elsif ($colName eq 'fid') {
2516            $retVal = "FIG ID";
2517        } elsif ($colName eq 'function') {
2518            $retVal = "Functional Assignment";
2519        } elsif ($colName eq 'gblink') {
2520            $retVal = "GBrowse";
2521        } elsif ($colName eq 'group') {
2522            $retVal = "NMDPR Group";
2523        } elsif ($colName =~ /^keyword:(.+)$/) {
2524            $retVal = ucfirst $1;
2525        } elsif ($colName eq 'orgName') {
2526            $retVal = "Organism and Gene ID";
2527        } elsif ($colName eq 'protlink') {
2528            $retVal = "NMPDR Protein Page";
2529        } elsif ($colName eq 'viewerlink') {
2530            $retVal = "Annotation Page";
2531        } elsif ($colName eq 'subsystem') {
2532            $retVal = "Subsystems";
2533        } elsif ($colName eq 'pdb') {
2534            $retVal = "Best PDB Match";
2535        }
2536        # Return the result.
2537        return $retVal;
2538    }
2539    
2540    =head3 FeatureColumnDownload
2541    
2542    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2543    
2544    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2545    
2546    =over 4
2547    
2548    =item colName
2549    
2550    Name of the relevant feature column.
2551    
2552    =item RETURN
2553    
2554    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2555    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2556    
2557    =back
2558    
2559    =cut
2560    
2561    sub FeatureColumnDownload {
2562        # Get the parameters.
2563        my ($self, $colName) = @_;
2564        # Return the determination. We download the column if it's not in the skip-hash.
2565        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2566        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2567    }
2568    
2569    
2570    =head3 FeatureColumnValue
2571    
2572    C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
2573    
2574    Return the value to be displayed in the specified feature column.
2575    
2576    =over 4
2577    
2578    =item colName
2579    
2580    Name of the column to be displayed.
2581    
2582    =item record
2583    
2584    ERDBObject record for the feature being displayed in the current row.
2585    
2586    =item extraCols
2587    
2588    Reference to a hash of extra column names to values. If the incoming column name
2589    begins with C<X=>, its value will be taken from this hash.
2590    
2591    =item RETURN
2592    
2593    Returns the HTML to be displayed in the named column for the specified feature.
2594    
2595  =back  =back
2596    
# Line 1783  Line 2617 
2617          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2618              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2619          }          }
     } 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);  
2620      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2621          # 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.
2622          # 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.
2623          $retVal = "%%aliases=$fid";          # To do the computation, we need to know the favored alias type and the
2624            # feature ID.
2625            my $favored = $cgi->param("FavoredAlias") || "fig";
2626            $retVal = "%%alias=$fid,$favored";
2627        } elsif ($colName eq 'fid') {
2628            # Here we have the raw feature ID. We hyperlink it to the protein page.
2629            $retVal = HTML::set_prot_links($fid);
2630      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2631          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2632          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2633      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2634          # 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.
2635          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2636          $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 })  
                          );  
2637      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2638          # Get the NMPDR group name.          # Get the NMPDR group name.
2639          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1817  Line 2641 
2641          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2642          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2643                            $group);                            $group);
2644        } elsif ($colName =~ /^keyword:(.+)$/) {
2645            # Here we want keyword-related values. This is also expensive, so
2646            # we compute them when the row is displayed.
2647            $retVal = "%%$colName=$fid";
2648        } elsif ($colName eq 'orgName') {
2649            # Here we want the formatted organism name and feature number.
2650            $retVal = $self->FeatureName($fid);
2651        } elsif ($colName eq 'protlink') {
2652            # Here we want a link to the protein page using the official NMPDR button.
2653            $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2654                              prot => $fid, SPROUT => 1, new_framework => 0,
2655                              user => '');
2656        } elsif ($colName eq 'viewerlink') {
2657            # Here we want a link to the SEED viewer page using the official viewer button.
2658            $retVal = FakeButton('Annotation', "index.cgi", undef,
2659                                 action => 'ShowAnnotation', prot => $fid);
2660        } elsif ($colName eq 'subsystem') {
2661            # Another run-time column: subsystem list.
2662            $retVal = "%%subsystem=$fid";
2663        } elsif ($colName eq 'pdb') {
2664            $retVal = "%%pdb=$fid";
2665      }      }
2666      # Return the result.      # Return the result.
2667      return $retVal;      return $retVal;
# Line 1855  Line 2700 
2700      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
2701      my $sprout = $self->DB();      my $sprout = $self->DB();
2702      my $cgi = $self->Q();      my $cgi = $self->Q();
2703        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2704      # Separate the text into a type and data.      # Separate the text into a type and data.
2705      if ($type eq 'aliases') {      if ($type eq 'alias') {
2706          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2707          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2708          my $fid = $text;          # the favored alias type.
2709          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2710          # aliases.          # The complicated part is we have to hyperlink them and handle the
2711            # favorites. First, get the aliases.
2712          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2713          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2714          # Only proceed if we found some.          # Only proceed if we found some.
2715          if (@aliases) {          if (@aliases) {
2716              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2717              my $aliasList = join(", ", @aliases);              my @favored = ();
2718                my @unfavored = ();
2719                for my $alias (@aliases) {
2720                    # Use substr instead of pattern match because $favored is specified by the user
2721                    # and we don't want him to put funny meta-characters in there.
2722                    if (substr($alias, 0, length($favored)) eq $favored) {
2723                        push @favored, $alias;
2724                    } else {
2725                        push @unfavored, $alias;
2726                    }
2727                }
2728                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2729                my $aliasList = join(", ", @favored, @unfavored);
2730              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2731              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2732          }          }
2733        } elsif ($type eq 'subsystem') {
2734            # Here the caller wants the subsystems in which this feature participates.
2735            # The text is the feature ID. We will list the subsystem names with links
2736            # to the subsystem's summary page.
2737            my $fid = $text;
2738            # Get the subsystems.
2739            Trace("Generating subsystems for feature $fid.") if T(4);
2740            my %subs = $sprout->SubsystemsOf($fid);
2741            # Extract the subsystem names.
2742            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2743            # String them into a list.
2744            $retVal = join(", ", @names);
2745        } elsif ($type =~ /^keyword:(.+)$/) {
2746            # Here the caller wants the value of the named keyword. The text is the
2747            # feature ID.
2748            my $keywordName = $1;
2749            my $fid = $text;
2750            # Get the attribute values.
2751            Trace("Getting $keywordName values for feature $fid.") if T(4);
2752            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2753                                          "Feature($keywordName)");
2754            # String them into a list.
2755            $retVal = join(", ", @values);
2756        } elsif ($type eq 'pdb') {
2757            # Here the caller wants the best PDB match to this feature. The text
2758            # is the feature ID. We will display the PDB with a link to the
2759            # PDB page along with the match score. If there are docking results we
2760            # will display a link to the docking result search.
2761            my $fid = $text;
2762            # Ask for the best PDB.
2763            my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2764                                            "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2765                                            [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2766            # Only proceed if there is a PDB.
2767            if ($bestPDB) {
2768                my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2769                # Convert the PDB ID to a hyperlink.
2770                my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2771                # Append the score.
2772                $retVal = "$pdbLink ($score)";
2773                # If there are docking results, append a docking results link.
2774                if ($dockingCount > 0) {
2775                    my $dockString = "$dockingCount docking results";
2776                    my $dockLink = $cgi->a({ href =>  $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2777                                             alt =>   "View computed docking results for $pdbID",
2778                                             title => "View computed docking results for $pdbID",
2779                                             target => "_blank"},
2780                                           $dockString);
2781                }
2782            }
2783        } elsif ($type eq 'role') {
2784            # Here the caller wants a functional role assignment. The key is the feature ID.
2785            $retVal = $sprout->FunctionOf($text);
2786        } elsif ($type eq 'loc') {
2787            # This is a tough one. We need to find the nearest feature in the appropriate direction
2788            # on the contig, and then output its id, functional role, and link button.
2789            if ($text =~ /^(.)\/(.+)/) {
2790                my ($direction, $locString) = ($1, $2);
2791                Trace("Location request of type $direction for $locString.") if T(3);
2792                # Convert the location string into a location object.
2793                my $loc = BasicLocation->new($locString);
2794                # Get the contig ID.
2795                my $contigID = $loc->Contig;
2796                # Compute the contig length.
2797                my $contigLen = $sprout->ContigLength($contigID);
2798                # Widen by the area to search in both directions.
2799                $loc->Widen(5000);
2800                # Now, if we're doing a before (-) search, we set the end point to the area's mid point.
2801                # If we're doing an after (+) search, we set the begin point to the area's mid point.
2802                my $mid = ($loc->Left + $loc->Right) / 2;
2803                # Compute the search direction.
2804                my $searchDir = ($direction eq $loc->Dir ? 1 : -1);
2805                # Adjust the midpoint so that it is different in the before direction from what it would
2806                # be in the after direction.
2807                if ($mid != int($mid)) {
2808                    # Here we need to round. The thing here is we want to round in a way that separates
2809                    # the after-search choice from the before-search choice.
2810                    if ($direction eq $loc->Dir) {
2811                        $mid = ceil($mid);
2812                    } else {
2813                        $mid = floor($mid);
2814                    }
2815                } elsif ($direction eq '+') {
2816                    # Here the midpoint is on a nucleotide and we are doing the after search. We bump the
2817                    # midpoint toward the end point.
2818                    $mid += $loc->NumDirection;
2819                }
2820                # Now put the midpoint on the proper end of the region.
2821                if ($direction eq '+') {
2822                    $loc->SetBegin($mid);
2823                } else {
2824                    $loc->SetEnd($mid);
2825                }
2826                Trace("Search region is " . $loc->String . ".") if T(3);
2827                # Find all the genes in the region.
2828                my ($fidList, $beg, $end) = $sprout->GenesInRegion($loc->Contig, $loc->Left, $loc->Right);
2829                Trace(scalar(@{$fidList}) . " features found.") if T(3);
2830                # Look for the best match.
2831                my $distance = 5000;
2832                my $chosenFid = undef;
2833                for my $fid (@{$fidList}) {
2834                    # Get the feature's location.
2835                    my ($locString) = $sprout->FeatureLocation($fid);
2836                    my $locObject = BasicLocation->new($locString);
2837                    # Check its begin point to see if we should keep it.
2838                    my $newDistance = ($mid - $locObject->Begin) * $searchDir;
2839                    Trace("Distance from $mid to $locString is $newDistance.") if T(4);
2840                    if ($newDistance > 0 && $newDistance < $distance) {
2841                        $distance = $newDistance;
2842                        $chosenFid = $fid;
2843                    }
2844                }
2845                # Only proceed if we found something.
2846                if (defined $chosenFid) {
2847                    my $role = $sprout->FunctionOf($chosenFid);
2848                    my $linkButton = SearchHelper::FakeButton('NMPDR', "protein.cgi", undef,
2849                                                               prot => $chosenFid, SPROUT => 1,
2850                                                               new_framework => 0, user => '');
2851                    $retVal = "$chosenFid&nbsp;$linkButton&nbsp;$role";
2852                }
2853            } else {
2854                Confess("Invalid location request %%loc=$text.");
2855            }
2856        }
2857        # Return the result.
2858        return $retVal;
2859    }
2860    
2861    =head3 SaveOrganismData
2862    
2863    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2864    
2865    Format the name of an organism and the display version of its group name. The incoming
2866    data should be the relevant fields from the B<Genome> record in the database. The
2867    data will also be stored in the genome cache for later use in posting search results.
2868    
2869    =over 4
2870    
2871    =item group
2872    
2873    Name of the genome's group as it appears in the database.
2874    
2875    =item genomeID
2876    
2877    ID of the relevant genome.
2878    
2879    =item genus
2880    
2881    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2882    in the database. In this case, the organism name is derived from the genomeID and the group
2883    is automatically the supporting-genomes group.
2884    
2885    =item species
2886    
2887    Species of the genome's organism.
2888    
2889    =item strain
2890    
2891    Strain of the species represented by the genome.
2892    
2893    =item taxonomy
2894    
2895    Taxonomy of the species represented by the genome.
2896    
2897    =item RETURN
2898    
2899    Returns a three-element list. The first element is the formatted genome name. The second
2900    element is the display name of the genome's group. The third is the genome's domain.
2901    
2902    =back
2903    
2904    =cut
2905    
2906    sub SaveOrganismData {
2907        # Get the parameters.
2908        my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2909        # Declare the return values.
2910        my ($name, $displayGroup);
2911        # If the organism does not exist, format an unknown name and a blank group.
2912        if (! defined($genus)) {
2913            $name = "Unknown Genome $genomeID";
2914            $displayGroup = "";
2915        } else {
2916            # It does exist, so format the organism name.
2917            $name = "$genus $species";
2918            if ($strain) {
2919                $name .= " $strain";
2920            }
2921            # Compute the display group. This is currently the same as the incoming group
2922            # name unless it's the supporting group, which is nulled out.
2923            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2924        }
2925        # Compute the domain from the taxonomy.
2926        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2927        # Cache the group and organism data.
2928        my $cache = $self->{orgs};
2929        $cache->{$genomeID} = [$name, $displayGroup, $domain];
2930        # Return the result.
2931        return ($name, $displayGroup, $domain);
2932    }
2933    
2934    =head3 ValidateKeywords
2935    
2936    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2937    
2938    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2939    set.
2940    
2941    =over 4
2942    
2943    =item keywordString
2944    
2945    Keyword string specified as a parameter to the current search.
2946    
2947    =item required
2948    
2949    TRUE if there must be at least one keyword specified, else FALSE.
2950    
2951    =item RETURN
2952    
2953    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2954    is acceptable if the I<$required> parameter is not specified.
2955    
2956    =back
2957    
2958    =cut
2959    
2960    sub ValidateKeywords {
2961        # Get the parameters.
2962        my ($self, $keywordString, $required) = @_;
2963        # Declare the return variable.
2964        my $retVal = 0;
2965        my @wordList = split /\s+/, $keywordString;
2966        # Right now our only real worry is a list of all minus words. The problem with it is that
2967        # it will return an incorrect result.
2968        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2969        if (! @wordList) {
2970            if ($required) {
2971                $self->SetMessage("No search words specified.");
2972            } else {
2973                $retVal = 1;
2974            }
2975        } elsif (! @plusWords) {
2976            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2977        } else {
2978            $retVal = 1;
2979        }
2980        # Return the result.
2981        return $retVal;
2982    }
2983    
2984    =head3 FakeButton
2985    
2986    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2987    
2988    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2989    Unlike a real button, this one won't visibly click, but it will take the user to the
2990    correct place.
2991    
2992    The parameters of this method are deliberately identical to L</Formlet> so that we
2993    can switch easily from real buttons to fake ones in the code.
2994    
2995    =over 4
2996    
2997    =item caption
2998    
2999    Caption to be put on the button.
3000    
3001    =item url
3002    
3003    URL for the target page or script.
3004    
3005    =item target
3006    
3007    Frame or target in which the new page should appear. If C<undef> is specified,
3008    the default target will be used.
3009    
3010    =item parms
3011    
3012    Hash containing the parameter names as keys and the parameter values as values.
3013    These will be appended to the URL.
3014    
3015    =back
3016    
3017    =cut
3018    
3019    sub FakeButton {
3020        # Get the parameters.
3021        my ($caption, $url, $target, %parms) = @_;
3022        # Declare the return variable.
3023        my $retVal;
3024        # Compute the target URL.
3025        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
3026        # Compute the target-frame HTML.
3027        my $targetHtml = ($target ? " target=\"$target\"" : "");
3028        # Assemble the result.
3029        return "<a href=\"$targetUrl\" $targetHtml><span class=\"button2 button\">$caption</span></a>";
3030    }
3031    
3032    =head3 Formlet
3033    
3034    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
3035    
3036    Create a mini-form that posts to the specified URL with the specified parameters. The
3037    parameters will be stored in hidden fields, and the form's only visible control will
3038    be a submit button with the specified caption.
3039    
3040    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
3041    and tags that we don't want to deal with.
3042    
3043    =over 4
3044    
3045    =item caption
3046    
3047    Caption to be put on the form button.
3048    
3049    =item url
3050    
3051    URL to be put in the form's action parameter.
3052    
3053    =item target
3054    
3055    Frame or target in which the form results should appear. If C<undef> is specified,
3056    the default target will be used.
3057    
3058    =item parms
3059    
3060    Hash containing the parameter names as keys and the parameter values as values.
3061    
3062    =back
3063    
3064    =cut
3065    
3066    sub Formlet {
3067        # Get the parameters.
3068        my ($caption, $url, $target, %parms) = @_;
3069        # Compute the target HTML.
3070        my $targetHtml = ($target ? " target=\"$target\"" : "");
3071        # Start the form.
3072        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
3073        # Add the parameters.
3074        for my $parm (keys %parms) {
3075            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
3076        }
3077        # Put in the button.
3078        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
3079        # Close the form.
3080        $retVal .= "</form>";
3081        # Return the result.
3082        return $retVal;
3083    }
3084    
3085    =head3 TuningParameters
3086    
3087    C<< my $options = $shelp->TuningParameters(%parmHash); >>
3088    
3089    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
3090    to their default values. The parameters and their values will be returned as a hash reference.
3091    
3092    =over 4
3093    
3094    =item parmHash
3095    
3096    Hash mapping parameter names to their default values.
3097    
3098    =item RETURN
3099    
3100    Returns a reference to a hash containing the parameter names mapped to their actual values.
3101    
3102    =back
3103    
3104    =cut
3105    
3106    sub TuningParameters {
3107        # Get the parameters.
3108        my ($self, %parmHash) = @_;
3109        # Declare the return variable.
3110        my $retVal = {};
3111        # Get the CGI Query Object.
3112        my $cgi = $self->Q();
3113        # Loop through the parameter names.
3114        for my $parm (keys %parmHash) {
3115            # Get the incoming value for this parameter.
3116            my $value = $cgi->param($parm);
3117            # Zero might be a valid value, so we do an is-defined check rather than an OR.
3118            if (defined($value)) {
3119                $retVal->{$parm} = $value;
3120            } else {
3121                $retVal->{$parm} = $parmHash{$parm};
3122            }
3123      }      }
3124      # Return the result.      # Return the result.
3125      return $retVal;      return $retVal;
# Line 1903  Line 3152 
3152    
3153  =head3 SortKey  =head3 SortKey
3154    
3155  C<< my $key = $shelp->SortKey($record); >>  C<< my $key = $shelp->SortKey($fdata); >>
3156    
3157  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,
3158  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
3159  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
3160  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
3161  own sort logic.  B<PutFeature>, so it is only used for feature searches. A non-feature search
3162    would presumably have its own sort logic.
3163    
3164  =over 4  =over 4
3165    
3166  =item record  =item record
3167    
3168  The C<DBObject> from which the current row of data is derived.  The C<FeatureData> containing the current feature.
3169    
3170  =item RETURN  =item RETURN
3171    
# Line 1927  Line 3177 
3177    
3178  sub SortKey {  sub SortKey {
3179      # Get the parameters.      # Get the parameters.
3180      my ($self, $record) = @_;      my ($self, $fdata) = @_;
3181      # Get the feature ID from the record.      # Get the feature ID from the record.
3182      my ($fid) = $record->Value('Feature(id)');      my $fid = $fdata->FID();
3183      # Get the group from the feature ID.      # Get the group from the feature ID.
3184      my $group = $self->FeatureGroup($fid);      my $group = $self->FeatureGroup($fid);
3185      # Ask the feature query object to form the sort key.      # Ask the feature query object to form the sort key.
3186      my $retVal = FeatureQuery::SortKey($self, $group, $record);      my $retVal = $fdata->SortKey($self, $group);
3187      # Return the result.      # Return the result.
3188      return $retVal;      return $retVal;
3189  }  }
3190    
3191    =head3 SearchTitle
3192    
3193    C<< my $titleHtml = $shelp->SearchTitle(); >>
3194    
3195    Return the display title for this search. The display title appears above the search results.
3196    If no result is returned, no title will be displayed. The result should be an html string
3197    that can be legally put inside a block tag such as C<h3> or C<p>.
3198    
3199    =cut
3200    
3201    sub SearchTitle {
3202        # Get the parameters.
3203        my ($self) = @_;
3204        # Declare the return variable.
3205        my $retVal;
3206        # Return it.
3207        return $retVal;
3208    }
3209    
3210    =head3 DownloadFormatAvailable
3211    
3212    C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3213    
3214    This method returns TRUE if a specified download format is legal for this type of search
3215    and FALSE otherwise. For any feature-based search, there is no need to override this
3216    method.
3217    
3218    =over 4
3219    
3220    =item format
3221    
3222    Download format type code.
3223    
3224    =item RETURN
3225    
3226    Returns TRUE if the download format is legal for this search and FALSE otherwise.
3227    
3228    =back
3229    
3230    =cut
3231    
3232    sub DownloadFormatAvailable {
3233        # Get the parameters.
3234        my ($self, $format) = @_;
3235        # Declare the return variable.
3236        my $retVal = 1;
3237        # Return the result.
3238        return $retVal;
3239    }
3240    
3241    =head3 ColumnTitle
3242    
3243    C<< my $title = $shelp->ColumnTitle($colName); >>
3244    
3245    Return the column heading title to be used for the specified column name. The
3246    default implementation is to simply call L</FeatureColumnTitle>.
3247    
3248    =over 4
3249    
3250    =item colName
3251    
3252    Name of the desired column.
3253    
3254    =item RETURN
3255    
3256    Returns the title to be used as the column header for the named column.
3257    
3258    =back
3259    
3260    =cut
3261    
3262    sub ColumnTitle {
3263        my ($self, $colName) = @_;
3264        return $self->FeatureColumnTitle($colName);
3265    }
3266    
3267    
3268  1;  1;

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.33

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3