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

Diff of /Sprout/SearchHelper.pm

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

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3