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

Diff of /Sprout/SearchHelper.pm

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

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3