[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.37, Mon Aug 20 23:22:42 2007 UTC
# Line 10  Line 10 
10      use File::Path;      use File::Path;
11      use File::stat;      use File::stat;
12      use LWP::UserAgent;      use LWP::UserAgent;
13      use Time::HiRes 'gettimeofday';      use FIGRules;
14      use Sprout;      use Sprout;
15      use SFXlate;      use SFXlate;
16      use FIGRules;      use FIGRules;
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
19        use URI::Escape;
20        use PageBuilder;
21        use AliasAnalysis;
22        use FreezeThaw qw(freeze thaw);
23    
24  =head1 Search Helper Base Class  =head1 Search Helper Base Class
25    
# Line 62  Line 66 
66    
67  =item orgs  =item orgs
68    
69  Reference to a hash mapping genome IDs to organism names.  Reference to a hash mapping genome IDs to organism data. (Used to
70    improve performance.)
71    
72  =item name  =item name
73    
# Line 72  Line 77 
77    
78  List of JavaScript statements to be executed after the form is closed.  List of JavaScript statements to be executed after the form is closed.
79    
80    =item genomeHash
81    
82    Cache of the genome group hash used to build genome selection controls.
83    
84    =item genomeParms
85    
86    List of the parameters that are used to select multiple genomes.
87    
88    =back
89    
90    =head2 Adding a new Search Tool
91    
92    To add a new search tool to the system, you must
93    
94    =over 4
95    
96    =item 1
97    
98    Choose a class name for your search tool.
99    
100    =item 2
101    
102    Create a new subclass of this object and implement each of the virtual methods. The
103    name of the subclass must be C<SH>I<className>, where I<className> is the
104    type of search.
105    
106    =item 3
107    
108    Create an include file among the web server pages that describes how to use
109    the search tool. The include file must be in the B<includes> directory, and
110    its name must be C<SearchHelp_>I<className>C<.inc>.
111    
112    =item 4
113    
114    If your search produces a result for which a helper does not exist, you
115    must create a new subclass of B<ResultHelper>. Its name must be
116    C<RH>I<className>, where I<className> is the type of result.
117    
118  =back  =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    L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
153    L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
154    name. Note that as an assist to people working with GET-style links, if no
155    genomes are specified and the incoming request style is GET, all genomes will
156    be returned.
157    
158    L</QueueFormScript> allows you to queue JavaScript statements for execution
159    after the form is fully generated. If you are using very complicated
160    form controls, the L</QueueFormScript> method allows you to perform
161    JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
162    facility to display a list of the pre-selected genomes.
163    
164    Finally, when generating the code for your controls, be sure to use any incoming
165    query parameters as default values so that the search request is persistent.
166    
167    =head3 Finding Search Results
168    
169    The L</Find> method is used to create the search results. The basic code
170    structure would work as follows.
171    
172        sub Find {
173            my ($self) = @_;
174            # Get the CGI and Sprout objects.
175            my $cgi = $self->Q();
176            my $sprout = $self->DB();
177            # Declare the return variable. If it remains undefined, the caller will
178            # know that an error occurred.
179            my $retVal;
180            ... validate the parameters ...
181            if (... invalid parameters...) {
182                $self->SetMessage(...appropriate message...);
183            } else {
184                # Determine the result type.
185                my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
186                # Specify the columns.
187                $self->DefaultColumns($rhelp);
188                # You may want to add extra columns. $name is the column name and
189                # $loc is its location. The other parameters take their names from the
190                # corresponding column methods.
191                $rhelp->AddExtraColumn($name => $loc, style => $style, download => $flag,
192                    title => $title);
193                # Some searches require optional columns that are configured by the
194                # user or by the search query itself. There are some special methods
195                # for this in the result helpers, but there's also the direct approach
196                # shown below.
197                $rhelp->AddOptionalColumn($name => $loc);
198                # Initialize the session file.
199                $self->OpenSession($rhelp);
200                # Initialize the result counter.
201                $retVal = 0;
202                ... set up to loop through the results ...
203                while (...more results...) {
204                    ...compute extra columns and call PutExtraColumns...
205                    $rhelp->PutData($sortKey, $objectID, $record);
206                    $retVal++;
207                }
208                # Close the session file.
209                $self->CloseSession();
210            }
211            # Return the result count.
212            return $retVal;
213        }
214    
215    A Find method is of course much more complicated than generating a form, and there
216    are variations on the above theme.
217    
218    In addition to the finding and filtering, it is necessary to send status messages
219    to the output so that the user does not get bored waiting for results. The L</PrintLine>
220    method performs this function. The single parameter should be text to be
221    output to the browser. In general, you'll invoke it as follows.
222    
223        $self->PrintLine("...my message text...<br />");
224    
225    The break tag is optional. When the Find method gets control, a paragraph will
226    have been started so that everything is XHTML-compliant.
227    
228    The L</Find> method must return C<undef> if the search parameters are invalid. If this
229    is the case, then a message describing the problem should be passed to the framework
230    by calling L</SetMessage>. If the parameters are valid, then the method must return
231    the number of items found.
232    
233  =cut  =cut
234    
235  # 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.
236  my $formCount = 0;  my $formCount = 0;
237    # This counter is used to generate unique DIV IDs.
238    my $divCount = 0;
239    
240  =head2 Public Methods  =head2 Public Methods
241    
242  =head3 new  =head3 new
243    
244  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
245    
246  Construct a new SearchHelper object.  Construct a new SearchHelper object.
247    
248  =over 4  =over 4
249    
250  =item query  =item cgi
251    
252  The CGI query object for the current script.  The CGI query object for the current script.
253    
# Line 99  Line 257 
257    
258  sub new {  sub new {
259      # Get the parameters.      # Get the parameters.
260      my ($class, $query) = @_;      my ($class, $cgi) = @_;
261      # Check for a session ID.      # Check for a session ID.
262      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
263      my $type = "old";      my $type = "old";
264      if (! $session_id) {      if (! $session_id) {
265            Trace("No session ID found.") if T(3);
266          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
267          # store it in the query object.          # store it in the query object.
268          $session_id = NewSessionID();          $session_id = FIGRules::NewSessionID();
269            Trace("New session ID is $session_id.") if T(3);
270          $type = "new";          $type = "new";
271          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
272        } else {
273            Trace("Session ID is $session_id.") if T(3);
274      }      }
275        Trace("Computing subclass.") if T(3);
276      # Compute the subclass name.      # Compute the subclass name.
277      $class =~ /SH(.+)$/;      my $subClass;
278      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
279      # Create the Sprout object.          # Here we have a real search class.
280      my $sprout = SFXlate->new_sprout_only();          $subClass = $1;
281        } else {
282            # Here we have a bare class. The bare class cannot search, but it can
283            # process search results.
284            $subClass = 'SearchHelper';
285        }
286        Trace("Subclass name is $subClass.") if T(3);
287      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
288      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
289      # Generate the form name.      # Generate the form name.
290      my $formName = "$class$formCount";      my $formName = "$class$formCount";
291      $formCount++;      $formCount++;
292        Trace("Creating helper.") if T(3);
293      # 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)
294      # 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
295      # class name and the Sprout object.      # class name and a placeholder for the Sprout object.
296      my $retVal = {      my $retVal = {
297                    query => $query,                    query => $cgi,
298                    type => $type,                    type => $type,
299                    class => $subClass,                    class => $subClass,
300                    sprout => $sprout,                    sprout => undef,
301                    orgs => {},                    orgs => {},
302                    name => $formName,                    name => $formName,
303                    scriptQueue => [],                    scriptQueue => [],
304                      genomeList => undef,
305                      genomeParms => [],
306                   };                   };
307      # Bless and return it.      # Bless and return it.
308      bless $retVal, $class;      bless $retVal, $class;
# Line 152  Line 324 
324      return $self->{query};      return $self->{query};
325  }  }
326    
327    
328    
329  =head3 DB  =head3 DB
330    
331  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 163  Line 337 
337  sub DB {  sub DB {
338      # Get the parameters.      # Get the parameters.
339      my ($self) = @_;      my ($self) = @_;
340        # Insure we have a database.
341        my $retVal = $self->{sprout};
342        if (! defined $retVal) {
343            $retVal = SFXlate->new_sprout_only();
344            $self->{sprout} = $retVal;
345        }
346      # Return the result.      # Return the result.
347      return $self->{sprout};      return $retVal;
348  }  }
349    
350  =head3 IsNew  =head3 IsNew
# Line 277  Line 457 
457      my ($self, $title) = @_;      my ($self, $title) = @_;
458      # Get the CGI object.      # Get the CGI object.
459      my $cgi = $self->Q();      my $cgi = $self->Q();
460      # Start the form.      # Start the form. Note we use the override option on the Class value, in
461        # case the Advanced button was used.
462      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
463                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
464                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
465                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
466                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
467                                -value => $self->{class}) .                                -value => $self->{class},
468                                  -override => 1) .
469                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
470                                -value => 1) .                                -value => 1) .
471                   $cgi->h3($title);                   $cgi->h3("$title" . Hint($self->{class}, "Click here for more information."));
     # If tracing is on, add it to the form.  
     if ($cgi->param('Trace')) {  
         $retVal .= $cgi->hidden(-name => 'Trace',  
                                 -value => $cgi->param('Trace')) .  
                    $cgi->hidden(-name => 'TF',  
                                 -value => ($cgi->param('TF') ? 1 : 0));  
     }  
472      # Put in an anchor tag in case there's a table of contents.      # Put in an anchor tag in case there's a table of contents.
473      my $anchorName = $self->FormName();      my $anchorName = $self->FormName();
474      $retVal .= "<a name=\"$anchorName\"></a>\n";      $retVal .= "<a name=\"$anchorName\"></a>\n";
# Line 375  Line 550 
550    
551  =head3 OpenSession  =head3 OpenSession
552    
553  C<< $shelp->OpenSession(); >>  C<< $shelp->OpenSession($rhelp); >>
554    
555  Set up to open the session cache file for writing. Note we don't actually  Set up the session cache file and write out the column headers.
556  open the file until after we know the column headers.  This method should not be called until all the columns have
557    been configured, including the extra columns.
558    
559    =over 4
560    
561    =item rhelp
562    
563    Result helper for formatting the output. This has the column
564    headers stored in it.
565    
566    =back
567    
568  =cut  =cut
569    
570  sub OpenSession {  sub OpenSession {
571      # Get the parameters.      # Get the parameters.
572      my ($self) = @_;      my ($self, $rhelp) = @_;
573      # Denote we have not yet written out the column headers.      # Insure the result helper is valid.
574      $self->{cols} = undef;      if (! defined($rhelp)) {
575            Confess("No result type specified for $self->{class}.");
576        } elsif(! $rhelp->isa('ResultHelper')) {
577            Confess("Invalid result type specified for $self->{class}.");
578        } else {
579            # Get the column headers and write them out.
580            my $colHdrs = $rhelp->GetColumnHeaders();
581            Trace(scalar(@{$colHdrs}) . " column headers written to output.") if T(3);
582            $self->WriteColumnHeaders(@{$colHdrs});
583        }
584  }  }
585    
586  =head3 GetCacheFileName  =head3 GetCacheFileName
# Line 430  Line 624 
624      my ($self, $type) = @_;      my ($self, $type) = @_;
625      # Compute the file name. Note it gets stuffed in the FIG temporary      # Compute the file name. Note it gets stuffed in the FIG temporary
626      # directory.      # directory.
627      my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";      my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
628      # Return the result.      # Return the result.
629      return $retVal;      return $retVal;
630  }  }
631    
 =head3 PutFeature  
   
 C<< $shelp->PutFeature($record, %extraCols); >>  
   
 Store a feature in the result cache. This is the workhorse method for most  
 searches, since the primary data item in the database is features.  
   
 For each feature, there are certain columns that are standard: the feature name, the  
 GBrowse and protein page links, the functional assignment, and so forth. If additional  
 columns are required by a particular search subclass, they should be included in the  
 parameters, in key-value form. For example, the following call adds columns for  
 essentiality and virulence.  
   
     $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);  
   
 For correct results, all values should be specified for all extra columns in all calls to  
 B<PutFeature>. (In particular, the column header names are computed on the first  
 call.) If a column is to be blank for the current feature, its value can be given  
 as C<undef>.  
   
     if (! $essentialFlag) {  
         $essentialFlag = undef;  
     }  
     $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);  
   
 =over 4  
   
 =item record  
   
 DBObject record for the feature.  
   
 =item extraCols  
   
 =back  
   
 =cut  
   
 sub PutFeature {  
     # Get the parameters. Note that the extra columns are read in as a list  
     # instead of a hash so that the column order is preserved.  
     my ($self, $record, @extraColList) = @_;  
     # Check for a first-call situation.  
     if (! defined $self->{cols}) {  
         # Here we need to set up the column information. Start with the defaults.  
         $self->{cols} = $self->DefaultFeatureColumns();  
         # Append the extras. Note we proceed by twos because the columns are  
         # specified in the form name => value.  
         for (my $i = 0; $i <= $#extraColList; $i += 2) {  
             push @{$self->{cols}}, "X=$extraColList[$i]";  
         }  
         # Write out the column headers. This also prepares the cache file to receive  
         # output.  
         $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});  
     }  
     # Get the feature ID.  
     my ($fid) = $record->Value('Feature(id)');  
     # Now we process the columns themselves. First, convert the extra column list  
     # to a hash.  
     my %extraCols = @extraColList;  
     # Loop through the column headers, producing the desired data.  
     my @output = ();  
     for my $colName (@{$self->{cols}}) {  
         push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);  
     }  
     # Compute the sort key. The sort key floats NMPDR organism features to the  
     # top of the return list.  
     my $group = $self->FeatureGroup($fid);  
     my $key = ($group ? "A$group" : "ZZ");  
     # Write the feature data.  
     $self->WriteColumnData($key, @output);  
 }  
   
632  =head3 WriteColumnHeaders  =head3 WriteColumnHeaders
633    
634  C<< $shelp->WriteColumnHeaders(@colNames); >>  C<< $shelp->WriteColumnHeaders(@colNames); >>
# Line 519  Line 641 
641    
642  =item colNames  =item colNames
643    
644  A list of column names in the desired presentation order.  A list of column names in the desired presentation order. For extra columns,
645    the column name is the hash supplied as the column definition.
646    
647  =back  =back
648    
# Line 531  Line 654 
654      # Get the cache file name and open it for output.      # Get the cache file name and open it for output.
655      my $fileName = $self->GetCacheFileName();      my $fileName = $self->GetCacheFileName();
656      my $handle1 = Open(undef, ">$fileName");      my $handle1 = Open(undef, ">$fileName");
657        # Freeze the column headers.
658        my @colHdrs = map { freeze($_) } @colNames;
659      # Write the column headers and close the file.      # Write the column headers and close the file.
660      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colHdrs);
661      close $handle1;      close $handle1;
662      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
663      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
# Line 541  Line 666 
666      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");      $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
667  }  }
668    
669    =head3 ReadColumnHeaders
670    
671    C<< my @colHdrs = $shelp->ReadColumnHeaders($fh); >>
672    
673    Read the column headers from the specified file handle. The column headers are
674    frozen strings intermixed with frozen hash references. The strings represent
675    column names defined in the result helper. The hash references represent the
676    definitions of the extra columns.
677    
678    =over 4
679    
680    =item fh
681    
682    File handle from which the column headers are to be read.
683    
684    =item RETURN
685    
686    Returns a list of the column headers pulled from the specified file's first line.
687    
688    =back
689    
690    =cut
691    
692    sub ReadColumnHeaders {
693        # Get the parameters.
694        my ($self, $fh) = @_;
695        # Read and thaw the columns.
696        my @retVal = map { thaw($_) } Tracer::GetLine($fh);
697        # Return them to the caller.
698        return @retVal;
699    }
700    
701  =head3 WriteColumnData  =head3 WriteColumnData
702    
703  C<< $shelp->WriteColumnData($key, @colValues); >>  C<< $shelp->WriteColumnData($key, @colValues); >>
# Line 567  Line 724 
724      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
725      # Write them to the cache file.      # Write them to the cache file.
726      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
727        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
728  }  }
729    
730  =head3 CloseSession  =head3 CloseSession
# Line 583  Line 741 
741      # Check for an open session file.      # Check for an open session file.
742      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
743          # We found one, so close it.          # We found one, so close it.
744            Trace("Closing session file.") if T(2);
745          close $self->{fileHandle};          close $self->{fileHandle};
746            # Tell the user.
747            my $cgi = $self->Q();
748            $self->PrintLine("Output formatting complete.<br />");
749      }      }
750  }  }
751    
 =head3 NewSessionID  
   
 C<< my $id = SearchHelpers::NewSessionID(); >>  
   
 Generate a new session ID for the current user.  
   
 =cut  
   
 sub NewSessionID {  
     # Declare the return variable.  
     my $retVal;  
     # Get a digest encoder.  
     my $md5 = Digest::MD5->new();  
     # If we have a randomization file, use it to seed the digester.  
     if (open(R, "/dev/urandom")) {  
         my $b;  
         read(R, $b, 1024);  
         $md5->add($b);  
     }  
     # Add the PID and the time stamp.  
     $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.  
     return $retVal;  
 }  
   
752  =head3 OrganismData  =head3 OrganismData
753    
754  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
# Line 632  Line 765 
765    
766  =item RETURN  =item RETURN
767    
768  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
769  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
770  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
771    
772  =back  =back
773    
# Line 644  Line 777 
777      # Get the parameters.      # Get the parameters.
778      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
779      # Declare the return variables.      # Declare the return variables.
780      my ($orgName, $group);      my ($orgName, $group, $domain);
781      # Check the cache.      # Check the cache.
782      my $cache = $self->{orgs};      my $cache = $self->{orgs};
783      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
784          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
785            Trace("Cached organism $genomeID has group \"$group\".") if T(4);
786      } else {      } else {
787          # Here we have to use the database.          # Here we have to use the database.
788          my $sprout = $self->DB();          my $sprout = $self->DB();
789          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $newGroup, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
790                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
791                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
792                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
793          # Null out the supporting group.                                                                   'Genome(taxonomy)']);
794          $group = "" if ($group eq $FIG_Config::otherGroup);          # Format and cache the name and display group.
795          # If the organism does not exist, format an unknown name.          Trace("Caching organism $genomeID with group \"$newGroup\".") if T(4);
796          if (! defined($genus)) {          ($orgName, $group, $domain) = $self->SaveOrganismData($newGroup, $genomeID, $genus, $species,
797              $orgName = "Unknown Genome $genomeID";                                                                $strain, $taxonomy);
798          } else {          Trace("Returning group $group.") if T(4);
             # 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];  
799      }      }
800      # Return the result.      # Return the result.
801      return ($orgName, $group);      return ($orgName, $group, $domain);
802  }  }
803    
804  =head3 Organism  =head3 Organism
# Line 700  Line 826 
826      # Get the parameters.      # Get the parameters.
827      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
828      # Get the organism data.      # Get the organism data.
829      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureGroup  
   
 C<< my $groupName = $shelp->FeatureGroup($fid); >>  
   
 Return the group name for the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the relevant feature.  
   
 =item RETURN  
   
 Returns the name of the NMPDR group to which the feature belongs, or an empty  
 string if it is not part of an NMPDR group.  
   
 =back  
   
 =cut  
   
 sub FeatureGroup {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Parse the feature ID to get the genome ID.  
     my ($genomeID) = FIGRules::ParseFeatureID($fid);  
     # Get the organism data.  
     my (undef, $retVal) = $self->OrganismData($genomeID);  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureName  
   
 C<< my $fidName = $shelp->FeatureName($fid); >>  
   
 Return the display name of the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the feature whose name is desired.  
   
 =item RETURN  
   
 A displayable feature name, consisting of the organism name plus some feature  
 type and location information.  
   
 =back  
   
 =cut  
   
 sub FeatureName {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Declare the return variable  
     my $retVal;  
     # Parse the feature ID.  
     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);  
     if (! defined $genomeID) {  
         # Here the feature ID has an invalid format.  
         $retVal = "External: $fid";  
     } else {  
         # Here we can get its genome data.  
         $retVal = $self->Organism($genomeID);  
         # Append the type and number.  
         $retVal .= " [$type $num]";  
     }  
830      # Return the result.      # Return the result.
831      return $retVal;      return $retVal;
832  }  }
833    
834  =head3 ComputeFASTA  =head3 ComputeFASTA
835    
836  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
837    
838  Parse a sequence input and convert it into a FASTA string of the desired type. Note  Parse a sequence input and convert it into a FASTA string of the desired type with
839  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
840    
841  =over 4  =over 4
842    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
843  =item desiredType  =item desiredType
844    
845  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, C<dnaPattern>
846  I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.  to return a DNA search pattern, C<protPattern> to return a protein search pattern.
847    
848  =item sequence  =item sequence
849    
# Line 805  Line 853 
853  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
854  line will be provided.  line will be provided.
855    
856    =item flankingWidth
857    
858    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
859    feature that should be included. Currently we can't do this for Proteins because the
860    protein translation of a feature doesn't always match the DNA and is taken directly
861    from the database.
862    
863  =item RETURN  =item RETURN
864    
865  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 817  Line 872 
872    
873  sub ComputeFASTA {  sub ComputeFASTA {
874      # Get the parameters.      # Get the parameters.
875      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
876      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
877      my $retVal;      my $retVal;
878        # This variable will be cleared if an error is detected.
879        my $okFlag = 1;
880      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
881      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
882      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
883        # Check for a feature specification. The smoking gun for that is a vertical bar.
884      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
885          # 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
886          # it.          # it.
887          my $fid = $1;          my $fid = $1;
888            Trace("Feature ID for fasta is $fid.") if T(3);
889          my $sprout = $self->DB();          my $sprout = $self->DB();
890          # 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
891          # 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
892          # exist.          # exist.
893          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
894          if (! $figID) {          if (! $figID) {
895              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
896                $okFlag = 0;
897          } else {          } else {
898              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
899              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
900                my $favorLen = length $favored;
901                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
902                if (! $fastaLabel) {
903                    # In an emergency, fall back to the original ID.
904                    $fastaLabel = $fid;
905                }
906              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
907              if ($desiredType =~ /prot/i) {              if ($desiredType =~ /prot/) {
908                  # We want protein, so get the translation.                  # We want protein, so get the translation.
909                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
910              } else {                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
911                  # We want DNA, so get the DNA sequence. This is a two-step process.              } elsif ($desiredType =~ /dna/) {
912                    # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
913                    # locations.
914                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
915                    if ($flankingWidth > 0) {
916                        # Here we need to add flanking data. Convert the locations to a list
917                        # of location objects.
918                        my @locObjects = map { BasicLocation->new($_) } @locList;
919                        # Initialize the return variable. We will put the DNA in here segment by segment.
920                        $fastaData = "";
921                        # Now we widen each location by the flanking width and stash the results. This
922                        # requires getting the contig length for each contig so we don't fall off the end.
923                        for my $locObject (@locObjects) {
924                            Trace("Current location is " . $locObject->String . ".") if T(4);
925                            # Remember the current start and length.
926                            my ($start, $len) = ($locObject->Left, $locObject->Length);
927                            # Get the contig length.
928                            my $contigLen = $sprout->ContigLength($locObject->Contig);
929                            # Widen the location and get its DNA.
930                            $locObject->Widen($flankingWidth, $contigLen);
931                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
932                            # Now we need to do some case changing. The main DNA is upper case and
933                            # the flanking DNA is lower case.
934                            my $leftFlank = $start - $locObject->Left;
935                            my $rightFlank = $leftFlank + $len;
936                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
937                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
938                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
939                                                    lc(substr($fastaSegment, $rightFlank));
940                            $fastaData .= $fancyFastaSegment;
941                        }
942                    } else {
943                        # Here we have just the raw sequence.
944                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
945              }              }
946                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
947                }
948          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
949      } else {      } else {
950            Trace("Analyzing FASTA sequence.") if T(4);
951          # 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.
952          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
953                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
954              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
955              $fastaLabel = $1;              $fastaLabel = $1;
956              $fastaData = $2;              $fastaData = $2;
957          } else {          } else {
958                Trace("No label found in match to sequence:\n$sequence") if T(4);
959              # 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
960              # as data.              # as data.
961              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "$desiredType sequence specified by user";
962              $fastaData = $sequence;              $fastaData = $sequence;
963          }          }
964          # The next step is to clean the junk out of the sequence.          # If we are not doing a pattern search, we need to clean the junk out of the sequence.
965            if ($desiredType !~ /pattern/i) {
966          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
967          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
968          # Finally, if the user wants to convert to protein, we do it here. Note that          }
969          # we've already prevented a conversion from protein to DNA.          # Finally, verify that it's DNA if we're doing DNA stuff.
970          if ($incomingType ne $desiredType) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
971              $fastaData = Sprout::Protein($fastaData);              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
972                $okFlag = 0;
973          }          }
974      }      }
975      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
976      # in progress.      # Only proceed if no error was detected.
977      if (defined $fastaLabel) {      if ($okFlag) {
978            if ($desiredType =~ /pattern/i) {
979                # For a scan, there is no label and no breakup.
980                $retVal = $fastaData;
981            } else {
982          # 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
983          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
984          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
985          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
986          # the delimiters are what we want.          # the delimiters are what we want.
987          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
988          my $retVal = join("\n", ">$fastaLabel", @chunks, "");              $retVal = join("\n", ">$fastaLabel", @chunks, "");
989            }
990      }      }
991      # Return the result.      # Return the result.
992      return $retVal;      return $retVal;
993  }  }
994    
995    =head3 SubsystemTree
996    
997    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
998    
999    This method creates a subsystem selection tree suitable for passing to
1000    L</SelectionTree>. Each leaf node in the tree will have a link to the
1001    subsystem display page. In addition, each node can have a radio button. The
1002    radio button alue is either C<classification=>I<string>, where I<string> is
1003    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1004    Thus, it can either be used to filter by a group of related subsystems or a
1005    single subsystem.
1006    
1007    =over 4
1008    
1009    =item sprout
1010    
1011    Sprout database object used to get the list of subsystems.
1012    
1013    =item options
1014    
1015    Hash containing options for building the tree.
1016    
1017    =item RETURN
1018    
1019    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1020    
1021    =back
1022    
1023    The supported options are as follows.
1024    
1025    =over 4
1026    
1027    =item radio
1028    
1029    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1030    
1031    =item links
1032    
1033    TRUE if the tree should be configured for links. The default is TRUE.
1034    
1035    =back
1036    
1037    =cut
1038    
1039    sub SubsystemTree {
1040        # Get the parameters.
1041        my ($sprout, %options) = @_;
1042        # Process the options.
1043        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1044        # Read in the subsystems.
1045        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1046                                   ['Subsystem(classification)', 'Subsystem(id)']);
1047        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1048        # is at the end, ALL subsystems are unclassified and we don't bother.
1049        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1050            while ($subs[0]->[0] eq '') {
1051                my $classLess = shift @subs;
1052                push @subs, $classLess;
1053            }
1054        }
1055        # Declare the return variable.
1056        my @retVal = ();
1057        # Each element in @subs represents a leaf node, so as we loop through it we will be
1058        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1059        # first element is a semi-colon-delimited list of the classifications for the
1060        # subsystem. There will be a stack of currently-active classifications, which we will
1061        # compare to the incoming classifications from the end backward. A new classification
1062        # requires starting a new branch. A different classification requires closing an old
1063        # branch and starting a new one. Each classification in the stack will also contain
1064        # that classification's current branch. We'll add a fake classification at the
1065        # beginning that we can use to represent the tree as a whole.
1066        my $rootName = '<root>';
1067        # Create the classification stack. Note the stack is a pair of parallel lists,
1068        # one containing names and the other containing content.
1069        my @stackNames = ($rootName);
1070        my @stackContents = (\@retVal);
1071        # Add a null entry at the end of the subsystem list to force an unrolling.
1072        push @subs, ['', undef];
1073        # Loop through the subsystems.
1074        for my $sub (@subs) {
1075            # Pull out the classification list and the subsystem ID.
1076            my ($classString, $id) = @{$sub};
1077            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1078            # Convert the classification string to a list with the root classification in
1079            # the front.
1080            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1081            # Find the leftmost point at which the class list differs from the stack.
1082            my $matchPoint = 0;
1083            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1084                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1085                $matchPoint++;
1086            }
1087            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1088                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1089            # Unroll the stack to the matchpoint.
1090            while ($#stackNames >= $matchPoint) {
1091                my $popped = pop @stackNames;
1092                pop @stackContents;
1093                Trace("\"$popped\" popped from stack.") if T(4);
1094            }
1095            # Start branches for any new classifications.
1096            while ($#stackNames < $#classList) {
1097                # The branch for a new classification contains its radio button
1098                # data and then a list of children. So, at this point, if radio buttons
1099                # are desired, we put them into the content.
1100                my $newLevel = scalar(@stackNames);
1101                my @newClassContent = ();
1102                if ($optionThing->{radio}) {
1103                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1104                    push @newClassContent, { value => "classification=$newClassString%" };
1105                }
1106                # The new classification node is appended to its parent's content
1107                # and then pushed onto the stack. First, we need the node name.
1108                my $nodeName = $classList[$newLevel];
1109                # Add the classification to its parent. This makes it part of the
1110                # tree we'll be returning to the user.
1111                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1112                # Push the classification onto the stack.
1113                push @stackContents, \@newClassContent;
1114                push @stackNames, $nodeName;
1115                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1116            }
1117            # Now the stack contains all our parent branches. We add the subsystem to
1118            # the branch at the top of the stack, but only if it's NOT the dummy node.
1119            if (defined $id) {
1120                # Compute the node name from the ID.
1121                my $nodeName = $id;
1122                $nodeName =~ s/_/ /g;
1123                # Create the node's leaf hash. This depends on the value of the radio
1124                # and link options.
1125                my $nodeContent = {};
1126                if ($optionThing->{links}) {
1127                    # Compute the link value.
1128                    my $linkable = uri_escape($id);
1129                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1130                }
1131                if ($optionThing->{radio}) {
1132                    # Compute the radio value.
1133                    $nodeContent->{value} = "id=$id";
1134                }
1135                # Push the node into its parent branch.
1136                Trace("\"$nodeName\" added to node list.") if T(4);
1137                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1138            }
1139        }
1140        # Return the result.
1141        return \@retVal;
1142    }
1143    
1144    
1145  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1146    
1147  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1148    
1149  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
1150  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 1156 
1156    
1157  Name to give to the menu.  Name to give to the menu.
1158    
1159  =item options  =item multiple
1160    
1161  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.  
1162    
1163  =item selected  =item selected
1164    
# Line 913  Line 1166 
1166  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
1167  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1168    
1169    =item rows (optional)
1170    
1171    Number of rows to display. If omitted, the default is 1 for a single-select list
1172    and 10 for a multi-select list.
1173    
1174    =item crossMenu (optional)
1175    
1176    If specified, is presumed to be the name of another genome menu whose contents
1177    are to be mutually exclusive with the contents of this menu. As a result, instead
1178    of the standard onChange event, the onChange event will deselect any entries in
1179    the other menu.
1180    
1181  =item RETURN  =item RETURN
1182    
1183  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 1188 
1188    
1189  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1190      # Get the parameters.      # Get the parameters.
1191      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1192      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1193      my $sprout = $self->DB();      my $sprout = $self->DB();
1194      my $cgi = $self->Q();      my $cgi = $self->Q();
1195        # Compute the row count.
1196        if (! defined $rows) {
1197            $rows = ($multiple ? 10 : 1);
1198        }
1199        # Create the multiple tag.
1200        my $multipleTag = ($multiple ? " multiple" : "");
1201      # Get the form name.      # Get the form name.
1202      my $formName = $self->FormName();      my $formName = $self->FormName();
1203        # Check to see if we already have a genome list in memory.
1204        my $groupHash;
1205        my @groups;
1206        my $nmpdrGroupCount;
1207        my $genomes = $self->{genomeList};
1208        if (defined $genomes) {
1209            # We have a list ready to use.
1210            $groupHash = $genomes;
1211            @groups = @{$self->{groupList}};
1212            $nmpdrGroupCount = $self->{groupCount};
1213        } else {
1214      # 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
1215      # 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
1216      # take advantage of an existing index.      # take advantage of an existing index.
# Line 936  Line 1218 
1218                                     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1219                                     [], ['Genome(primary-group)', 'Genome(id)',                                     [], ['Genome(primary-group)', 'Genome(id)',
1220                                          'Genome(genus)', 'Genome(species)',                                          'Genome(genus)', 'Genome(species)',
1221                                          'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1222                                                  'Genome(taxonomy)']);
1223      # 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
1224      # 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
1225      # name.      # name.
1226      my %groupHash = ();          my %gHash = ();
1227      for my $genome (@genomeList) {      for my $genome (@genomeList) {
1228          # Get the genome data.          # Get the genome data.
1229          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1230          # Form the genome name.              # Compute and cache its name and display group.
1231          my $name = "$genus $species";              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1232          if ($strain) {                                                                           $strain, $taxonomy);
1233              $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1234                # name here, not the display group name.
1235                push @{$gHash{$group}}, [$genomeID, $name, $domain];
1236            }
1237            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1238            # the supporting genomes by domain. First, we sort the NMPDR groups.
1239            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1240            # Remember the number of NMPDR groups.
1241            $nmpdrGroupCount = scalar @groups;
1242            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1243            # of the domains found.
1244            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1245            my @domains = ();
1246            for my $genomeData (@otherGenomes) {
1247                my ($genomeID, $name, $domain) = @{$genomeData};
1248                if (exists $gHash{$domain}) {
1249                    push @{$gHash{$domain}}, $genomeData;
1250                } else {
1251                    $gHash{$domain} = [$genomeData];
1252                    push @domains, $domain;
1253          }          }
         # Push the genome into the group's list.  
         push @{$groupHash{$group}}, [$genomeID, $name];  
1254      }      }
1255      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting          # Add the domain groups at the end of the main group list. The main group list will now
1256      # the supporting-genome group last.          # contain all the categories we need to display the genomes.
1257      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;          push @groups, sort @domains;
1258      push @groups, $FIG_Config::otherGroup;          # Delete the supporting group.
1259      # Next, create a hash that specifies the pre-selected entries.          delete $gHash{$FIG_Config::otherGroup};
1260      my %selectedHash = map { $_ => 1 } @{$selected};          # Save the genome list for future use.
1261      # Now it gets complicated. We need a way to mark all the NMPDR genomes.          $self->{genomeList} = \%gHash;
1262            $self->{groupList} = \@groups;
1263            $self->{groupCount} = $nmpdrGroupCount;
1264            $groupHash = \%gHash;
1265        }
1266        # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1267        # with the possibility of undefined values in the incoming list.
1268        my %selectedHash = ();
1269        if (defined $selected) {
1270            %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1271        }
1272        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1273        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1274        # and use that to make the selections.
1275        my $nmpdrCount = 0;
1276      # Create the type counters.      # Create the type counters.
1277      my $groupCount = 1;      my $groupCount = 1;
1278      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 967  Line 1281 
1281      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1282      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1283      my $onChange = "";      my $onChange = "";
1284      if ($options->{multiple}) {      if ($cross) {
1285            # Here we have a paired menu. Selecting something in our menu unselects it in the
1286            # other and redisplays the status of both.
1287            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1288        } elsif ($multiple) {
1289            # This is an unpaired menu, so all we do is redisplay our status.
1290          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1291      }      }
1292      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1293      my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1294      # Loop through the groups.      # Loop through the groups.
1295      for my $group (@groups) {      for my $group (@groups) {
1296          # Create the option group tag.          # Create the option group tag.
1297          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1298          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");  
1299          # Get the genomes in the group.          # Get the genomes in the group.
1300          for my $genome (@{$groupHash{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1301              my ($genomeID, $name) = @{$genome};              # Count this organism if it's NMPDR.
1302                if ($nmpdrGroupCount > 0) {
1303                    $nmpdrCount++;
1304                }
1305                # Get the organism ID, name, and domain.
1306                my ($genomeID, $name, $domain) = @{$genome};
1307              # See if it's selected.              # See if it's selected.
1308              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1309              # Generate the option tag.              # Generate the option tag.
1310              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1311              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1312          }          }
1313          # Close the option group.          # Close the option group.
1314          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1315            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1316            # groups.
1317            $nmpdrGroupCount--;
1318      }      }
1319      # Close the SELECT tag.      # Close the SELECT tag.
1320      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1321      # Check for multiple selection.      # Check for multiple selection.
1322      if ($options->{multiple}) {      if ($multiple) {
1323          # 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
1324            # the search box. This allows the user to type text and have all genomes containing
1325            # the text selected automatically.
1326            my $searchThingName = "${menuName}_SearchThing";
1327            push @lines, "<br />" .
1328                         "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1329                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />" . Hint("Genome Control",
1330                                                                                                "Enter a genome number, then click the button to the left " .
1331                                                                                                "in order to select the genome with that number. " .
1332                                                                                                "Enter a genus, species, or strain and click the " .
1333                                                                                                "button to select all genomes with that genus, species, " .
1334                                                                                                "or strain name.");
1335            # Next are the buttons to set and clear selections.
1336          push @lines, "<br />";          push @lines, "<br />";
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
1337          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\" />";
1338          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\" />";
1339          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\" />";
1340            # push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1341          # Add the status display, too.          # Add the status display, too.
1342          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1343          # 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 1346 
1346          # in case we decide to twiddle the parameters.          # in case we decide to twiddle the parameters.
1347          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1348          $self->QueueFormScript($showSelect);          $self->QueueFormScript($showSelect);
1349            # Finally, add this parameter to the list of genome parameters. This enables us to
1350            # easily find all the parameters used to select one or more genomes.
1351            push @{$self->{genomeParms}}, $menuName;
1352      }      }
1353      # Assemble all the lines into a string.      # Assemble all the lines into a string.
1354      my $retVal = join("\n", @lines, "");      my $retVal = join("\n", @lines, "");
# Line 1021  Line 1356 
1356      return $retVal;      return $retVal;
1357  }  }
1358    
1359    =head3 PropertyMenu
1360    
1361    C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1362    
1363    Generate a property name dropdown menu.
1364    
1365    =over 4
1366    
1367    =item menuName
1368    
1369    Name to give to the menu.
1370    
1371    =item selected
1372    
1373    Value of the property name to pre-select.
1374    
1375    =item force (optional)
1376    
1377    If TRUE, then the user will be forced to choose a property name. If FALSE,
1378    then an additional menu choice will be provided to select nothing.
1379    
1380    =item RETURN
1381    
1382    Returns a dropdown menu box that allows the user to select a property name. An additional
1383    selection entry will be provided for selecting no property name
1384    
1385    =back
1386    
1387    =cut
1388    
1389    sub PropertyMenu {
1390        # Get the parameters.
1391        my ($self, $menuName, $selected, $force) = @_;
1392        # Get the CGI and Sprout objects.
1393        my $sprout = $self->DB();
1394        my $cgi = $self->Q();
1395        # Create the property name list.
1396        my @propNames = ();
1397        if (! $force) {
1398            push @propNames, "";
1399        }
1400        # Get all the property names, putting them after the null choice if one exists.
1401        push @propNames, $sprout->GetChoices('Property', 'property-name');
1402        # Create a menu from them.
1403        my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1404                                      -default => $selected);
1405        # Return the result.
1406        return $retVal;
1407    }
1408    
1409  =head3 MakeTable  =head3 MakeTable
1410    
1411  C<< my $htmlText = $shelp->MakeTable(\@rows); >>  C<< my $htmlText = $shelp->MakeTable(\@rows); >>
# Line 1039  Line 1424 
1424  =item rows  =item rows
1425    
1426  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1427  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1428  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1429    
1430  =item RETURN  =item RETURN
1431    
# Line 1055  Line 1440 
1440      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1441      # Get the CGI object.      # Get the CGI object.
1442      my $cgi = $self->Q();      my $cgi = $self->Q();
1443      # Fix the widths on the first column. Note that we eschew the use of the "g"      # The first column of the first row must have its width fixed.
1444        # This flag will be set to FALSE when that happens.
1445        my $needWidth = 1;
1446      # modifier becase we only want to change the first tag. Also, if a width      # modifier becase we only want to change the first tag. Also, if a width
1447      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1448      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1449          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1450            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1451                # Here we have a first cell and its tag parameters are in $2.
1452                my $elements = $2;
1453                if ($elements !~ /colspan/i) {
1454                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1455                    # Here there's no colspan, so we plug in the width. We
1456                    # eschew the "g" modifier on the substitution because we
1457                    # only want to update the first cell.
1458                    $row =~ s/(<(td|th))/$1 width="150"/i;
1459                    # Denote we don't need this any more.
1460                    $needWidth = 0;
1461      }      }
1462      # Create the table.          }
1463        }
1464        # Create the table.
1465      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
1466                                width => 700, class => 'search'},                                width => 700, class => 'search'},
1467                               @{$rows});                               @{$rows});
# Line 1071  Line 1471 
1471    
1472  =head3 SubmitRow  =head3 SubmitRow
1473    
1474  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1475    
1476  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1477  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1478  near the top of the form.  near the top of the form.
1479    
1480    =over 4
1481    
1482    =item caption (optional)
1483    
1484    Caption to be put on the search button. The default is C<Go>.
1485    
1486    =item RETURN
1487    
1488    Returns a table row containing the controls for submitting the search
1489    and tuning the results.
1490    
1491    =back
1492    
1493  =cut  =cut
1494    
1495  sub SubmitRow {  sub SubmitRow {
1496      # Get the parameters.      # Get the parameters.
1497      my ($self) = @_;      my ($self, $caption) = @_;
1498      my $cgi = $self->Q();      my $cgi = $self->Q();
1499      # Declare the return variable.      # Compute the button caption.
1500      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $realCaption = (defined $caption ? $caption : 'Go');
1501        # Get the current page size.
1502        my $pageSize = $cgi->param('PageSize');
1503        # Get the current feature ID type.
1504        my $aliasType = $self->GetPreferredAliasType();
1505        # Create the rows.
1506        my $retVal = $cgi->Tr($cgi->td("Identifier Type "),
1507                              $cgi->td({ colspan => 2 },
1508                                       $cgi->popup_menu(-name => 'AliasType',
1509                                                        -values => ['FIG', AliasAnalysis::AliasTypes() ],
1510                                                        -default => $aliasType) .
1511                                       Hint("Identifier type", "Specify how you want gene names to be displayed."))) .
1512                     "\n" .
1513                     $cgi->Tr($cgi->td("Results/Page"),
1514                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1515                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1516                                                      -default => $cgi->param('PageSize'))),                                                      -default => $pageSize)),
1517                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1518                                                  -name => 'Search',                                                  -name => 'Search',
1519                                                  -value => 'Go')));                                                  -value => $realCaption)));
1520      # Return the result.      # Return the result.
1521      return $retVal;      return $retVal;
1522  }  }
 =head3 GBrowseFeatureURL  
1523    
1524  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  =head3 GetGenomes
1525    
1526  Compute the URL required to pull up a Gbrowse page for the the specified feature.  C<< my @genomeList = $shelp->GetGenomes($parmName); >>
1527  In order to do this, we need to pull out the ID of the feature's Genome, its  
1528  contig ID, and some rough starting and stopping offsets.  Return the list of genomes specified by the specified CGI query parameter.
1529    If the request method is POST, then the list of genome IDs is returned
1530    without preamble. If the request method is GET and the parameter is not
1531    specified, then it is treated as a request for all genomes. This makes it
1532    easier for web pages to link to a search that wants to specify all genomes.
1533    
1534  =over 4  =over 4
1535    
1536  =item sprout  =item parmName
1537    
1538  Sprout object for accessing the database.  Name of the parameter containing the list of genomes. This will be the
1539    first parameter passed to the L</NmpdrGenomeMenu> call that created the
1540    genome selection control on the form.
1541    
1542    =item RETURN
1543    
1544    Returns a list of the genomes to process.
1545    
1546    =back
1547    
1548    =cut
1549    
1550    sub GetGenomes {
1551        # Get the parameters.
1552        my ($self, $parmName) = @_;
1553        # Get the CGI query object.
1554        my $cgi = $self->Q();
1555        # Get the list of genome IDs in the request header.
1556        my @retVal = $cgi->param($parmName);
1557        Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1558        # Check for the special GET case.
1559        if ($cgi->request_method() eq "GET" && ! @retVal) {
1560            # Here the caller wants all the genomes.
1561            my $sprout = $self->DB();
1562            @retVal = $sprout->Genomes();
1563        }
1564        # Return the result.
1565        return @retVal;
1566    }
1567    
1568    =head3 GetHelpText
1569    
1570    C<< my $htmlText = $shelp->GetHelpText(); >>
1571    
1572    Get the help text for this search. The help text is stored in files on the template
1573    server. The help text for a specific search is taken from a file named
1574    C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1575    There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1576    feature filtering performed by the B<RHFeatures> object, C<SearchHelp1_GenomeControl.inc>
1577    describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1578    describes the standard controls for a search, such as page size, URL display, and
1579    external alias display.
1580    
1581    =cut
1582    
1583    sub GetHelpText {
1584        # Get the parameters.
1585        my ($self) = @_;
1586        # Create a list to hold the pieces of the help.
1587        my @helps = ();
1588        # Get the template directory URL.
1589        my $urlBase = $FIG_Config::template_url;
1590        # Start with the specific help.
1591        my $class = $self->{class};
1592        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1593        # Add the genome control help if needed.
1594        if (scalar @{$self->{genomeParms}}) {
1595            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1596        }
1597        # Next the filter help.
1598        if ($self->{filtered}) {
1599            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1600        }
1601        # Finally, the standard help.
1602        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1603        # Assemble the pieces.
1604        my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1605        # Return the result.
1606        return $retVal;
1607    }
1608    
1609  =item feat  =head3 ComputeSearchURL
1610    
1611  ID of the feature whose Gbrowse URL is desired.  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1612    
1613    Compute the GET-style URL for the current search. In order for this to work, there
1614    must be a copy of the search form on the current page. This will always be the
1615    case if the search is coming from C<SearchSkeleton.cgi>.
1616    
1617    A little expense is involved in order to make the URL as smart as possible. The
1618    main complication is that if the user specified all genomes, we'll want to
1619    remove the parameter entirely from a get-style URL.
1620    
1621    =over 4
1622    
1623    =item overrides
1624    
1625    Hash containing override values for the parameters, where the parameter name is
1626    the key and the parameter value is the override value. If the override value is
1627    C<undef>, the parameter will be deleted from the result.
1628    
1629  =item RETURN  =item RETURN
1630    
1631  Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome  Returns a GET-style URL for invoking the search with the specified overrides.
 ID, contig ID, starting offset, and stopping offset.  
1632    
1633  =back  =back
1634    
1635  =cut  =cut
1636    
1637  sub GBrowseFeatureURL {  sub ComputeSearchURL {
1638      # Get the parameters.      # Get the parameters.
1639      my ($sprout, $feat) = @_;      my ($self, %overrides) = @_;
1640      # Declare the return variable.      # Get the database and CGI query object.
1641      my $retVal;      my $cgi = $self->Q();
1642      # Compute the genome ID.      my $sprout = $self->DB();
1643      my ($genomeID) = FIGRules::ParseFeatureID($feat);      # Start with the full URL.
1644      # Only proceed if the feature ID produces a valid genome.      my $retVal = $cgi->url(-full => 1);
1645      if ($genomeID) {      # Get all the query parameters in a hash.
1646          # Get the feature location string.      my %parms = $cgi->Vars();
1647          my $loc = $sprout->FeatureLocation($feat);      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1648          # Compute the contig, start, and stop points.      # characters separating the individual values. We have to convert those to lists. In addition,
1649          my($start, $stop, $contig) = BasicLocation::Parse($loc);      # the multiple-selection genome parameters and the feature type parameter must be checked to
1650          # Now we need to do some goofiness to insure that the location is not too      # determine whether or not they can be removed from the URL. First, we get a list of the
1651          # big and that we get some surrounding stuff.      # genome parameters and a list of all genomes. Note that we only need the list if a
1652          my $mid = int(($start + $stop) / 2);      # multiple-selection genome parameter has been found on the form.
1653          my $chunk_len = 20000;      my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1654          my $max_feature = 40000;      my @genomeList;
1655          my $feat_len = abs($stop - $start);      if (keys %genomeParms) {
1656          if ($feat_len > $chunk_len) {          @genomeList = $sprout->Genomes();
1657              if ($feat_len > $max_feature) {      }
1658                  $chunk_len = $max_feature;      # Create a list to hold the URL parameters we find.
1659        my @urlList = ();
1660        # Now loop through the parameters in the hash, putting them into the output URL.
1661        for my $parmKey (keys %parms) {
1662            # Get a list of the parameter values. If there's only one, we'll end up with
1663            # a singleton list, but that's okay.
1664            my @values = split (/\0/, $parms{$parmKey});
1665            # Check for special cases.
1666            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1667                # These are bookkeeping parameters we don't need to start a search.
1668                @values = ();
1669            } elsif ($parmKey =~ /_SearchThing$/) {
1670                # Here the value coming in is from a genome control's search thing. It does
1671                # not affect the results of the search, so we clear it.
1672                @values = ();
1673            } elsif ($genomeParms{$parmKey}) {
1674                # Here we need to see if the user wants all the genomes. If he does,
1675                # we erase all the values just like with features.
1676                my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1677                if ($allFlag) {
1678                    @values = ();
1679                }
1680            } elsif (exists $overrides{$parmKey}) {
1681                # Here the value is being overridden, so we skip it for now.
1682                @values = ();
1683            }
1684            # If we still have values, create the URL parameters.
1685            if (@values) {
1686                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1687            }
1688        }
1689        # Now do the overrides.
1690        for my $overKey (keys %overrides) {
1691            # Only use this override if it's not a delete marker.
1692            if (defined $overrides{$overKey}) {
1693                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1694            }
1695        }
1696        # Add the parameters to the URL.
1697        $retVal .= "?" . join(";", @urlList);
1698        # Return the result.
1699        return $retVal;
1700    }
1701    
1702    =head3 AdvancedClassList
1703    
1704    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1705    
1706    Return a list of advanced class names. This list is used to generate the directory
1707    of available searches on the search page.
1708    
1709    We do a file search to accomplish this, but to pull it off we need to look at %INC.
1710    
1711    =cut
1712    
1713    sub AdvancedClassList {
1714        # Determine the search helper module directory.
1715        my $libDirectory = $INC{'SearchHelper.pm'};
1716        $libDirectory =~ s/SearchHelper\.pm//;
1717        # Read it, keeping only the helper modules.
1718        my @modules = grep { /^SH\w+\.pm/ } Tracer::OpenDir($libDirectory, 0);
1719        # Convert the file names to search types.
1720        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } @modules;
1721        # Return the result in alphabetical order.
1722        return sort @retVal;
1723    }
1724    
1725    =head3 SelectionTree
1726    
1727    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1728    
1729    Display a selection tree.
1730    
1731    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1732    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1733    addition, some of the tree nodes can contain hyperlinks.
1734    
1735    The tree itself is passed in as a multi-level list containing node names followed by
1736    contents. Each content element is a reference to a similar list. The first element of
1737    each list may be a hash reference. If so, it should contain one or both of the following
1738    keys.
1739    
1740    =over 4
1741    
1742    =item link
1743    
1744    The navigation URL to be popped up if the user clicks on the node name.
1745    
1746    =item value
1747    
1748    The form value to be returned if the user selects the tree node.
1749    
1750    =back
1751    
1752    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1753    a C<value> key indicates the node name will have a radio button. If a node has no children,
1754    you may pass it a hash reference instead of a list reference.
1755    
1756    The following example shows the hash for a three-level tree with links on the second level and
1757    radio buttons on the third.
1758    
1759        [   Objects => [
1760                Entities => [
1761                    {link => "../docs/WhatIsAnEntity.html"},
1762                    Genome => {value => 'GenomeData'},
1763                    Feature => {value => 'FeatureData'},
1764                    Contig => {value => 'ContigData'},
1765                ],
1766                Relationships => [
1767                    {link => "../docs/WhatIsARelationShip.html"},
1768                    HasFeature => {value => 'GenomeToFeature'},
1769                    IsOnContig => {value => 'FeatureToContig'},
1770                ]
1771            ]
1772        ]
1773    
1774    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1775    all have list references.
1776    
1777    This next example shows how to set up a taxonomy selection field. The value returned
1778    by the tree control will be the taxonomy string for the selected node ready for use
1779    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1780    reasons of space.
1781    
1782        [   All => [
1783                {value => "%"},
1784                Bacteria => [
1785                    {value => "Bacteria%"},
1786                    Proteobacteria => [
1787                        {value => "Bacteria; Proteobacteria%"},
1788                        Epsilonproteobacteria => [
1789                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1790                            Campylobacterales => [
1791                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1792                                Campylobacteraceae =>
1793                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1794                                ...
1795                            ]
1796                            ...
1797                        ]
1798                        ...
1799                    ]
1800                    ...
1801                ]
1802                ...
1803            ]
1804        ]
1805    
1806    
1807    This method of tree storage allows the caller to control the order in which the tree nodes
1808    are displayed and to completely control value selection and use of hyperlinks. It is, however
1809    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1810    
1811    The parameters to this method are as follows.
1812    
1813    =over 4
1814    
1815    =item cgi
1816    
1817    CGI object used to generate the HTML.
1818    
1819    =item tree
1820    
1821    Reference to a hash describing a tree. See the description above.
1822    
1823    =item options
1824    
1825    Hash containing options for the tree display.
1826    
1827    =back
1828    
1829    The allowable options are as follows
1830    
1831    =over 4
1832    
1833    =item nodeImageClosed
1834    
1835    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1836    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1837    
1838    =item nodeImageOpen
1839    
1840    URL of the image to display next to the tree nodes when they are expanded. Clicking
1841    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1842    
1843    =item style
1844    
1845    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1846    as nested lists, the key components of this style are the definitions for the C<ul> and
1847    C<li> tags. The default style file contains the following definitions.
1848    
1849        .tree ul {
1850           margin-left: 0; padding-left: 22px
1851        }
1852        .tree li {
1853            list-style-type: none;
1854        }
1855    
1856    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1857    parent by the width of the node image. This use of styles limits the things we can do in formatting
1858    the tree, but it has the advantage of vastly simplifying the tree creation.
1859    
1860    =item name
1861    
1862    Field name to give to the radio buttons in the tree. The default is C<selection>.
1863    
1864    =item target
1865    
1866    Frame target for links. The default is C<_self>.
1867    
1868    =item selected
1869    
1870    If specified, the value of the radio button to be pre-selected.
1871    
1872    =back
1873    
1874    =cut
1875    
1876    sub SelectionTree {
1877        # Get the parameters.
1878        my ($cgi, $tree, %options) = @_;
1879        # Get the options.
1880        my $optionThing = Tracer::GetOptions({ name => 'selection',
1881                                               nodeImageClosed => '../FIG/Html/plus.gif',
1882                                               nodeImageOpen => '../FIG/Html/minus.gif',
1883                                               style => 'tree',
1884                                               target => '_self',
1885                                               selected => undef},
1886                                             \%options);
1887        # Declare the return variable. We'll do the standard thing with creating a list
1888        # of HTML lines and rolling them together at the end.
1889        my @retVal = ();
1890        # Only proceed if the tree is present.
1891        if (defined($tree)) {
1892            # Validate the tree.
1893            if (ref $tree ne 'ARRAY') {
1894                Confess("Selection tree is not a list reference.");
1895            } elsif (scalar @{$tree} == 0) {
1896                # The tree is empty, so we do nothing.
1897            } elsif ($tree->[0] eq 'HASH') {
1898                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
1899              } else {              } else {
1900                  $chunk_len = $feat_len + 100;              # Here we have a real tree. Apply the tree style.
1901                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
1902                # Give us a DIV ID.
1903                my $divID = GetDivID($optionThing->{name});
1904                # Show the tree.
1905                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
1906                # Close the DIV block.
1907                push @retVal, $cgi->end_div();
1908            }
1909        }
1910        # Return the result.
1911        return join("\n", @retVal, "");
1912              }              }
1913    
1914    =head3 ShowBranch
1915    
1916    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
1917    
1918    This is a recursive method that displays a branch of the tree.
1919    
1920    =over 4
1921    
1922    =item cgi
1923    
1924    CGI object used to format HTML.
1925    
1926    =item label
1927    
1928    Label of this tree branch. It is only used in error messages.
1929    
1930    =item id
1931    
1932    ID to be given to this tree branch. The ID is used in the code that expands and collapses
1933    tree nodes.
1934    
1935    =item branch
1936    
1937    Reference to a list containing the content of the tree branch. The list contains an optional
1938    hash reference that is ignored and the list of children, each child represented by a name
1939    and then its contents. The contents could by a hash reference (indicating the attributes
1940    of a leaf node), or another tree branch.
1941    
1942    =item options
1943    
1944    Options from the original call to L</SelectionTree>.
1945    
1946    =item displayType
1947    
1948    C<block> if the contents of this list are to be displayed, C<none> if they are to be
1949    hidden.
1950    
1951    =item RETURN
1952    
1953    Returns one or more HTML lines that can be used to display the tree branch.
1954    
1955    =back
1956    
1957    =cut
1958    
1959    sub ShowBranch {
1960        # Get the parameters.
1961        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
1962        # Declare the return variable.
1963        my @retVal = ();
1964        # Start the branch.
1965        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
1966        # Check for the hash and choose the start location accordingly.
1967        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
1968        # Get the list length.
1969        my $i1 = scalar(@{$branch});
1970        # Verify we have an even number of elements.
1971        if (($i1 - $i0) % 2 != 0) {
1972            Trace("Branch elements are from $i0 to $i1.") if T(3);
1973            Confess("Odd number of elements in tree branch $label.");
1974        } else {
1975            # Loop through the elements.
1976            for (my $i = $i0; $i < $i1; $i += 2) {
1977                # Get this node's label and contents.
1978                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
1979                # Get an ID for this node's children (if any).
1980                my $myID = GetDivID($options->{name});
1981                # Now we need to find the list of children and the options hash.
1982                # This is a bit ugly because we allow the shortcut of a hash without an
1983                # enclosing list. First, we need some variables.
1984                my $attrHash = {};
1985                my @childHtml = ();
1986                my $hasChildren = 0;
1987                if (! ref $myContent) {
1988                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
1989                } elsif (ref $myContent eq 'HASH') {
1990                    # Here the node is a leaf and its content contains the link/value hash.
1991                    $attrHash = $myContent;
1992                } elsif (ref $myContent eq 'ARRAY') {
1993                    # Here the node may be a branch. Its content is a list.
1994                    my $len = scalar @{$myContent};
1995                    if ($len >= 1) {
1996                        # Here the first element of the list could by the link/value hash.
1997                        if (ref $myContent->[0] eq 'HASH') {
1998                            $attrHash = $myContent->[0];
1999                            # If there's data in the list besides the hash, it's our child list.
2000                            # We can pass the entire thing as the child list, because the hash
2001                            # is ignored.
2002                            if ($len > 1) {
2003                                $hasChildren = 1;
2004          }          }
         my($show_start, $show_stop);  
         if ($chunk_len == $max_feature) {  
             $show_start = $start - 300;  
2005          } else {          } else {
2006              $show_start = $mid - int($chunk_len / 2);                          $hasChildren = 1;
2007          }          }
2008          if ($show_start < 1) {                      # If we have children, create the child list with a recursive call.
2009              $show_start = 1;                      if ($hasChildren) {
2010                            Trace("Processing children of $myLabel.") if T(4);
2011                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2012                            Trace("Children of $myLabel finished.") if T(4);
2013          }          }
         $show_stop = $show_start + $chunk_len - 1;  
         my $clen = $sprout->ContigLength($contig);  
         if ($show_stop > $clen) {  
             $show_stop = $clen;  
2014          }          }
         my $seg_id = $contig;  
         $seg_id =~ s/:/--/g;  
         # Assemble all the pieces.  
         $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";  
2015      }      }
2016                # Okay, it's time to pause and take stock. We have the label of the current node
2017                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2018                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2019                # Compute the image HTML. It's tricky, because we have to deal with the open and
2020                # closed images.
2021                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2022                my $image = $images[$hasChildren];
2023                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2024                if ($hasChildren) {
2025                    # If there are children, we wrap the image in a toggle hyperlink.
2026                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2027                                          $prefixHtml);
2028                }
2029                # Now the radio button, if any. Note we use "defined" in case the user wants the
2030                # value to be 0.
2031                if (defined $attrHash->{value}) {
2032                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2033                    # hash for the "input" method. If the item is pre-selected, we add
2034                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2035                    # at all.
2036                    my $radioParms = { type => 'radio',
2037                                       name => $options->{name},
2038                                       value => $attrHash->{value},
2039                                     };
2040                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2041                        $radioParms->{checked} = undef;
2042                    }
2043                    $prefixHtml .= $cgi->input($radioParms);
2044                }
2045                # Next, we format the label.
2046                my $labelHtml = $myLabel;
2047                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2048                # Apply a hyperlink if necessary.
2049                if (defined $attrHash->{link}) {
2050                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2051                                         $labelHtml);
2052                }
2053                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2054                # here.
2055                my $childHtml = join("\n", @childHtml);
2056                # Now we have all the pieces, so we can put them together.
2057                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2058            }
2059        }
2060        # Close the tree branch.
2061        push @retVal, $cgi->end_ul();
2062      # Return the result.      # Return the result.
2063      return $retVal;      return @retVal;
2064  }  }
2065    
2066  =head2 Feature Column Methods  =head3 GetDivID
2067    
2068  The methods in this column manage feature column data. If you want to provide the  C<< my $idString = SearchHelper::GetDivID($name); >>
 capability to include new types of data in feature columns, then all the changes  
 are made to this section of the source file. Technically, this should be implemented  
 using object-oriented methods, but this is simpler for non-programmers to maintain.  
 To add a new column of feature data, you must first give it a name. For example,  
 the name for the protein page link column is C<protlink>. If the column is to appear  
 in the default list of feature columns, add it to the list returned by  
 L</DefaultFeatureColumns>. Then add code to produce the column title to  
 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  
 everything else will happen automatically.  
2069    
2070  There is one special column name syntax for extra columns (that is, nonstandard  Return a new HTML ID string.
 feature columns). If the column name begins with C<X=>, then it is presumed to be  
 an extra column. The column title is the text after the C<X=>, and its value is  
 pulled from the extra column hash.  
2071    
2072  =head3 DefaultFeatureColumns  =over 4
2073    
2074  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  =item name
2075    
2076    Name to be prefixed to the ID string.
2077    
2078    =item RETURN
2079    
2080    Returns a hopefully-unique ID string.
2081    
2082  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.  
2083    
2084  =cut  =cut
2085    
2086  sub DefaultFeatureColumns {  sub GetDivID {
2087      # Get the parameters.      # Get the parameters.
2088      my ($self) = @_;      my ($name) = @_;
2089        # Compute the ID.
2090        my $retVal = "elt_$name$divCount";
2091        # Increment the counter to make sure this ID is not re-used.
2092        $divCount++;
2093      # Return the result.      # Return the result.
2094      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
2095  }  }
2096    
2097  =head3 FeatureColumnTitle  =head3 PrintLine
2098    
2099  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< $shelp->PrintLine($message); >>
2100    
2101  Return the column heading title to be used for the specified feature column.  Print a line of CGI output. This is used during the operation of the B<Find> method while
2102    searching, so the user sees progress in real-time.
2103    
2104  =over 4  =over 4
2105    
2106  =item name  =item message
2107    
2108  Name of the desired feature column.  HTML text to display.
2109    
2110    =back
2111    
2112    =cut
2113    
2114    sub PrintLine {
2115        # Get the parameters.
2116        my ($self, $message) = @_;
2117        # Send them to the output.
2118        print "$message\n";
2119    }
2120    
2121    =head3 GetHelper
2122    
2123    C<< my $shelp = SearchHelper::GetHelper($parm, $type => $className); >>
2124    
2125    Return a helper object with the given class name. If no such class exists, an
2126    error will be thrown.
2127    
2128    =over 4
2129    
2130    =item parm
2131    
2132    Parameter to pass to the constructor. This is a CGI object for a search helper
2133    and a search helper object for the result helper.
2134    
2135    =item type
2136    
2137    Type of helper: C<RH> for a result helper and C<SH> for a search helper.
2138    
2139    =item className
2140    
2141    Class name for the helper object, without the preceding C<SH> or C<RH>. This is
2142    identical to what the script expects for the C<Class> or C<ResultType> parameter.
2143    
2144  =item RETURN  =item RETURN
2145    
2146  Returns the title to be used as the column header for the named feature column.  Returns a helper object for the specified class.
2147    
2148  =back  =back
2149    
2150  =cut  =cut
2151    
2152  sub FeatureColumnTitle {  sub GetHelper {
2153      # Get the parameters.      # Get the parameters.
2154      my ($self, $colName) = @_;      my ($parm, $type, $className) = @_;
2155      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
2156      my $retVal = "&nbsp;";      my $retVal;
2157      # Process the column name.      # Try to create the helper.
2158      if ($colName =~ /^X=(.+)$/) {      eval {
2159          # Here we have an extra column.          # Load it into memory. If it's already there nothing will happen here.
2160          $retVal = $1;          my $realName = "$type$className";
2161      } elsif ($colName eq 'orgName') {          Trace("Requiring helper $realName.") if T(3);
2162          $retVal = "Name";          require "$realName.pm";
2163      } elsif ($colName eq 'fid') {          Trace("Constructing helper object.") if T(3);
2164          $retVal = "FIG ID";          # Construct the object.
2165      } elsif ($colName eq 'alias') {          $retVal = eval("$realName->new(\$parm)");
2166          $retVal = "External Aliases";          # Commit suicide if it didn't work.
2167      } elsif ($colName eq 'function') {          if (! defined $retVal) {
2168          $retVal = "Functional Assignment";              die "Could not find a $type handler of type $className.";
2169      } elsif ($colName eq 'gblink') {          }
2170          $retVal = "GBrowse";      };
2171      } elsif ($colName eq 'protlink') {      # Check for errors.
2172          $retVal = "NMPDR Protein Page";      if ($@) {
2173      } elsif ($colName eq 'group') {          Confess("Error retrieving $type$className: $@");
         $retVal = "NMDPR Group";  
2174      }      }
2175      # Return the result.      # Return the result.
2176      return $retVal;      return $retVal;
2177  }  }
2178    
2179  =head3 FeatureColumnValue  =head3 SaveOrganismData
2180    
2181    C<< my ($name, $displayGroup, $domain) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2182    
2183    Format the name of an organism and the display version of its group name. The incoming
2184    data should be the relevant fields from the B<Genome> record in the database. The
2185    data will also be stored in the genome cache for later use in posting search results.
2186    
2187    =over 4
2188    
2189    =item group
2190    
2191    Name of the genome's group as it appears in the database.
2192    
2193    =item genomeID
2194    
2195    ID of the relevant genome.
2196    
2197    =item genus
2198    
2199    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2200    in the database. In this case, the organism name is derived from the genomeID and the group
2201    is automatically the supporting-genomes group.
2202    
2203    =item species
2204    
2205    Species of the genome's organism.
2206    
2207    =item strain
2208    
2209    Strain of the species represented by the genome.
2210    
2211    =item taxonomy
2212    
2213    Taxonomy of the species represented by the genome.
2214    
2215    =item RETURN
2216    
2217    Returns a three-element list. The first element is the formatted genome name. The second
2218    element is the display name of the genome's group. The third is the genome's domain.
2219    
2220    =back
2221    
2222    =cut
2223    
2224    sub SaveOrganismData {
2225        # Get the parameters.
2226        my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2227        # Declare the return values.
2228        my ($name, $displayGroup);
2229        # If the organism does not exist, format an unknown name and a blank group.
2230        if (! defined($genus)) {
2231            $name = "Unknown Genome $genomeID";
2232            $displayGroup = "";
2233        } else {
2234            # It does exist, so format the organism name.
2235            $name = "$genus $species";
2236            if ($strain) {
2237                $name .= " $strain";
2238            }
2239            # Compute the display group. This is currently the same as the incoming group
2240            # name unless it's the supporting group, which is nulled out.
2241            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2242            Trace("Group = $displayGroup, translated from \"$group\".") if T(4);
2243        }
2244        # Compute the domain from the taxonomy.
2245        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2246        # Cache the group and organism data.
2247        my $cache = $self->{orgs};
2248        $cache->{$genomeID} = [$name, $displayGroup, $domain];
2249        # Return the result.
2250        return ($name, $displayGroup, $domain);
2251    }
2252    
2253    =head3 ValidateKeywords
2254    
2255  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2256    
2257  Return the value to be displayed in the specified feature column.  Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2258    set.
2259    
2260  =over 4  =over 4
2261    
2262  =item colName  =item keywordString
2263    
2264    Keyword string specified as a parameter to the current search.
2265    
2266    =item required
2267    
2268    TRUE if there must be at least one keyword specified, else FALSE.
2269    
2270    =item RETURN
2271    
2272  Name of the column to be displayed.  Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2273    is acceptable if the I<$required> parameter is not specified.
2274    
2275  =item record  =back
2276    
2277  DBObject record for the feature being displayed in the current row.  =cut
2278    
2279  =item extraCols  sub ValidateKeywords {
2280        # Get the parameters.
2281        my ($self, $keywordString, $required) = @_;
2282        # Declare the return variable.
2283        my $retVal = 0;
2284        my @wordList = split /\s+/, $keywordString;
2285        # Right now our only real worry is a list of all minus words. The problem with it is that
2286        # it will return an incorrect result.
2287        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2288        if (! @wordList) {
2289            if ($required) {
2290                $self->SetMessage("No search words specified.");
2291            } else {
2292                $retVal = 1;
2293            }
2294        } elsif (! @plusWords) {
2295            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2296        } else {
2297            $retVal = 1;
2298        }
2299        # Return the result.
2300        return $retVal;
2301    }
2302    
2303    =head3 TuningParameters
2304    
2305    C<< my $options = $shelp->TuningParameters(%parmHash); >>
2306    
2307    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2308    to their default values. The parameters and their values will be returned as a hash reference.
2309    
2310    =over 4
2311    
2312    =item parmHash
2313    
2314  Reference to a hash of extra column names to values. If the incoming column name  Hash mapping parameter names to their default values.
 begins with C<X=>, its value will be taken from this hash.  
2315    
2316  =item RETURN  =item RETURN
2317    
2318  Returns the HTML to be displayed in the named column for the specified feature.  Returns a reference to a hash containing the parameter names mapped to their actual values.
2319    
2320  =back  =back
2321    
2322  =cut  =cut
2323    
2324  sub FeatureColumnValue {  sub TuningParameters {
2325      # Get the parameters.      # Get the parameters.
2326      my ($self, $colName, $record, $extraCols) = @_;      my ($self, %parmHash) = @_;
2327      # Get the sprout and CGI objects.      # Declare the return variable.
2328        my $retVal = {};
2329        # Get the CGI Query Object.
2330      my $cgi = $self->Q();      my $cgi = $self->Q();
2331      my $sprout = $self->DB();      # Loop through the parameter names.
2332      # Get the feature ID.      for my $parm (keys %parmHash) {
2333      my ($fid) = $record->Value('Feature(id)');          # Get the incoming value for this parameter.
2334      # Declare the return variable. Denote that we default to a non-breaking space,          my $value = $cgi->param($parm);
2335      # which will translate to an empty table cell (rather than a table cell with no          # Zero might be a valid value, so we do an is-defined check rather than an OR.
2336      # interior, which is what you get for a null string).          if (defined($value)) {
2337      my $retVal = "&nbsp;";              $retVal->{$parm} = $value;
2338      # Process according to the column name.          } else {
2339      if ($colName =~ /^X=(.+)$/) {              $retVal->{$parm} = $parmHash{$parm};
2340          # Here we have an extra column. Only update if the value exists. Note that          }
         # a value of C<undef> is treated as a non-existent value, because the  
         # caller may have put "colName => undef" in the "PutFeature" call in order  
         # to insure we know the extra column exists.  
         if (defined $extraCols->{$1}) {  
             $retVal = $extraCols->{$1};  
         }  
     } elsif ($colName eq 'orgName') {  
         # Here we want the formatted organism name and feature number.  
         $retVal = $self->FeatureName($fid);  
     } elsif ($colName eq 'fid') {  
         # Here we have the raw feature ID. We hyperlink it to the protein page.  
         $retVal = HTML::set_prot_links($fid);  
     } elsif ($colName eq 'alias') {  
         # In this case, the user wants a list of external aliases for the feature.  
         # The complicated part is we have to hyperlink them. First, get the  
         # aliases.  
         my @aliases = $sprout->FeatureAliases($fid);  
         # Only proceed if we found some.  
         if (@aliases) {  
             # Join the aliases into a comma-delimited list.  
             my $aliasList = join(", ", @aliases);  
             # Ask the HTML processor to hyperlink them.  
             $retVal = HTML::set_prot_links($aliasList);  
         }  
     } elsif ($colName eq 'function') {  
         # The functional assignment is just a matter of getting some text.  
         ($retVal) = $record->Value('Feature(assignment)');  
     } elsif ($colName eq 'gblink') {  
         # Here we want a link to the GBrowse page using the official GBrowse button.  
         my $gurl = "GetGBrowse.cgi?fid=$fid";  
         $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $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 })  
                          );  
     } elsif ($colName eq 'group') {  
         # Get the NMPDR group name.  
         my (undef, $group) = $self->OrganismData($fid);  
         # Dress it with a URL to the group's main page.  
         my $nurl = $sprout->GroupPageName($group);  
         $retVal = $cgi->a({ href => $nurl, title => "$group summary" },  
                           $group);  
2341      }      }
2342      # Return the result.      # Return the result.
2343      return $retVal;      return $retVal;
2344  }  }
2345    
2346    =head3 GetPreferredAliasType
2347    
2348    C<< my $type = $shelp->GetPreferredAliasType(); >>
2349    
2350    Return the preferred alias type for the current session. This information is stored
2351    in the C<AliasType> parameter of the CGI query object, and the default is C<FIG>
2352    (which indicates the FIG ID).
2353    
2354    =cut
2355    
2356    sub GetPreferredAliasType {
2357        # Get the parameters.
2358        my ($self) = @_;
2359        # Determine the preferred type.
2360        my $cgi = $self->Q();
2361        my $retVal = $cgi->param('AliasType') || 'FIG';
2362        # Return it.
2363        return $retVal;
2364    }
2365    
2366    =head2 Virtual Methods
2367    
2368    =head3 Form
2369    
2370    C<< my $html = $shelp->Form(); >>
2371    
2372    Generate the HTML for a form to request a new search.
2373    
2374    =head3 Find
2375    
2376    C<< my $resultCount = $shelp->Find(); >>
2377    
2378    Conduct a search based on the current CGI query parameters. The search results will
2379    be written to the session cache file and the number of results will be
2380    returned. If the search parameters are invalid, a result count of C<undef> will be
2381    returned and a result message will be stored in this object describing the problem.
2382    
2383    =cut
2384    
2385    sub Find {
2386        # Get the parameters.
2387        my ($self) = @_;
2388        $self->Message("Call to pure virtual Find method in helper of type " . ref($self) . ".");
2389        return undef;
2390    }
2391    
2392    =head3 Description
2393    
2394    C<< my $htmlText = $shelp->Description(); >>
2395    
2396    Return a description of this search. The description is used for the table of contents
2397    on the main search tools page. It may contain HTML, but it should be character-level,
2398    not block-level, since the description is going to appear in a list.
2399    
2400    =cut
2401    
2402    sub Description {
2403        # Get the parameters.
2404        my ($self) = @_;
2405        $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2406        return "Unknown search type";
2407    }
2408    
2409    =head3 SearchTitle
2410    
2411    C<< my $titleHtml = $shelp->SearchTitle(); >>
2412    
2413    Return the display title for this search. The display title appears above the search results.
2414    If no result is returned, no title will be displayed. The result should be an html string
2415    that can be legally put inside a block tag such as C<h3> or C<p>.
2416    
2417    =cut
2418    
2419    sub SearchTitle {
2420        # Get the parameters.
2421        my ($self) = @_;
2422        # Declare the return variable.
2423        my $retVal = "";
2424        # Return it.
2425        return $retVal;
2426    }
2427    
2428    =head3 DefaultColumns
2429    
2430    C<< $shelp->DefaultColumns($rhelp); >>
2431    
2432    Store the default columns in the result helper. The default action is just to ask
2433    the result helper for its default columns, but this may be changed by overriding
2434    this method.
2435    
2436    =over 4
2437    
2438    =item rhelp
2439    
2440    Result helper object in which the column list should be stored.
2441    
2442    =back
2443    
2444    =cut
2445    
2446    sub DefaultColumns {
2447        # Get the parameters.
2448        my ($self, $rhelp) = @_;
2449        # Get the default columns from the result helper.
2450        my @cols = $rhelp->DefaultResultColumns();
2451        # Store them back.
2452        $rhelp->SetColumns(@cols);
2453    }
2454    
2455    =head3 Hint
2456    
2457    C<< my $htmlText = SearchHelper::Hint($wikiPage, $hintText); >>
2458    
2459    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
2460    This HTML can be put in forms to provide a useful hinting mechanism.
2461    
2462    =over 4
2463    
2464    =item wikiPage
2465    
2466    Name of the wiki page to be popped up when the hint maek is clicked.
2467    
2468    =item hintText
2469    
2470    Text to display for the hint. It is raw html, but may not contain any double quotes.
2471    
2472    =item RETURN
2473    
2474    Returns the html for the hint facility. The resulting html shows a small button-like thing that
2475    uses the standard FIG popup technology.
2476    
2477    =back
2478    
2479    =cut
2480    
2481    sub Hint {
2482        # Get the parameters.
2483        my ($wikiPage, $hintText) = @_;
2484        # Escape the single quotes in the hint text.
2485        my $quotedText = $hintText;
2486        $quotedText =~ s/'/\\'/g;
2487        # Convert the wiki page name to a URL.
2488        my $wikiURL = ucfirst $wikiPage;
2489        $wikiURL =~ s/ /_/g;
2490        $wikiURL = "../wiki/index.php/$wikiURL";
2491        # Create the html.
2492        my $retVal = "&nbsp;<input type=\"button\" class=\"hintbutton\" onMouseOver=\"javascript:if (!this.tooltip) { " .
2493                     "this.tooltip = new Popup_Tooltip(this, 'Search Hint', '$quotedText', '', 1); this.tooltip.addHandler(); } " .
2494                     "return false;\" value=\"?\" onClick=\"javascript:window.open('$wikiURL', 'nmpdrHelp');\" />";
2495        # Return it.
2496        return $retVal;
2497    }
2498    
2499    
2500  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3