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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (view) (download) (as text)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package SearchHelper;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use PageBuilder;
8 :     use Digest::MD5;
9 :     use File::Basename;
10 :     use File::Path;
11 :     use File::stat;
12 :     use LWP::UserAgent;
13 :     use Time::HiRes 'gettimeofday';
14 :     use Sprout;
15 :     use SFXlate;
16 :     use FIGRules;
17 :     use HTML;
18 :     use BasicLocation;
19 : parrello 1.2 use FeatureQuery;
20 : parrello 1.3 use URI::Escape;
21 :     use PageBuilder;
22 : parrello 1.33 use POSIX;
23 : parrello 1.1
24 :     =head1 Search Helper Base Class
25 :    
26 :     =head2 Introduction
27 :    
28 :     The search helper is a base class for all search objects. It has methods for performing
29 :     all the common tasks required to build and manage a search cache. The subclass must
30 :     provide methods for generating and processing search forms. The base class has the
31 :     following object fields.
32 :    
33 :     =over 4
34 :    
35 :     =item cols
36 :    
37 :     Reference to a list of column header descriptions. If undefined, then the session cache
38 :     file has been opened but nothing has been written to it.
39 :    
40 :     =item fileHandle
41 :    
42 :     File handle for the session cache file.
43 :    
44 :     =item query
45 :    
46 :     CGI query object, which includes the search parameters and the various
47 :     session status variables kept between requests from the user.
48 :    
49 :     =item type
50 :    
51 :     Session type: C<old> if there is an existing cache file from which we are
52 :     displaying search results, or C<new> if the cache file needs to be built.
53 :    
54 :     =item class
55 :    
56 :     Name of the search helper class as it would appear in the CGI query object
57 :     (i.e. without the C<SH> prefix.
58 :    
59 :     =item sprout
60 :    
61 :     Sprout object for accessing the database.
62 :    
63 :     =item message
64 :    
65 :     Message to display if an error has been detected.
66 :    
67 :     =item orgs
68 :    
69 :     Reference to a hash mapping genome IDs to organism names.
70 :    
71 :     =item name
72 :    
73 :     Name to use for this object's form.
74 :    
75 :     =item scriptQueue
76 :    
77 :     List of JavaScript statements to be executed after the form is closed.
78 :    
79 : parrello 1.3 =item genomeHash
80 :    
81 :     Cache of the genome group hash used to build genome selection controls.
82 :    
83 :     =item genomeParms
84 :    
85 :     List of the parameters that are used to select multiple genomes.
86 :    
87 :     =item filtered
88 :    
89 :     TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
90 :     field is updated by the B<FeatureQuery> object.
91 :    
92 : parrello 1.27 =item extraPos
93 :    
94 : parrello 1.30 Hash indicating which extra columns should be put at the end. Extra columns
95 :     not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
96 :     method to change this option.
97 : parrello 1.27
98 : parrello 1.1 =back
99 :    
100 : parrello 1.2 =head2 Adding a new Search Tool
101 :    
102 :     To add a new search tool to the system, you must
103 :    
104 :     =over 4
105 :    
106 :     =item 1
107 :    
108 :     Choose a class name for your search tool.
109 :    
110 :     =item 2
111 :    
112 :     Create a new subclass of this object and implement each of the virtual methods. The
113 :     name of the subclass must be C<SH>I<className>.
114 :    
115 :     =item 3
116 :    
117 :     Create an include file among the web server pages that describes how to use
118 :     the search tool. The include file must be in the B<includes> directory, and
119 :     its name must be C<SearchHelp_>I<className>C<.inc>.
120 :    
121 :     =item 4
122 :    
123 : parrello 1.15 In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
124 : parrello 1.2
125 :     =back
126 :    
127 :     =head3 Building a Search Form
128 :    
129 :     All search forms are three-column tables. In general, you want one form
130 :     variable per table row. The first column should contain the label and
131 :     the second should contain the form control for specifying the variable
132 :     value. If the control is wide, you should use C<colspan="2"> to give it
133 :     extra room. B<Do not> specify a width in any of your table cells, as
134 :     width management is handled by this class.
135 :    
136 :     The general code for creating the form should be
137 :    
138 :     sub Form {
139 :     my ($self) = @_;
140 :     # Get the CGI object.
141 :     my $cgi = @self->Q();
142 :     # Start the form.
143 :     my $retVal = $self->FormStart("form title");
144 :     # Assemble the table rows.
145 :     my @rows = ();
146 :     ... push table row Html into @rows ...
147 :     push @rows, $self->SubmitRow();
148 :     ... push more Html into @rows ...
149 :     # Build the table from the rows.
150 :     $retVal .= $self->MakeTable(\@rows);
151 :     # Close the form.
152 :     $retVal .= $self->FormEnd();
153 :     # Return the form Html.
154 :     return $retVal;
155 :     }
156 :    
157 :     Several helper methods are provided for particular purposes.
158 :    
159 :     =over 4
160 :    
161 :     =item 1
162 :    
163 : parrello 1.3 L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
164 :     L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
165 :     name. Note that as an assist to people working with GET-style links, if no
166 :     genomes are specified and the incoming request style is GET, all genomes will
167 :     be returned.
168 : parrello 1.2
169 :     =item 2
170 :    
171 :     L</FeatureFilterRow> formats several rows of controls for filtering features.
172 :     When you start building the code for the L</Find> method, you can use a
173 :     B<FeatureQuery> object to automatically filter each genome's features using
174 :     the values from the filter controls.
175 :    
176 :     =item 3
177 :    
178 :     L</QueueFormScript> allows you to queue JavaScript statements for execution
179 :     after the form is fully generated. If you are using very complicated
180 :     form controls, the L</QueueFormScript> method allows you to perform
181 :     JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
182 :     facility to display a list of the pre-selected genomes.
183 :    
184 :     =back
185 :    
186 : parrello 1.14 If you are doing a feature search, you can also change the list of feature
187 :     columns displayed and their display order by overriding
188 :     L</DefaultFeatureColumns>.
189 :    
190 : parrello 1.2 Finally, when generating the code for your controls, be sure to use any incoming
191 :     query parameters as default values so that the search request is persistent.
192 :    
193 :     =head3 Finding Search Results
194 :    
195 :     The L</Find> method is used to create the search results. For a search that
196 :     wants to return features (which is most of them), the basic code structure
197 :     would work as follows. It is assumed that the L</FeatureFilterRows> method
198 :     has been used to create feature filtering parameters.
199 :    
200 :     sub Find {
201 :     my ($self) = @_;
202 :     # Get the CGI and Sprout objects.
203 :     my $cgi = $self->Q();
204 :     my $sprout = $self->DB();
205 :     # Declare the return variable. If it remains undefined, the caller will
206 :     # know that an error occurred.
207 :     my $retVal;
208 :     ... validate the parameters ...
209 :     if (... invalid parameters...) {
210 :     $self->SetMessage(...appropriate message...);
211 :     } elsif (FeatureQuery::Valid($self)) {
212 :     # Initialize the session file.
213 :     $self->OpenSession();
214 :     # Initialize the result counter.
215 :     $retVal = 0;
216 :     ... get a list of genomes ...
217 :     for my $genomeID (... each genome ...) {
218 :     my $fq = FeatureQuery->new($self, $genomeID);
219 :     while (my $feature = $fq->Fetch()) {
220 :     ... examine the feature ...
221 :     if (... we want to keep it ...) {
222 :     $self->PutFeature($fq);
223 :     $retVal++;
224 :     }
225 :     }
226 :     }
227 : parrello 1.9 # Close the session file.
228 :     $self->CloseSession();
229 : parrello 1.2 }
230 :     # Return the result count.
231 :     return $retVal;
232 :     }
233 :    
234 :     A Find method is of course much more complicated than generating a form, and there
235 : parrello 1.14 are variations on the above theme. For example, you could eschew feature filtering
236 : parrello 1.2 entirely in favor of your own custom filtering, you could include extra columns
237 :     in the output, or you could search for something that's not a feature at all. The
238 :     above code is just a loose framework.
239 :    
240 : parrello 1.28 In addition to the finding and filtering, it is necessary to send status messages
241 :     to the output so that the user does not get bored waiting for results. The L</PrintLine>
242 :     method performs this function. The single parameter should be text to be
243 :     output to the browser. In general, you'll invoke it as follows.
244 :    
245 :     $self->PrintLine("...my message text...<br />");
246 :    
247 :     The break tag is optional. When the Find method gets control, a paragraph will
248 :     have been started so that everything is XHTML-compliant.
249 :    
250 : parrello 1.2 If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
251 :     method of the feature query object.
252 :    
253 :     $fq->AddExtraColumns(score => $sc);
254 :    
255 :     The L</Find> method must return C<undef> if the search parameters are invalid. If this
256 :     is the case, then a message describing the problem should be passed to the framework
257 :     by calling L</SetMessage>. If the parameters are valid, then the method must return
258 :     the number of items found.
259 :    
260 : parrello 1.1 =cut
261 :    
262 :     # This counter is used to insure every form on the page has a unique name.
263 :     my $formCount = 0;
264 : parrello 1.16 # This counter is used to generate unique DIV IDs.
265 :     my $divCount = 0;
266 : parrello 1.1
267 :     =head2 Public Methods
268 :    
269 :     =head3 new
270 :    
271 : parrello 1.28 C<< my $shelp = SearchHelper->new($cgi); >>
272 : parrello 1.1
273 :     Construct a new SearchHelper object.
274 :    
275 :     =over 4
276 :    
277 : parrello 1.19 =item cgi
278 : parrello 1.1
279 :     The CGI query object for the current script.
280 :    
281 :     =back
282 :    
283 :     =cut
284 :    
285 :     sub new {
286 :     # Get the parameters.
287 : parrello 1.19 my ($class, $cgi) = @_;
288 : parrello 1.1 # Check for a session ID.
289 : parrello 1.19 my $session_id = $cgi->param("SessionID");
290 : parrello 1.1 my $type = "old";
291 :     if (! $session_id) {
292 : parrello 1.26 Trace("No session ID found.") if T(3);
293 : parrello 1.1 # Here we're starting a new session. We create the session ID and
294 :     # store it in the query object.
295 :     $session_id = NewSessionID();
296 :     $type = "new";
297 : parrello 1.19 $cgi->param(-name => 'SessionID', -value => $session_id);
298 : parrello 1.26 } else {
299 :     Trace("Session ID is $session_id.") if T(3);
300 : parrello 1.1 }
301 :     # Compute the subclass name.
302 : parrello 1.19 my $subClass;
303 :     if ($class =~ /SH(.+)$/) {
304 :     # Here we have a real search class.
305 :     $subClass = $1;
306 :     } else {
307 :     # Here we have a bare class. The bare class cannot search, but it can
308 :     # process search results.
309 :     $subClass = 'SearchHelper';
310 :     }
311 : parrello 1.1 # Insure everybody knows we're in Sprout mode.
312 : parrello 1.19 $cgi->param(-name => 'SPROUT', -value => 1);
313 : parrello 1.1 # Generate the form name.
314 :     my $formName = "$class$formCount";
315 :     $formCount++;
316 :     # Create the shelp object. It contains the query object (with the session ID)
317 :     # as well as an indicator as to whether or not the session is new, plus the
318 : parrello 1.2 # class name and a placeholder for the Sprout object.
319 : parrello 1.1 my $retVal = {
320 : parrello 1.19 query => $cgi,
321 : parrello 1.1 type => $type,
322 :     class => $subClass,
323 : parrello 1.2 sprout => undef,
324 : parrello 1.1 orgs => {},
325 :     name => $formName,
326 :     scriptQueue => [],
327 : parrello 1.3 genomeList => undef,
328 :     genomeParms => [],
329 :     filtered => 0,
330 : parrello 1.30 extraPos => {},
331 : parrello 1.1 };
332 :     # Bless and return it.
333 :     bless $retVal, $class;
334 :     return $retVal;
335 :     }
336 :    
337 :     =head3 Q
338 :    
339 :     C<< my $query = $shelp->Q(); >>
340 :    
341 :     Return the CGI query object.
342 :    
343 :     =cut
344 :    
345 :     sub Q {
346 :     # Get the parameters.
347 :     my ($self) = @_;
348 :     # Return the result.
349 :     return $self->{query};
350 :     }
351 :    
352 : parrello 1.9
353 :    
354 : parrello 1.1 =head3 DB
355 :    
356 :     C<< my $sprout = $shelp->DB(); >>
357 :    
358 :     Return the Sprout database object.
359 :    
360 :     =cut
361 :    
362 :     sub DB {
363 :     # Get the parameters.
364 :     my ($self) = @_;
365 : parrello 1.2 # Insure we have a database.
366 :     my $retVal = $self->{sprout};
367 :     if (! defined $retVal) {
368 :     $retVal = SFXlate->new_sprout_only();
369 :     $self->{sprout} = $retVal;
370 :     }
371 : parrello 1.1 # Return the result.
372 : parrello 1.2 return $retVal;
373 : parrello 1.1 }
374 :    
375 :     =head3 IsNew
376 :    
377 :     C<< my $flag = $shelp->IsNew(); >>
378 :    
379 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
380 :     session already has search results ready to process.
381 :    
382 :     =cut
383 :    
384 :     sub IsNew {
385 :     # Get the parameters.
386 :     my ($self) = @_;
387 :     # Return the result.
388 :     return ($self->{type} eq 'new');
389 :     }
390 :    
391 : parrello 1.27 =head3 SetExtraPos
392 :    
393 : parrello 1.30 C<< $shelp->SetExtraPos(@columnMap); >>
394 : parrello 1.27
395 :     Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
396 :    
397 :     =over 4
398 :    
399 : parrello 1.30 =item columnMap
400 : parrello 1.27
401 : parrello 1.30 A list of extra columns to display at the end.
402 : parrello 1.27
403 :     =back
404 :    
405 :     =cut
406 :    
407 :     sub SetExtraPos {
408 : parrello 1.30 # Get the parameters.
409 :     my ($self, @columnMap) = @_;
410 :     # Convert the column map to a hash.
411 :     my %map = map { $_ => 1 } @columnMap;
412 :     # Save a reference to it.
413 :     $self->{extraPos} = \%map;
414 : parrello 1.27 }
415 :    
416 : parrello 1.1 =head3 ID
417 :    
418 :     C<< my $sessionID = $shelp->ID(); >>
419 :    
420 :     Return the current session ID.
421 :    
422 :     =cut
423 :    
424 :     sub ID {
425 :     # Get the parameters.
426 :     my ($self) = @_;
427 :     # Return the result.
428 :     return $self->Q()->param("SessionID");
429 :     }
430 :    
431 :     =head3 FormName
432 :    
433 :     C<< my $name = $shelp->FormName(); >>
434 :    
435 :     Return the name of the form this helper object will generate.
436 :    
437 :     =cut
438 :    
439 :     sub FormName {
440 :     # Get the parameters.
441 :     my ($self) = @_;
442 :     # Return the result.
443 :     return $self->{name};
444 :     }
445 :    
446 :     =head3 QueueFormScript
447 :    
448 :     C<< $shelp->QueueFormScript($statement); >>
449 :    
450 :     Add the specified statement to the queue of JavaScript statements that are to be
451 :     executed when the form has been fully defined. This is necessary because until
452 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
453 :     name. When generating the statement, you can refer to the variable C<thisForm>
454 :     in order to reference the form in progress. Thus,
455 :    
456 :     thisForm.simLimit.value = 1e-10;
457 :    
458 :     would set the value of the form element C<simLimit> in the current form to
459 :     C<1e-10>.
460 :    
461 :     =over 4
462 :    
463 :     =item statement
464 :    
465 :     JavaScript statement to be queued for execution after the form is built.
466 :     The trailing semi-colon is required. Theoretically, you could include
467 :     multiple statements separated by semi-colons, but one at a time works
468 :     just as well.
469 :    
470 :     =back
471 :    
472 :     =cut
473 :    
474 :     sub QueueFormScript {
475 :     # Get the parameters.
476 :     my ($self, $statement) = @_;
477 :     # Push the statement onto the script queue.
478 :     push @{$self->{scriptQueue}}, $statement;
479 :     }
480 :    
481 :     =head3 FormStart
482 :    
483 :     C<< my $html = $shelp->FormStart($title); >>
484 :    
485 :     Return the initial section of a form designed to perform another search of the
486 :     same type. The form header is included along with hidden fields to persist the
487 :     tracing, sprout status, and search class.
488 :    
489 :     A call to L</FormEnd> is required to close the form.
490 :    
491 :     =over 4
492 :    
493 :     =item title
494 :    
495 :     Title to be used for the form.
496 :    
497 :     =item RETURN
498 :    
499 :     Returns the initial HTML for the search form.
500 :    
501 :     =back
502 :    
503 :     =cut
504 :    
505 :     sub FormStart {
506 :     # Get the parameters.
507 :     my ($self, $title) = @_;
508 :     # Get the CGI object.
509 :     my $cgi = $self->Q();
510 : parrello 1.18 # Start the form. Note we use the override option on the Class value, in
511 :     # case the Advanced button was used.
512 : parrello 1.1 my $retVal = "<div class=\"search\">\n" .
513 :     $cgi->start_form(-method => 'POST',
514 :     -action => $cgi->url(-relative => 1),
515 :     -name => $self->FormName()) .
516 :     $cgi->hidden(-name => 'Class',
517 : parrello 1.18 -value => $self->{class},
518 :     -override => 1) .
519 : parrello 1.1 $cgi->hidden(-name => 'SPROUT',
520 :     -value => 1) .
521 :     $cgi->h3($title);
522 :     # If tracing is on, add it to the form.
523 :     if ($cgi->param('Trace')) {
524 :     $retVal .= $cgi->hidden(-name => 'Trace',
525 :     -value => $cgi->param('Trace')) .
526 :     $cgi->hidden(-name => 'TF',
527 :     -value => ($cgi->param('TF') ? 1 : 0));
528 :     }
529 :     # Put in an anchor tag in case there's a table of contents.
530 :     my $anchorName = $self->FormName();
531 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
532 :     # Return the result.
533 :     return $retVal;
534 :     }
535 :    
536 :     =head3 FormEnd
537 :    
538 :     C<< my $htmlText = $shelp->FormEnd(); >>
539 :    
540 :     Return the HTML text for closing a search form. This closes both the C<form> and
541 :     C<div> tags.
542 :    
543 :     =cut
544 :    
545 :     sub FormEnd {
546 :     # Get the parameters.
547 :     my ($self) = @_;
548 :     # Declare the return variable, closing the form and the DIV block.
549 :     my $retVal = "</form></div>\n";
550 :     # Now we flush out the statement queue.
551 :     my @statements = @{$self->{scriptQueue}};
552 :     if (@statements > 0) {
553 :     # Switch to JavaScript and set the "thisForm" variable.
554 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
555 :     " thisForm = document.$self->{name};\n";
556 :     # Unroll the statements.
557 :     while (@statements > 0) {
558 :     my $statement = shift @statements;
559 :     $retVal .= " $statement\n";
560 :     }
561 :     # Close the JavaScript.
562 :     $retVal .= "</SCRIPT>\n";
563 :     }
564 :     # Return the result.
565 :     return $retVal;
566 :     }
567 :    
568 :     =head3 SetMessage
569 :    
570 :     C<< $shelp->SetMessage($msg); >>
571 :    
572 :     Store the specified text as the result message. The result message is displayed
573 :     if an invalid parameter value is specified.
574 :    
575 :     =over 4
576 :    
577 :     =item msg
578 :    
579 :     Text of the result message to be displayed.
580 :    
581 :     =back
582 :    
583 :     =cut
584 :    
585 :     sub SetMessage {
586 :     # Get the parameters.
587 :     my ($self, $msg) = @_;
588 :     # Store the message.
589 :     $self->{message} = $msg;
590 :     }
591 :    
592 :     =head3 Message
593 :    
594 :     C<< my $text = $shelp->Message(); >>
595 :    
596 :     Return the result message. The result message is displayed if an invalid parameter
597 :     value is specified.
598 :    
599 :     =cut
600 :    
601 :     sub Message {
602 :     # Get the parameters.
603 :     my ($self) = @_;
604 :     # Return the result.
605 :     return $self->{message};
606 :     }
607 :    
608 :     =head3 OpenSession
609 :    
610 :     C<< $shelp->OpenSession(); >>
611 :    
612 :     Set up to open the session cache file for writing. Note we don't actually
613 :     open the file until after we know the column headers.
614 :    
615 :     =cut
616 :    
617 :     sub OpenSession {
618 :     # Get the parameters.
619 :     my ($self) = @_;
620 :     # Denote we have not yet written out the column headers.
621 :     $self->{cols} = undef;
622 :     }
623 :    
624 :     =head3 GetCacheFileName
625 :    
626 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
627 :    
628 :     Return the name to be used for this session's cache file.
629 :    
630 :     =cut
631 :    
632 :     sub GetCacheFileName {
633 :     # Get the parameters.
634 :     my ($self) = @_;
635 :     # Return the result.
636 :     return $self->GetTempFileName('cache');
637 :     }
638 :    
639 :     =head3 GetTempFileName
640 :    
641 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
642 :    
643 :     Return the name to be used for a temporary file of the specified type. The
644 :     name is computed from the session name with the type as a suffix.
645 :    
646 :     =over 4
647 :    
648 :     =item type
649 :    
650 :     Type of temporary file to be generated.
651 :    
652 :     =item RETURN
653 :    
654 :     Returns a file name generated from the session name and the specified type.
655 :    
656 :     =back
657 :    
658 :     =cut
659 :    
660 :     sub GetTempFileName {
661 :     # Get the parameters.
662 :     my ($self, $type) = @_;
663 :     # Compute the file name. Note it gets stuffed in the FIG temporary
664 :     # directory.
665 :     my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";
666 :     # Return the result.
667 :     return $retVal;
668 :     }
669 :    
670 :     =head3 PutFeature
671 :    
672 : parrello 1.11 C<< $shelp->PutFeature($fdata); >>
673 : parrello 1.1
674 :     Store a feature in the result cache. This is the workhorse method for most
675 :     searches, since the primary data item in the database is features.
676 :    
677 :     For each feature, there are certain columns that are standard: the feature name, the
678 :     GBrowse and protein page links, the functional assignment, and so forth. If additional
679 : parrello 1.2 columns are required by a particular search subclass, they should be stored in
680 :     the feature query object using the B<AddExtraColumns> method. For example, the following
681 :     code adds columns for essentiality and virulence.
682 : parrello 1.1
683 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
684 :     $shelp->PutFeature($fd);
685 : parrello 1.1
686 :     For correct results, all values should be specified for all extra columns in all calls to
687 :     B<PutFeature>. (In particular, the column header names are computed on the first
688 :     call.) If a column is to be blank for the current feature, its value can be given
689 :     as C<undef>.
690 :    
691 :     if (! $essentialFlag) {
692 :     $essentialFlag = undef;
693 :     }
694 : parrello 1.11 $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
695 :     $shelp->PutFeature($fd);
696 : parrello 1.1
697 :     =over 4
698 :    
699 : parrello 1.11 =item fdata
700 : parrello 1.1
701 : parrello 1.11 B<FeatureData> object containing the current feature data.
702 : parrello 1.1
703 :     =back
704 :    
705 :     =cut
706 :    
707 :     sub PutFeature {
708 : parrello 1.2 # Get the parameters.
709 : parrello 1.11 my ($self, $fd) = @_;
710 : parrello 1.3 # Get the CGI query object.
711 :     my $cgi = $self->Q();
712 : parrello 1.2 # Get the feature data.
713 : parrello 1.11 my $record = $fd->Feature();
714 :     my $extraCols = $fd->ExtraCols();
715 : parrello 1.1 # Check for a first-call situation.
716 :     if (! defined $self->{cols}) {
717 : parrello 1.14 Trace("Setting up the columns.") if T(3);
718 : parrello 1.28 # Tell the user what's happening.
719 :     $self->PrintLine("Creating output columns.<br />");
720 : parrello 1.27 # Here we need to set up the column information. First we accumulate the extras,
721 : parrello 1.30 # sorted by column name and separate by whether they go in the beginning or the
722 :     # end.
723 :     my @xtraNamesFront = ();
724 :     my @xtraNamesEnd = ();
725 :     my $xtraPosMap = $self->{extraPos};
726 : parrello 1.27 for my $col (sort keys %{$extraCols}) {
727 : parrello 1.30 if ($xtraPosMap->{$col}) {
728 :     push @xtraNamesEnd, "X=$col";
729 :     } else {
730 :     push @xtraNamesFront, "X=$col";
731 :     }
732 : parrello 1.27 }
733 :     # Set up the column name array.
734 : parrello 1.14 my @colNames = ();
735 : parrello 1.30 # Put in the extra columns that go in the beginning.
736 :     push @colNames, @xtraNamesFront;
737 : parrello 1.14 # Add the default columns.
738 :     push @colNames, $self->DefaultFeatureColumns();
739 :     # Add any additional columns requested by the feature filter.
740 :     push @colNames, FeatureQuery::AdditionalColumns($self);
741 : parrello 1.27 # If extras go at the end, put them in here.
742 : parrello 1.30 push @colNames, @xtraNamesEnd;
743 : parrello 1.23 Trace("Full column list determined.") if T(3);
744 : parrello 1.14 # Save the full list.
745 :     $self->{cols} = \@colNames;
746 : parrello 1.28 # Write out the column names. This also prepares the cache file to receive
747 : parrello 1.1 # output.
748 : parrello 1.23 Trace("Writing column headers.") if T(3);
749 : parrello 1.28 $self->WriteColumnHeaders(@{$self->{cols}});
750 : parrello 1.23 Trace("Column headers written.") if T(3);
751 : parrello 1.1 }
752 :     # Get the feature ID.
753 : parrello 1.11 my $fid = $fd->FID();
754 : parrello 1.29 # Loop through the column headers, producing the desired data. The first column
755 :     # is the feature ID. The feature ID does not show up in the output: its purpose
756 :     # is to help the various output formatters.
757 :     my @output = ($fid);
758 : parrello 1.1 for my $colName (@{$self->{cols}}) {
759 : parrello 1.2 push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
760 : parrello 1.1 }
761 : parrello 1.9 # Compute the sort key. The sort key usually floats NMPDR organism features to the
762 : parrello 1.1 # top of the return list.
763 : parrello 1.11 my $key = $self->SortKey($fd);
764 : parrello 1.1 # Write the feature data.
765 :     $self->WriteColumnData($key, @output);
766 :     }
767 :    
768 :     =head3 WriteColumnHeaders
769 :    
770 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
771 :    
772 :     Write out the column headers for the current search session. The column headers
773 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
774 :     the handle saved.
775 :    
776 :     =over 4
777 :    
778 :     =item colNames
779 :    
780 :     A list of column names in the desired presentation order.
781 :    
782 :     =back
783 :    
784 :     =cut
785 :    
786 :     sub WriteColumnHeaders {
787 :     # Get the parameters.
788 :     my ($self, @colNames) = @_;
789 :     # Get the cache file name and open it for output.
790 :     my $fileName = $self->GetCacheFileName();
791 :     my $handle1 = Open(undef, ">$fileName");
792 :     # Write the column headers and close the file.
793 :     Tracer::PutLine($handle1, \@colNames);
794 :     close $handle1;
795 : parrello 1.32 Trace("Column headers are: " . join("; ", @colNames) . ".") if T(3);
796 : parrello 1.1 # Now open the sort pipe and save the file handle. Note how we append the
797 :     # sorted data to the column header row already in place. The output will
798 :     # contain a sort key followed by the real columns. The sort key is
799 :     # hacked off before going to the output file.
800 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
801 :     }
802 :    
803 :     =head3 WriteColumnData
804 :    
805 :     C<< $shelp->WriteColumnData($key, @colValues); >>
806 :    
807 :     Write a row of column values to the current search session. It is assumed that
808 :     the session file is already open for output.
809 :    
810 :     =over 4
811 :    
812 :     =item key
813 :    
814 :     Sort key.
815 :    
816 :     =item colValues
817 :    
818 :     List of column values to write to the search result cache file for this session.
819 :    
820 :     =back
821 :    
822 :     =cut
823 :    
824 :     sub WriteColumnData {
825 :     # Get the parameters.
826 :     my ($self, $key, @colValues) = @_;
827 :     # Write them to the cache file.
828 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
829 : parrello 1.32 Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
830 : parrello 1.1 }
831 :    
832 :     =head3 CloseSession
833 :    
834 :     C<< $shelp->CloseSession(); >>
835 :    
836 :     Close the session file.
837 :    
838 :     =cut
839 :    
840 :     sub CloseSession {
841 :     # Get the parameters.
842 :     my ($self) = @_;
843 :     # Check for an open session file.
844 :     if (defined $self->{fileHandle}) {
845 :     # We found one, so close it.
846 : parrello 1.9 Trace("Closing session file.") if T(2);
847 : parrello 1.1 close $self->{fileHandle};
848 : parrello 1.28 # Tell the user.
849 :     my $cgi = $self->Q();
850 :     $self->PrintLine("Output formatting complete.<br />");
851 : parrello 1.1 }
852 :     }
853 :    
854 :     =head3 NewSessionID
855 :    
856 :     C<< my $id = SearchHelpers::NewSessionID(); >>
857 :    
858 :     Generate a new session ID for the current user.
859 :    
860 :     =cut
861 :    
862 :     sub NewSessionID {
863 :     # Declare the return variable.
864 :     my $retVal;
865 :     # Get a digest encoder.
866 :     my $md5 = Digest::MD5->new();
867 : parrello 1.4 # Add the PID, the IP, and the time stamp. Note that the time stamp is
868 :     # actually two numbers, and we get them both because we're in list
869 :     # context.
870 :     $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
871 :     # Hash up all this identifying data.
872 :     $retVal = $md5->hexdigest();
873 :     # Return the result.
874 : parrello 1.1 return $retVal;
875 :     }
876 :    
877 :     =head3 OrganismData
878 :    
879 : parrello 1.33 C<< my ($orgName, $group, $domain) = $shelp->Organism($genomeID); >>
880 : parrello 1.1
881 :     Return the name and status of the organism corresponding to the specified genome ID.
882 :     For performance reasons, this information is cached in a special hash table, so we
883 :     only compute it once per run.
884 :    
885 :     =over 4
886 :    
887 :     =item genomeID
888 :    
889 :     ID of the genome whose name is desired.
890 :    
891 :     =item RETURN
892 :    
893 : parrello 1.32 Returns a list of three items. The first item in the list is the organism name,
894 : parrello 1.1 and the second is the name of the NMPDR group, or an empty string if the
895 : parrello 1.32 organism is not in an NMPDR group. The third item is the organism's domain.
896 : parrello 1.1
897 :     =back
898 :    
899 :     =cut
900 :    
901 :     sub OrganismData {
902 :     # Get the parameters.
903 :     my ($self, $genomeID) = @_;
904 :     # Declare the return variables.
905 : parrello 1.32 my ($orgName, $group, $domain);
906 : parrello 1.1 # Check the cache.
907 :     my $cache = $self->{orgs};
908 :     if (exists $cache->{$genomeID}) {
909 : parrello 1.32 ($orgName, $group, $domain) = @{$cache->{$genomeID}};
910 : parrello 1.1 } else {
911 :     # Here we have to use the database.
912 :     my $sprout = $self->DB();
913 : parrello 1.32 my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
914 :     ['Genome(genus)', 'Genome(species)',
915 :     'Genome(unique-characterization)',
916 :     'Genome(primary-group)',
917 :     'Genome(taxonomy)']);
918 : parrello 1.10 # Format and cache the name and display group.
919 : parrello 1.32 ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
920 :     $strain, $taxonomy);
921 : parrello 1.1 }
922 :     # Return the result.
923 : parrello 1.32 return ($orgName, $group, $domain);
924 : parrello 1.1 }
925 :    
926 :     =head3 Organism
927 :    
928 :     C<< my $orgName = $shelp->Organism($genomeID); >>
929 :    
930 :     Return the name of the relevant organism. The name is computed from the genus,
931 :     species, and unique characterization. A cache is used to improve performance.
932 :    
933 :     =over 4
934 :    
935 :     =item genomeID
936 :    
937 :     ID of the genome whose name is desired.
938 :    
939 :     =item RETURN
940 :    
941 :     Returns the display name of the specified organism.
942 :    
943 :     =back
944 :    
945 :     =cut
946 :    
947 :     sub Organism {
948 :     # Get the parameters.
949 :     my ($self, $genomeID) = @_;
950 :     # Get the organism data.
951 : parrello 1.32 my ($retVal) = $self->OrganismData($genomeID);
952 : parrello 1.1 # Return the result.
953 :     return $retVal;
954 :     }
955 :    
956 :     =head3 FeatureGroup
957 :    
958 :     C<< my $groupName = $shelp->FeatureGroup($fid); >>
959 :    
960 :     Return the group name for the specified feature.
961 :    
962 :     =over 4
963 :    
964 :     =item fid
965 :    
966 :     ID of the relevant feature.
967 :    
968 :     =item RETURN
969 :    
970 :     Returns the name of the NMPDR group to which the feature belongs, or an empty
971 :     string if it is not part of an NMPDR group.
972 :    
973 :     =back
974 :    
975 :     =cut
976 :    
977 :     sub FeatureGroup {
978 :     # Get the parameters.
979 :     my ($self, $fid) = @_;
980 :     # Parse the feature ID to get the genome ID.
981 :     my ($genomeID) = FIGRules::ParseFeatureID($fid);
982 :     # Get the organism data.
983 :     my (undef, $retVal) = $self->OrganismData($genomeID);
984 :     # Return the result.
985 :     return $retVal;
986 :     }
987 :    
988 :     =head3 FeatureName
989 :    
990 :     C<< my $fidName = $shelp->FeatureName($fid); >>
991 :    
992 :     Return the display name of the specified feature.
993 :    
994 :     =over 4
995 :    
996 :     =item fid
997 :    
998 :     ID of the feature whose name is desired.
999 :    
1000 :     =item RETURN
1001 :    
1002 :     A displayable feature name, consisting of the organism name plus some feature
1003 :     type and location information.
1004 :    
1005 :     =back
1006 :    
1007 :     =cut
1008 :    
1009 :     sub FeatureName {
1010 :     # Get the parameters.
1011 :     my ($self, $fid) = @_;
1012 :     # Declare the return variable
1013 :     my $retVal;
1014 :     # Parse the feature ID.
1015 :     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);
1016 :     if (! defined $genomeID) {
1017 :     # Here the feature ID has an invalid format.
1018 :     $retVal = "External: $fid";
1019 :     } else {
1020 :     # Here we can get its genome data.
1021 :     $retVal = $self->Organism($genomeID);
1022 : parrello 1.4 # Append the FIG ID.
1023 :     $retVal .= " [$fid]";
1024 : parrello 1.1 }
1025 :     # Return the result.
1026 :     return $retVal;
1027 :     }
1028 :    
1029 :     =head3 ComputeFASTA
1030 :    
1031 : parrello 1.32 C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
1032 : parrello 1.1
1033 : parrello 1.32 Parse a sequence input and convert it into a FASTA string of the desired type with
1034 :     the desired flanking width.
1035 : parrello 1.1
1036 :     =over 4
1037 :    
1038 :     =item desiredType
1039 :    
1040 : parrello 1.18 C<dna> to return a DNA sequence, C<prot> to return a protein sequence.
1041 : parrello 1.1
1042 :     =item sequence
1043 :    
1044 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
1045 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
1046 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
1047 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
1048 :     line will be provided.
1049 :    
1050 : parrello 1.32 =item flankingWidth
1051 :    
1052 :     If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
1053 :     feature that should be included. Currently we can't do this for Proteins because the
1054 :     protein translation of a feature doesn't always match the DNA and is taken directly
1055 :     from the database.
1056 :    
1057 : parrello 1.1 =item RETURN
1058 :    
1059 :     Returns a string in FASTA format representing the content of the desired sequence with
1060 :     an appropriate label. If the input is invalid, a message will be stored and we will
1061 :     return C<undef>. Note that the output will include a trailing new-line.
1062 :    
1063 :     =back
1064 :    
1065 :     =cut
1066 :    
1067 :     sub ComputeFASTA {
1068 :     # Get the parameters.
1069 : parrello 1.32 my ($self, $desiredType, $sequence, $flankingWidth) = @_;
1070 : parrello 1.1 # Declare the return variable. If an error occurs, it will remain undefined.
1071 :     my $retVal;
1072 : parrello 1.11 # This variable will be cleared if an error is detected.
1073 :     my $okFlag = 1;
1074 : parrello 1.1 # Create variables to hold the FASTA label and data.
1075 :     my ($fastaLabel, $fastaData);
1076 : parrello 1.18 Trace("FASTA desired type is $desiredType.") if T(4);
1077 : parrello 1.29 # Check for a feature specification. The smoking gun for that is a vertical bar.
1078 : parrello 1.1 if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1079 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
1080 :     # it.
1081 :     my $fid = $1;
1082 : parrello 1.11 Trace("Feature ID for fasta is $fid.") if T(3);
1083 : parrello 1.1 my $sprout = $self->DB();
1084 :     # Get the FIG ID. Note that we only use the first feature found. We are not
1085 :     # supposed to have redundant aliases, though we may have an ID that doesn't
1086 :     # exist.
1087 :     my ($figID) = $sprout->FeaturesByAlias($fid);
1088 :     if (! $figID) {
1089 : parrello 1.17 $self->SetMessage("No gene found with the ID \"$fid\".");
1090 : parrello 1.11 $okFlag = 0;
1091 : parrello 1.1 } else {
1092 : parrello 1.29 # Set the FASTA label. The ID is the first favored alias.
1093 :     my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1094 :     my $favorLen = length $favored;
1095 :     ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1096 :     if (! $fastaLabel) {
1097 :     # In an emergency, fall back to the original ID.
1098 :     $fastaLabel = $fid;
1099 :     }
1100 : parrello 1.1 # Now proceed according to the sequence type.
1101 : parrello 1.33 if ($desiredType =~ /prot/) {
1102 : parrello 1.1 # We want protein, so get the translation.
1103 :     $fastaData = $sprout->FeatureTranslation($figID);
1104 : parrello 1.11 Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1105 : parrello 1.1 } else {
1106 : parrello 1.32 # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
1107 :     # locations.
1108 : parrello 1.1 my @locList = $sprout->FeatureLocation($figID);
1109 : parrello 1.32 if ($flankingWidth > 0) {
1110 :     # Here we need to add flanking data. Convert the locations to a list
1111 :     # of location objects.
1112 :     my @locObjects = map { BasicLocation->new($_) } @locList;
1113 :     # Initialize the return variable. We will put the DNA in here segment by segment.
1114 :     $fastaData = "";
1115 :     # Now we widen each location by the flanking width and stash the results. This
1116 :     # requires getting the contig length for each contig so we don't fall off the end.
1117 :     for my $locObject (@locObjects) {
1118 :     Trace("Current location is " . $locObject->String . ".") if T(4);
1119 :     # Remember the current start and length.
1120 :     my ($start, $len) = ($locObject->Left, $locObject->Length);
1121 :     # Get the contig length.
1122 :     my $contigLen = $sprout->ContigLength($locObject->Contig);
1123 :     # Widen the location and get its DNA.
1124 :     $locObject->Widen($flankingWidth, $contigLen);
1125 :     my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
1126 :     # Now we need to do some case changing. The main DNA is upper case and
1127 :     # the flanking DNA is lower case.
1128 :     my $leftFlank = $start - $locObject->Left;
1129 :     my $rightFlank = $leftFlank + $len;
1130 :     Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1131 :     my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1132 :     uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1133 :     lc(substr($fastaSegment, $rightFlank));
1134 :     $fastaData .= $fancyFastaSegment;
1135 :     }
1136 :     } else {
1137 :     # Here we have just the raw sequence.
1138 :     $fastaData = $sprout->DNASeq(\@locList);
1139 :     }
1140 :     Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1141 : parrello 1.1 }
1142 :     }
1143 :     } else {
1144 : parrello 1.11 Trace("Analyzing FASTA sequence.") if T(4);
1145 : parrello 1.1 # Here we are expecting a FASTA. We need to see if there's a label.
1146 : parrello 1.11 if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1147 :     Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1148 : parrello 1.1 # Here we have a label, so we split it from the data.
1149 :     $fastaLabel = $1;
1150 :     $fastaData = $2;
1151 :     } else {
1152 : parrello 1.11 Trace("No label found in match to sequence:\n$sequence") if T(4);
1153 : parrello 1.1 # Here we have no label, so we create one and use the entire sequence
1154 :     # as data.
1155 : parrello 1.18 $fastaLabel = "User-specified $desiredType sequence";
1156 : parrello 1.1 $fastaData = $sequence;
1157 :     }
1158 :     # The next step is to clean the junk out of the sequence.
1159 :     $fastaData =~ s/\n//g;
1160 :     $fastaData =~ s/\s+//g;
1161 : parrello 1.18 # Finally, verify that it's DNA if we're doing DNA stuff.
1162 : parrello 1.24 if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1163 :     $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1164 : parrello 1.11 $okFlag = 0;
1165 : parrello 1.1 }
1166 :     }
1167 : parrello 1.11 Trace("FASTA data sequence: $fastaData") if T(4);
1168 :     # Only proceed if no error was detected.
1169 :     if ($okFlag) {
1170 : parrello 1.33 if ($desiredType =~ /pattern/i) {
1171 :     # We're doing a scan, so only the data is passed in.
1172 :     $retVal = $fastaData;
1173 :     } else {
1174 :     # We need to format the sequence into 60-byte chunks. We use the infamous
1175 :     # grep-split trick. The split, because of the presence of the parentheses,
1176 :     # includes the matched delimiters in the output list. The grep strips out
1177 :     # the empty list items that appear between the so-called delimiters, since
1178 :     # the delimiters are what we want.
1179 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1180 :     $retVal = join("\n", ">$fastaLabel", @chunks, "");
1181 :     }
1182 : parrello 1.1 }
1183 :     # Return the result.
1184 :     return $retVal;
1185 :     }
1186 :    
1187 : parrello 1.16 =head3 SubsystemTree
1188 :    
1189 :     C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1190 :    
1191 :     This method creates a subsystem selection tree suitable for passing to
1192 :     L</SelectionTree>. Each leaf node in the tree will have a link to the
1193 :     subsystem display page. In addition, each node can have a radio button. The
1194 :     radio button alue is either C<classification=>I<string>, where I<string> is
1195 :     a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1196 :     Thus, it can either be used to filter by a group of related subsystems or a
1197 :     single subsystem.
1198 :    
1199 :     =over 4
1200 :    
1201 :     =item sprout
1202 :    
1203 :     Sprout database object used to get the list of subsystems.
1204 :    
1205 :     =item options
1206 :    
1207 :     Hash containing options for building the tree.
1208 :    
1209 :     =item RETURN
1210 :    
1211 :     Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1212 :    
1213 :     =back
1214 :    
1215 :     The supported options are as follows.
1216 :    
1217 :     =over 4
1218 :    
1219 :     =item radio
1220 :    
1221 :     TRUE if the tree should be configured for radio buttons. The default is FALSE.
1222 :    
1223 :     =item links
1224 :    
1225 :     TRUE if the tree should be configured for links. The default is TRUE.
1226 :    
1227 :     =back
1228 :    
1229 :     =cut
1230 :    
1231 :     sub SubsystemTree {
1232 :     # Get the parameters.
1233 :     my ($sprout, %options) = @_;
1234 :     # Process the options.
1235 :     my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1236 :     # Read in the subsystems.
1237 :     my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1238 :     ['Subsystem(classification)', 'Subsystem(id)']);
1239 : parrello 1.26 # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1240 :     # is at the end, ALL subsystems are unclassified and we don't bother.
1241 :     if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1242 :     while ($subs[0]->[0] eq '') {
1243 :     my $classLess = shift @subs;
1244 :     push @subs, $classLess;
1245 :     }
1246 :     }
1247 : parrello 1.16 # Declare the return variable.
1248 :     my @retVal = ();
1249 :     # Each element in @subs represents a leaf node, so as we loop through it we will be
1250 :     # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1251 :     # first element is a semi-colon-delimited list of the classifications for the
1252 :     # subsystem. There will be a stack of currently-active classifications, which we will
1253 :     # compare to the incoming classifications from the end backward. A new classification
1254 :     # requires starting a new branch. A different classification requires closing an old
1255 :     # branch and starting a new one. Each classification in the stack will also contain
1256 :     # that classification's current branch. We'll add a fake classification at the
1257 :     # beginning that we can use to represent the tree as a whole.
1258 :     my $rootName = '<root>';
1259 :     # Create the classification stack. Note the stack is a pair of parallel lists,
1260 :     # one containing names and the other containing content.
1261 :     my @stackNames = ($rootName);
1262 :     my @stackContents = (\@retVal);
1263 :     # Add a null entry at the end of the subsystem list to force an unrolling.
1264 : parrello 1.27 push @subs, ['', undef];
1265 : parrello 1.16 # Loop through the subsystems.
1266 :     for my $sub (@subs) {
1267 :     # Pull out the classification list and the subsystem ID.
1268 :     my ($classString, $id) = @{$sub};
1269 :     Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1270 :     # Convert the classification string to a list with the root classification in
1271 :     # the front.
1272 :     my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1273 :     # Find the leftmost point at which the class list differs from the stack.
1274 :     my $matchPoint = 0;
1275 :     while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1276 :     $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1277 :     $matchPoint++;
1278 :     }
1279 :     Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1280 :     ". Class List length is " . scalar(@classList) . ".") if T(4);
1281 :     # Unroll the stack to the matchpoint.
1282 :     while ($#stackNames >= $matchPoint) {
1283 :     my $popped = pop @stackNames;
1284 :     pop @stackContents;
1285 :     Trace("\"$popped\" popped from stack.") if T(4);
1286 :     }
1287 :     # Start branches for any new classifications.
1288 :     while ($#stackNames < $#classList) {
1289 :     # The branch for a new classification contains its radio button
1290 :     # data and then a list of children. So, at this point, if radio buttons
1291 :     # are desired, we put them into the content.
1292 :     my $newLevel = scalar(@stackNames);
1293 :     my @newClassContent = ();
1294 :     if ($optionThing->{radio}) {
1295 :     my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1296 :     push @newClassContent, { value => "classification=$newClassString%" };
1297 :     }
1298 :     # The new classification node is appended to its parent's content
1299 :     # and then pushed onto the stack. First, we need the node name.
1300 :     my $nodeName = $classList[$newLevel];
1301 :     # Add the classification to its parent. This makes it part of the
1302 :     # tree we'll be returning to the user.
1303 :     push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1304 :     # Push the classification onto the stack.
1305 :     push @stackContents, \@newClassContent;
1306 :     push @stackNames, $nodeName;
1307 :     Trace("\"$nodeName\" pushed onto stack.") if T(4);
1308 :     }
1309 :     # Now the stack contains all our parent branches. We add the subsystem to
1310 :     # the branch at the top of the stack, but only if it's NOT the dummy node.
1311 :     if (defined $id) {
1312 :     # Compute the node name from the ID.
1313 :     my $nodeName = $id;
1314 :     $nodeName =~ s/_/ /g;
1315 :     # Create the node's leaf hash. This depends on the value of the radio
1316 :     # and link options.
1317 :     my $nodeContent = {};
1318 :     if ($optionThing->{links}) {
1319 :     # Compute the link value.
1320 :     my $linkable = uri_escape($id);
1321 : parrello 1.28 $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1322 : parrello 1.16 }
1323 :     if ($optionThing->{radio}) {
1324 :     # Compute the radio value.
1325 :     $nodeContent->{value} = "id=$id";
1326 :     }
1327 :     # Push the node into its parent branch.
1328 :     Trace("\"$nodeName\" added to node list.") if T(4);
1329 :     push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1330 :     }
1331 :     }
1332 :     # Return the result.
1333 :     return \@retVal;
1334 :     }
1335 :    
1336 :    
1337 : parrello 1.1 =head3 NmpdrGenomeMenu
1338 :    
1339 : parrello 1.3 C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1340 : parrello 1.1
1341 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1342 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
1343 :     easier to select all genomes from a particular category.
1344 :    
1345 :     =over 4
1346 :    
1347 :     =item menuName
1348 :    
1349 :     Name to give to the menu.
1350 :    
1351 : parrello 1.3 =item multiple
1352 : parrello 1.1
1353 : parrello 1.3 TRUE if the user is allowed to select multiple genomes, else FALSE.
1354 : parrello 1.1
1355 :     =item selected
1356 :    
1357 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
1358 :     is not intended to allow multiple selections, the list should be a singleton. If the
1359 :     list is empty, nothing will be pre-selected.
1360 :    
1361 : parrello 1.3 =item rows (optional)
1362 :    
1363 :     Number of rows to display. If omitted, the default is 1 for a single-select list
1364 :     and 10 for a multi-select list.
1365 :    
1366 : parrello 1.8 =item crossMenu (optional)
1367 :    
1368 :     If specified, is presumed to be the name of another genome menu whose contents
1369 :     are to be mutually exclusive with the contents of this menu. As a result, instead
1370 :     of the standard onChange event, the onChange event will deselect any entries in
1371 :     the other menu.
1372 :    
1373 : parrello 1.1 =item RETURN
1374 :    
1375 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
1376 :    
1377 :     =back
1378 :    
1379 :     =cut
1380 :    
1381 :     sub NmpdrGenomeMenu {
1382 :     # Get the parameters.
1383 : parrello 1.8 my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1384 : parrello 1.1 # Get the Sprout and CGI objects.
1385 :     my $sprout = $self->DB();
1386 :     my $cgi = $self->Q();
1387 : parrello 1.3 # Compute the row count.
1388 :     if (! defined $rows) {
1389 :     $rows = ($multiple ? 10 : 1);
1390 :     }
1391 :     # Create the multiple tag.
1392 :     my $multipleTag = ($multiple ? " multiple" : "");
1393 : parrello 1.1 # Get the form name.
1394 :     my $formName = $self->FormName();
1395 : parrello 1.3 # Check to see if we already have a genome list in memory.
1396 : parrello 1.32 my $groupHash;
1397 :     my @groups;
1398 :     my $nmpdrGroupCount;
1399 : parrello 1.3 my $genomes = $self->{genomeList};
1400 :     if (defined $genomes) {
1401 :     # We have a list ready to use.
1402 :     $groupHash = $genomes;
1403 : parrello 1.32 @groups = @{$self->{groupList}};
1404 :     $nmpdrGroupCount = $self->{groupCount};
1405 : parrello 1.3 } else {
1406 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
1407 :     # by name (genus,species,strain), but putting primary-group in front enables us to
1408 :     # take advantage of an existing index.
1409 :     my @genomeList = $sprout->GetAll(['Genome'],
1410 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1411 :     [], ['Genome(primary-group)', 'Genome(id)',
1412 :     'Genome(genus)', 'Genome(species)',
1413 : parrello 1.32 'Genome(unique-characterization)',
1414 :     'Genome(taxonomy)']);
1415 : parrello 1.3 # Create a hash to organize the genomes by group. Each group will contain a list of
1416 :     # 2-tuples, the first element being the genome ID and the second being the genome
1417 :     # name.
1418 :     my %gHash = ();
1419 :     for my $genome (@genomeList) {
1420 :     # Get the genome data.
1421 : parrello 1.32 my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1422 : parrello 1.10 # Compute and cache its name and display group.
1423 : parrello 1.32 my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1424 :     $strain, $taxonomy);
1425 : parrello 1.10 # Push the genome into the group's list. Note that we use the real group
1426 :     # name here, not the display group name.
1427 : parrello 1.32 push @{$gHash{$group}}, [$genomeID, $name, $domain];
1428 :     }
1429 :     # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1430 :     # the supporting genomes by domain. First, we sort the NMPDR groups.
1431 :     @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1432 :     # Remember the number of NMPDR groups.
1433 :     $nmpdrGroupCount = scalar @groups;
1434 :     # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1435 :     # of the domains found.
1436 :     my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1437 :     my @domains = ();
1438 :     for my $genomeData (@otherGenomes) {
1439 :     my ($genomeID, $name, $domain) = @{$genomeData};
1440 :     if (exists $gHash{$domain}) {
1441 :     push @{$gHash{$domain}}, $genomeData;
1442 :     } else {
1443 :     $gHash{$domain} = [$genomeData];
1444 :     push @domains, $domain;
1445 :     }
1446 : parrello 1.1 }
1447 : parrello 1.32 # Add the domain groups at the end of the main group list. The main group list will now
1448 :     # contain all the categories we need to display the genomes.
1449 :     push @groups, sort @domains;
1450 :     # Delete the supporting group.
1451 :     delete $gHash{$FIG_Config::otherGroup};
1452 : parrello 1.3 # Save the genome list for future use.
1453 :     $self->{genomeList} = \%gHash;
1454 : parrello 1.32 $self->{groupList} = \@groups;
1455 :     $self->{groupCount} = $nmpdrGroupCount;
1456 : parrello 1.3 $groupHash = \%gHash;
1457 : parrello 1.1 }
1458 : parrello 1.3 # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1459 :     # with the possibility of undefined values in the incoming list.
1460 :     my %selectedHash = ();
1461 :     if (defined $selected) {
1462 :     %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1463 :     }
1464 : parrello 1.13 # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1465 :     # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1466 :     # and use that to make the selections.
1467 :     my $nmpdrCount = 0;
1468 : parrello 1.1 # Create the type counters.
1469 :     my $groupCount = 1;
1470 :     # Compute the ID for the status display.
1471 :     my $divID = "${formName}_${menuName}_status";
1472 :     # Compute the JavaScript call for updating the status.
1473 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
1474 :     # If multiple selection is supported, create an onChange event.
1475 :     my $onChange = "";
1476 : parrello 1.8 if ($cross) {
1477 : parrello 1.13 # Here we have a paired menu. Selecting something in our menu unselects it in the
1478 :     # other and redisplays the status of both.
1479 : parrello 1.8 $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1480 :     } elsif ($multiple) {
1481 : parrello 1.13 # This is an unpaired menu, so all we do is redisplay our status.
1482 : parrello 1.1 $onChange = " onChange=\"$showSelect\"";
1483 :     }
1484 :     # Create the SELECT tag and stuff it into the output array.
1485 : parrello 1.13 my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
1486 : parrello 1.1 # Loop through the groups.
1487 :     for my $group (@groups) {
1488 :     # Create the option group tag.
1489 :     my $tag = "<OPTGROUP label=\"$group\">";
1490 :     push @lines, " $tag";
1491 :     # Get the genomes in the group.
1492 : parrello 1.3 for my $genome (@{$groupHash->{$group}}) {
1493 : parrello 1.13 # Count this organism if it's NMPDR.
1494 : parrello 1.32 if ($nmpdrGroupCount > 0) {
1495 : parrello 1.13 $nmpdrCount++;
1496 :     }
1497 : parrello 1.32 # Get the organism ID, name, and domain.
1498 :     my ($genomeID, $name, $domain) = @{$genome};
1499 : parrello 1.1 # See if it's selected.
1500 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
1501 :     # Generate the option tag.
1502 : parrello 1.32 my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1503 : parrello 1.1 push @lines, " $optionTag";
1504 :     }
1505 :     # Close the option group.
1506 :     push @lines, " </OPTGROUP>";
1507 : parrello 1.32 # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1508 :     # groups.
1509 :     $nmpdrGroupCount--;
1510 : parrello 1.1 }
1511 :     # Close the SELECT tag.
1512 :     push @lines, "</SELECT>";
1513 :     # Check for multiple selection.
1514 : parrello 1.3 if ($multiple) {
1515 : parrello 1.15 # Multi-select is on, so we need to add some selection helpers. First is
1516 :     # the search box. This allows the user to type text and have all genomes containing
1517 :     # the text selected automatically.
1518 :     my $searchThingName = "${menuName}_SearchThing";
1519 : parrello 1.18 push @lines, "<br />" .
1520 :     "<INPUT type=\"button\" name=\"Search\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1521 :     "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1522 : parrello 1.15 # Next are the buttons to set and clear selections.
1523 : parrello 1.1 push @lines, "<br />";
1524 : parrello 1.15 push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1525 : parrello 1.1 push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1526 : parrello 1.13 push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1527 :     push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1528 : parrello 1.1 # Add the status display, too.
1529 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1530 :     # Queue to update the status display when the form loads. We need to modify the show statement
1531 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1532 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1533 :     # in case we decide to twiddle the parameters.
1534 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1535 :     $self->QueueFormScript($showSelect);
1536 : parrello 1.3 # Finally, add this parameter to the list of genome parameters. This enables us to
1537 :     # easily find all the parameters used to select one or more genomes.
1538 :     push @{$self->{genomeParms}}, $menuName;
1539 : parrello 1.1 }
1540 :     # Assemble all the lines into a string.
1541 :     my $retVal = join("\n", @lines, "");
1542 :     # Return the result.
1543 :     return $retVal;
1544 :     }
1545 :    
1546 : parrello 1.3 =head3 PropertyMenu
1547 :    
1548 :     C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1549 :    
1550 :     Generate a property name dropdown menu.
1551 :    
1552 :     =over 4
1553 :    
1554 :     =item menuName
1555 :    
1556 :     Name to give to the menu.
1557 :    
1558 :     =item selected
1559 :    
1560 :     Value of the property name to pre-select.
1561 :    
1562 :     =item force (optional)
1563 :    
1564 :     If TRUE, then the user will be forced to choose a property name. If FALSE,
1565 :     then an additional menu choice will be provided to select nothing.
1566 :    
1567 :     =item RETURN
1568 :    
1569 :     Returns a dropdown menu box that allows the user to select a property name. An additional
1570 :     selection entry will be provided for selecting no property name
1571 :    
1572 :     =back
1573 :    
1574 :     =cut
1575 :    
1576 :     sub PropertyMenu {
1577 :     # Get the parameters.
1578 :     my ($self, $menuName, $selected, $force) = @_;
1579 :     # Get the CGI and Sprout objects.
1580 :     my $sprout = $self->DB();
1581 :     my $cgi = $self->Q();
1582 :     # Create the property name list.
1583 :     my @propNames = ();
1584 :     if (! $force) {
1585 :     push @propNames, "";
1586 :     }
1587 :     # Get all the property names, putting them after the null choice if one exists.
1588 :     push @propNames, $sprout->GetChoices('Property', 'property-name');
1589 :     # Create a menu from them.
1590 :     my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1591 :     -default => $selected);
1592 :     # Return the result.
1593 :     return $retVal;
1594 :     }
1595 :    
1596 : parrello 1.1 =head3 MakeTable
1597 :    
1598 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1599 :    
1600 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1601 :     other words, each must have the TR and TD tags included.
1602 :    
1603 :     The purpose of this method is to provide a uniform look for search form tables. It is
1604 :     almost impossible to control a table using styles, so rather than have a table style,
1605 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1606 :     be updated with an explicit width so the forms look pretty when they are all on one
1607 :     page.
1608 :    
1609 :     =over 4
1610 :    
1611 :     =item rows
1612 :    
1613 :     Reference to a list of table rows. Each table row must be in HTML form with all
1614 : parrello 1.29 the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1615 :     will be modified to set the width. Everything else will be left as is.
1616 : parrello 1.1
1617 :     =item RETURN
1618 :    
1619 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1620 :    
1621 :     =back
1622 :    
1623 :     =cut
1624 :    
1625 :     sub MakeTable {
1626 :     # Get the parameters.
1627 :     my ($self, $rows) = @_;
1628 :     # Get the CGI object.
1629 :     my $cgi = $self->Q();
1630 : parrello 1.29 # The first column of the first row must have its width fixed.
1631 :     # This flag will be set to FALSE when that happens.
1632 :     my $needWidth = 1;
1633 : parrello 1.1 # modifier becase we only want to change the first tag. Also, if a width
1634 :     # is already specified on the first column bad things will happen.
1635 :     for my $row (@{$rows}) {
1636 : parrello 1.29 # See if this row needs a width.
1637 :     if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1638 :     # Here we have a first cell and its tag parameters are in $2.
1639 :     my $elements = $2;
1640 :     if ($elements !~ /colspan/i) {
1641 :     Trace("No colspan tag found in element \'$elements\'.") if T(3);
1642 :     # Here there's no colspan, so we plug in the width. We
1643 :     # eschew the "g" modifier on the substitution because we
1644 :     # only want to update the first cell.
1645 :     $row =~ s/(<(td|th))/$1 width="150"/i;
1646 :     # Denote we don't need this any more.
1647 :     $needWidth = 0;
1648 :     }
1649 :     }
1650 : parrello 1.1 }
1651 :     # Create the table.
1652 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1653 :     width => 700, class => 'search'},
1654 :     @{$rows});
1655 :     # Return the result.
1656 :     return $retVal;
1657 :     }
1658 :    
1659 :     =head3 SubmitRow
1660 :    
1661 : parrello 1.18 C<< my $htmlText = $shelp->SubmitRow($caption); >>
1662 : parrello 1.1
1663 :     Returns the HTML text for the row containing the page size control
1664 :     and the submit button. All searches should have this row somewhere
1665 :     near the top of the form.
1666 :    
1667 : parrello 1.18 =over 4
1668 :    
1669 :     =item caption (optional)
1670 :    
1671 :     Caption to be put on the search button. The default is C<Go>.
1672 :    
1673 :     =item RETURN
1674 :    
1675 :     Returns a table row containing the controls for submitting the search
1676 :     and tuning the results.
1677 :    
1678 :     =back
1679 :    
1680 : parrello 1.1 =cut
1681 :    
1682 :     sub SubmitRow {
1683 :     # Get the parameters.
1684 : parrello 1.18 my ($self, $caption) = @_;
1685 : parrello 1.1 my $cgi = $self->Q();
1686 : parrello 1.18 # Compute the button caption.
1687 :     my $realCaption = (defined $caption ? $caption : 'Go');
1688 : parrello 1.3 # Get the current page size.
1689 :     my $pageSize = $cgi->param('PageSize');
1690 :     # Get the incoming external-link flag.
1691 :     my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1692 :     # Create the row.
1693 : parrello 1.1 my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1694 :     $cgi->td($cgi->popup_menu(-name => 'PageSize',
1695 : parrello 1.7 -values => [10, 25, 50, 100, 1000],
1696 : parrello 1.25 -default => $pageSize)),
1697 : parrello 1.1 $cgi->td($cgi->submit(-class => 'goButton',
1698 :     -name => 'Search',
1699 : parrello 1.18 -value => $realCaption)));
1700 : parrello 1.1 # Return the result.
1701 :     return $retVal;
1702 :     }
1703 : parrello 1.2
1704 :     =head3 FeatureFilterRows
1705 :    
1706 : parrello 1.27 C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1707 : parrello 1.2
1708 : parrello 1.11 This method creates table rows that can be used to filter features. The form
1709 :     values can be used to select features by genome using the B<FeatureQuery>
1710 :     object.
1711 : parrello 1.2
1712 : parrello 1.27 =over 4
1713 :    
1714 :     =item subset
1715 :    
1716 :     List of rows to display. The default (C<all>) is to display all rows.
1717 :     C<words> displays the word search box, C<subsys> displays the subsystem
1718 :     selector, and C<options> displays the options row.
1719 :    
1720 :     =item RETURN
1721 :    
1722 :     Returns the html text for table rows containing the desired feature filtering controls.
1723 :    
1724 :     =back
1725 :    
1726 : parrello 1.2 =cut
1727 :    
1728 :     sub FeatureFilterRows {
1729 :     # Get the parameters.
1730 : parrello 1.27 my ($self, @subset) = @_;
1731 :     if (@subset == 0 || $subset[0] eq 'all') {
1732 :     @subset = qw(words subsys options);
1733 :     }
1734 : parrello 1.2 # Return the result.
1735 : parrello 1.27 return FeatureQuery::FilterRows($self, @subset);
1736 : parrello 1.2 }
1737 :    
1738 : parrello 1.1 =head3 GBrowseFeatureURL
1739 :    
1740 :     C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
1741 :    
1742 :     Compute the URL required to pull up a Gbrowse page for the the specified feature.
1743 :     In order to do this, we need to pull out the ID of the feature's Genome, its
1744 :     contig ID, and some rough starting and stopping offsets.
1745 :    
1746 :     =over 4
1747 :    
1748 :     =item sprout
1749 :    
1750 :     Sprout object for accessing the database.
1751 :    
1752 :     =item feat
1753 :    
1754 :     ID of the feature whose Gbrowse URL is desired.
1755 :    
1756 :     =item RETURN
1757 :    
1758 :     Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome
1759 :     ID, contig ID, starting offset, and stopping offset.
1760 :    
1761 :     =back
1762 :    
1763 :     =cut
1764 :    
1765 :     sub GBrowseFeatureURL {
1766 :     # Get the parameters.
1767 :     my ($sprout, $feat) = @_;
1768 :     # Declare the return variable.
1769 :     my $retVal;
1770 :     # Compute the genome ID.
1771 :     my ($genomeID) = FIGRules::ParseFeatureID($feat);
1772 :     # Only proceed if the feature ID produces a valid genome.
1773 :     if ($genomeID) {
1774 :     # Get the feature location string.
1775 :     my $loc = $sprout->FeatureLocation($feat);
1776 :     # Compute the contig, start, and stop points.
1777 : parrello 1.6 my($contig, $start, $stop) = BasicLocation::Parse($loc);
1778 : parrello 1.5 Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1779 : parrello 1.1 # Now we need to do some goofiness to insure that the location is not too
1780 :     # big and that we get some surrounding stuff.
1781 :     my $mid = int(($start + $stop) / 2);
1782 :     my $chunk_len = 20000;
1783 :     my $max_feature = 40000;
1784 :     my $feat_len = abs($stop - $start);
1785 :     if ($feat_len > $chunk_len) {
1786 :     if ($feat_len > $max_feature) {
1787 :     $chunk_len = $max_feature;
1788 :     } else {
1789 :     $chunk_len = $feat_len + 100;
1790 :     }
1791 :     }
1792 :     my($show_start, $show_stop);
1793 :     if ($chunk_len == $max_feature) {
1794 :     $show_start = $start - 300;
1795 :     } else {
1796 :     $show_start = $mid - int($chunk_len / 2);
1797 :     }
1798 :     if ($show_start < 1) {
1799 :     $show_start = 1;
1800 :     }
1801 :     $show_stop = $show_start + $chunk_len - 1;
1802 :     my $clen = $sprout->ContigLength($contig);
1803 :     if ($show_stop > $clen) {
1804 :     $show_stop = $clen;
1805 :     }
1806 :     my $seg_id = $contig;
1807 :     $seg_id =~ s/:/--/g;
1808 : parrello 1.5 Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1809 : parrello 1.1 # Assemble all the pieces.
1810 : parrello 1.18 $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id;start=$show_start;stop=$show_stop";
1811 : parrello 1.1 }
1812 :     # Return the result.
1813 :     return $retVal;
1814 :     }
1815 :    
1816 : parrello 1.3 =head3 GetGenomes
1817 :    
1818 :     C<< my @genomeList = $shelp->GetGenomes($parmName); >>
1819 :    
1820 :     Return the list of genomes specified by the specified CGI query parameter.
1821 :     If the request method is POST, then the list of genome IDs is returned
1822 :     without preamble. If the request method is GET and the parameter is not
1823 :     specified, then it is treated as a request for all genomes. This makes it
1824 :     easier for web pages to link to a search that wants to specify all genomes.
1825 :    
1826 :     =over 4
1827 :    
1828 :     =item parmName
1829 :    
1830 :     Name of the parameter containing the list of genomes. This will be the
1831 :     first parameter passed to the L</NmpdrGenomeMenu> call that created the
1832 :     genome selection control on the form.
1833 :    
1834 :     =item RETURN
1835 :    
1836 :     Returns a list of the genomes to process.
1837 :    
1838 :     =back
1839 :    
1840 :     =cut
1841 :    
1842 :     sub GetGenomes {
1843 :     # Get the parameters.
1844 :     my ($self, $parmName) = @_;
1845 :     # Get the CGI query object.
1846 :     my $cgi = $self->Q();
1847 :     # Get the list of genome IDs in the request header.
1848 :     my @retVal = $cgi->param($parmName);
1849 :     Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1850 :     # Check for the special GET case.
1851 :     if ($cgi->request_method() eq "GET" && ! @retVal) {
1852 :     # Here the caller wants all the genomes.
1853 :     my $sprout = $self->DB();
1854 :     @retVal = $sprout->Genomes();
1855 :     }
1856 :     # Return the result.
1857 :     return @retVal;
1858 :     }
1859 :    
1860 :     =head3 GetHelpText
1861 :    
1862 :     C<< my $htmlText = $shelp->GetHelpText(); >>
1863 :    
1864 :     Get the help text for this search. The help text is stored in files on the template
1865 :     server. The help text for a specific search is taken from a file named
1866 :     C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1867 :     There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1868 :     feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1869 :     describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1870 :     describes the standard controls for a search, such as page size, URL display, and
1871 :     external alias display.
1872 :    
1873 :     =cut
1874 :    
1875 :     sub GetHelpText {
1876 :     # Get the parameters.
1877 :     my ($self) = @_;
1878 :     # Create a list to hold the pieces of the help.
1879 :     my @helps = ();
1880 :     # Get the template directory URL.
1881 :     my $urlBase = $FIG_Config::template_url;
1882 :     # Start with the specific help.
1883 :     my $class = $self->{class};
1884 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1885 :     # Add the genome control help if needed.
1886 :     if (scalar @{$self->{genomeParms}}) {
1887 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1888 :     }
1889 :     # Next the filter help.
1890 :     if ($self->{filtered}) {
1891 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1892 :     }
1893 :     # Finally, the standard help.
1894 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1895 :     # Assemble the pieces.
1896 :     my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1897 :     # Return the result.
1898 :     return $retVal;
1899 :     }
1900 :    
1901 :     =head3 ComputeSearchURL
1902 :    
1903 : parrello 1.19 C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1904 : parrello 1.3
1905 :     Compute the GET-style URL for the current search. In order for this to work, there
1906 :     must be a copy of the search form on the current page. This will always be the
1907 :     case if the search is coming from C<SearchSkeleton.cgi>.
1908 :    
1909 :     A little expense is involved in order to make the URL as smart as possible. The
1910 :     main complication is that if the user specified all genomes, we'll want to
1911 :     remove the parameter entirely from a get-style URL.
1912 :    
1913 : parrello 1.19 =over 4
1914 :    
1915 :     =item overrides
1916 :    
1917 :     Hash containing override values for the parameters, where the parameter name is
1918 :     the key and the parameter value is the override value. If the override value is
1919 :     C<undef>, the parameter will be deleted from the result.
1920 :    
1921 :     =item RETURN
1922 :    
1923 :     Returns a GET-style URL for invoking the search with the specified overrides.
1924 :    
1925 :     =back
1926 :    
1927 : parrello 1.3 =cut
1928 :    
1929 :     sub ComputeSearchURL {
1930 :     # Get the parameters.
1931 : parrello 1.19 my ($self, %overrides) = @_;
1932 : parrello 1.3 # Get the database and CGI query object.
1933 :     my $cgi = $self->Q();
1934 :     my $sprout = $self->DB();
1935 :     # Start with the full URL.
1936 :     my $retVal = $cgi->url(-full => 1);
1937 :     # Get all the query parameters in a hash.
1938 :     my %parms = $cgi->Vars();
1939 :     # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1940 :     # characters separating the individual values. We have to convert those to lists. In addition,
1941 :     # the multiple-selection genome parameters and the feature type parameter must be checked to
1942 :     # determine whether or not they can be removed from the URL. First, we get a list of the
1943 :     # genome parameters and a list of all genomes. Note that we only need the list if a
1944 :     # multiple-selection genome parameter has been found on the form.
1945 :     my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1946 :     my @genomeList;
1947 :     if (keys %genomeParms) {
1948 :     @genomeList = $sprout->Genomes();
1949 :     }
1950 :     # Create a list to hold the URL parameters we find.
1951 :     my @urlList = ();
1952 :     # Now loop through the parameters in the hash, putting them into the output URL.
1953 :     for my $parmKey (keys %parms) {
1954 :     # Get a list of the parameter values. If there's only one, we'll end up with
1955 :     # a singleton list, but that's okay.
1956 :     my @values = split (/\0/, $parms{$parmKey});
1957 :     # Check for special cases.
1958 : parrello 1.26 if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1959 : parrello 1.3 # These are bookkeeping parameters we don't need to start a search.
1960 :     @values = ();
1961 :     } elsif ($parmKey =~ /_SearchThing$/) {
1962 :     # Here the value coming in is from a genome control's search thing. It does
1963 :     # not affect the results of the search, so we clear it.
1964 :     @values = ();
1965 :     } elsif ($genomeParms{$parmKey}) {
1966 :     # Here we need to see if the user wants all the genomes. If he does,
1967 :     # we erase all the values just like with features.
1968 :     my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1969 :     if ($allFlag) {
1970 :     @values = ();
1971 :     }
1972 : parrello 1.19 } elsif (exists $overrides{$parmKey}) {
1973 :     # Here the value is being overridden, so we skip it for now.
1974 :     @values = ();
1975 : parrello 1.3 }
1976 :     # If we still have values, create the URL parameters.
1977 :     if (@values) {
1978 :     push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1979 :     }
1980 :     }
1981 : parrello 1.19 # Now do the overrides.
1982 :     for my $overKey (keys %overrides) {
1983 :     # Only use this override if it's not a delete marker.
1984 :     if (defined $overrides{$overKey}) {
1985 :     push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1986 :     }
1987 :     }
1988 : parrello 1.3 # Add the parameters to the URL.
1989 :     $retVal .= "?" . join(";", @urlList);
1990 :     # Return the result.
1991 :     return $retVal;
1992 :     }
1993 :    
1994 :     =head3 GetRunTimeValue
1995 :    
1996 :     C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1997 :    
1998 :     Compute a run-time column value.
1999 :    
2000 :     =over 4
2001 :    
2002 :     =item text
2003 :    
2004 :     The run-time column text. It consists of 2 percent signs, a column type, an equal
2005 :     sign, and the data for the current row.
2006 :    
2007 :     =item RETURN
2008 :    
2009 :     Returns the fully-formatted HTML text to go into the current column of the current row.
2010 :    
2011 :     =back
2012 :    
2013 :     =cut
2014 :    
2015 :     sub GetRunTimeValue {
2016 :     # Get the parameters.
2017 :     my ($self, $text) = @_;
2018 :     # Declare the return variable.
2019 :     my $retVal;
2020 :     # Parse the incoming text.
2021 :     if ($text =~ /^%%([^=]+)=(.*)$/) {
2022 :     $retVal = $self->RunTimeColumns($1, $2);
2023 :     } else {
2024 :     Confess("Invalid run-time column string \"$text\" encountered in session file.");
2025 :     }
2026 :     # Return the result.
2027 :     return $retVal;
2028 :     }
2029 :    
2030 : parrello 1.9 =head3 AdvancedClassList
2031 :    
2032 :     C<< my @classes = SearchHelper::AdvancedClassList(); >>
2033 :    
2034 :     Return a list of advanced class names. This list is used to generate the directory
2035 :     of available searches on the search page.
2036 :    
2037 : parrello 1.15 We use the %INC variable to accomplish this.
2038 : parrello 1.9
2039 :     =cut
2040 :    
2041 :     sub AdvancedClassList {
2042 : parrello 1.15 my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2043 : parrello 1.30 return sort @retVal;
2044 : parrello 1.9 }
2045 :    
2046 : parrello 1.16 =head3 SelectionTree
2047 :    
2048 :     C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
2049 :    
2050 :     Display a selection tree.
2051 :    
2052 :     This method creates the HTML for a tree selection control. The tree is implemented as a set of
2053 :     nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
2054 :     addition, some of the tree nodes can contain hyperlinks.
2055 :    
2056 :     The tree itself is passed in as a multi-level list containing node names followed by
2057 :     contents. Each content element is a reference to a similar list. The first element of
2058 :     each list may be a hash reference. If so, it should contain one or both of the following
2059 :     keys.
2060 :    
2061 :     =over 4
2062 :    
2063 :     =item link
2064 :    
2065 :     The navigation URL to be popped up if the user clicks on the node name.
2066 :    
2067 :     =item value
2068 :    
2069 :     The form value to be returned if the user selects the tree node.
2070 :    
2071 :     =back
2072 :    
2073 :     The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
2074 :     a C<value> key indicates the node name will have a radio button. If a node has no children,
2075 :     you may pass it a hash reference instead of a list reference.
2076 :    
2077 :     The following example shows the hash for a three-level tree with links on the second level and
2078 :     radio buttons on the third.
2079 :    
2080 :     [ Objects => [
2081 :     Entities => [
2082 :     {link => "../docs/WhatIsAnEntity.html"},
2083 :     Genome => {value => 'GenomeData'},
2084 :     Feature => {value => 'FeatureData'},
2085 :     Contig => {value => 'ContigData'},
2086 :     ],
2087 :     Relationships => [
2088 :     {link => "../docs/WhatIsARelationShip.html"},
2089 :     HasFeature => {value => 'GenomeToFeature'},
2090 :     IsOnContig => {value => 'FeatureToContig'},
2091 :     ]
2092 :     ]
2093 :     ]
2094 :    
2095 :     Note how each leaf of the tree has a hash reference for its value, while the branch nodes
2096 :     all have list references.
2097 :    
2098 :     This next example shows how to set up a taxonomy selection field. The value returned
2099 :     by the tree control will be the taxonomy string for the selected node ready for use
2100 :     in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
2101 :     reasons of space.
2102 :    
2103 :     [ All => [
2104 :     {value => "%"},
2105 :     Bacteria => [
2106 :     {value => "Bacteria%"},
2107 :     Proteobacteria => [
2108 :     {value => "Bacteria; Proteobacteria%"},
2109 :     Epsilonproteobacteria => [
2110 :     {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
2111 :     Campylobacterales => [
2112 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
2113 :     Campylobacteraceae =>
2114 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
2115 :     ...
2116 :     ]
2117 :     ...
2118 :     ]
2119 :     ...
2120 :     ]
2121 :     ...
2122 :     ]
2123 :     ...
2124 :     ]
2125 :     ]
2126 :    
2127 :    
2128 :     This method of tree storage allows the caller to control the order in which the tree nodes
2129 :     are displayed and to completely control value selection and use of hyperlinks. It is, however
2130 :     a bit complicated. Eventually, tree-building classes will be provided to simplify things.
2131 :    
2132 :     The parameters to this method are as follows.
2133 :    
2134 :     =over 4
2135 :    
2136 :     =item cgi
2137 :    
2138 :     CGI object used to generate the HTML.
2139 :    
2140 :     =item tree
2141 :    
2142 :     Reference to a hash describing a tree. See the description above.
2143 :    
2144 :     =item options
2145 :    
2146 :     Hash containing options for the tree display.
2147 :    
2148 :     =back
2149 :    
2150 :     The allowable options are as follows
2151 :    
2152 :     =over 4
2153 :    
2154 :     =item nodeImageClosed
2155 :    
2156 :     URL of the image to display next to the tree nodes when they are collapsed. Clicking
2157 :     on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
2158 :    
2159 :     =item nodeImageOpen
2160 :    
2161 :     URL of the image to display next to the tree nodes when they are expanded. Clicking
2162 :     on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
2163 :    
2164 :     =item style
2165 :    
2166 :     Style to use for the tree. The default is C<tree>. Because the tree style is implemented
2167 :     as nested lists, the key components of this style are the definitions for the C<ul> and
2168 :     C<li> tags. The default style file contains the following definitions.
2169 :    
2170 :     .tree ul {
2171 :     margin-left: 0; padding-left: 22px
2172 :     }
2173 :     .tree li {
2174 :     list-style-type: none;
2175 :     }
2176 :    
2177 :     The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
2178 :     parent by the width of the node image. This use of styles limits the things we can do in formatting
2179 :     the tree, but it has the advantage of vastly simplifying the tree creation.
2180 :    
2181 :     =item name
2182 :    
2183 :     Field name to give to the radio buttons in the tree. The default is C<selection>.
2184 :    
2185 :     =item target
2186 :    
2187 :     Frame target for links. The default is C<_self>.
2188 :    
2189 :     =item selected
2190 :    
2191 :     If specified, the value of the radio button to be pre-selected.
2192 :    
2193 :     =back
2194 :    
2195 :     =cut
2196 :    
2197 :     sub SelectionTree {
2198 :     # Get the parameters.
2199 :     my ($cgi, $tree, %options) = @_;
2200 :     # Get the options.
2201 :     my $optionThing = Tracer::GetOptions({ name => 'selection',
2202 :     nodeImageClosed => '../FIG/Html/plus.gif',
2203 :     nodeImageOpen => '../FIG/Html/minus.gif',
2204 :     style => 'tree',
2205 :     target => '_self',
2206 :     selected => undef},
2207 :     \%options);
2208 :     # Declare the return variable. We'll do the standard thing with creating a list
2209 :     # of HTML lines and rolling them together at the end.
2210 :     my @retVal = ();
2211 :     # Only proceed if the tree is present.
2212 :     if (defined($tree)) {
2213 :     # Validate the tree.
2214 :     if (ref $tree ne 'ARRAY') {
2215 :     Confess("Selection tree is not a list reference.");
2216 :     } elsif (scalar @{$tree} == 0) {
2217 :     # The tree is empty, so we do nothing.
2218 :     } elsif ($tree->[0] eq 'HASH') {
2219 :     Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2220 :     } else {
2221 :     # Here we have a real tree. Apply the tree style.
2222 :     push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2223 :     # Give us a DIV ID.
2224 :     my $divID = GetDivID($optionThing->{name});
2225 :     # Show the tree.
2226 :     push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2227 :     # Close the DIV block.
2228 :     push @retVal, $cgi->end_div();
2229 :     }
2230 :     }
2231 :     # Return the result.
2232 :     return join("\n", @retVal, "");
2233 :     }
2234 :    
2235 :     =head3 ShowBranch
2236 :    
2237 :     C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2238 :    
2239 :     This is a recursive method that displays a branch of the tree.
2240 :    
2241 :     =over 4
2242 :    
2243 :     =item cgi
2244 :    
2245 :     CGI object used to format HTML.
2246 :    
2247 :     =item label
2248 :    
2249 :     Label of this tree branch. It is only used in error messages.
2250 :    
2251 :     =item id
2252 :    
2253 :     ID to be given to this tree branch. The ID is used in the code that expands and collapses
2254 :     tree nodes.
2255 :    
2256 :     =item branch
2257 :    
2258 :     Reference to a list containing the content of the tree branch. The list contains an optional
2259 :     hash reference that is ignored and the list of children, each child represented by a name
2260 :     and then its contents. The contents could by a hash reference (indicating the attributes
2261 :     of a leaf node), or another tree branch.
2262 :    
2263 :     =item options
2264 :    
2265 :     Options from the original call to L</SelectionTree>.
2266 :    
2267 :     =item displayType
2268 :    
2269 :     C<block> if the contents of this list are to be displayed, C<none> if they are to be
2270 :     hidden.
2271 :    
2272 :     =item RETURN
2273 :    
2274 :     Returns one or more HTML lines that can be used to display the tree branch.
2275 :    
2276 :     =back
2277 :    
2278 :     =cut
2279 :    
2280 :     sub ShowBranch {
2281 :     # Get the parameters.
2282 :     my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2283 :     # Declare the return variable.
2284 :     my @retVal = ();
2285 :     # Start the branch.
2286 :     push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2287 :     # Check for the hash and choose the start location accordingly.
2288 :     my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2289 :     # Get the list length.
2290 :     my $i1 = scalar(@{$branch});
2291 :     # Verify we have an even number of elements.
2292 :     if (($i1 - $i0) % 2 != 0) {
2293 :     Trace("Branch elements are from $i0 to $i1.") if T(3);
2294 :     Confess("Odd number of elements in tree branch $label.");
2295 :     } else {
2296 :     # Loop through the elements.
2297 :     for (my $i = $i0; $i < $i1; $i += 2) {
2298 :     # Get this node's label and contents.
2299 :     my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2300 :     # Get an ID for this node's children (if any).
2301 :     my $myID = GetDivID($options->{name});
2302 :     # Now we need to find the list of children and the options hash.
2303 :     # This is a bit ugly because we allow the shortcut of a hash without an
2304 :     # enclosing list. First, we need some variables.
2305 :     my $attrHash = {};
2306 :     my @childHtml = ();
2307 :     my $hasChildren = 0;
2308 :     if (! ref $myContent) {
2309 :     Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2310 :     } elsif (ref $myContent eq 'HASH') {
2311 :     # Here the node is a leaf and its content contains the link/value hash.
2312 :     $attrHash = $myContent;
2313 :     } elsif (ref $myContent eq 'ARRAY') {
2314 :     # Here the node may be a branch. Its content is a list.
2315 :     my $len = scalar @{$myContent};
2316 :     if ($len >= 1) {
2317 :     # Here the first element of the list could by the link/value hash.
2318 :     if (ref $myContent->[0] eq 'HASH') {
2319 :     $attrHash = $myContent->[0];
2320 :     # If there's data in the list besides the hash, it's our child list.
2321 :     # We can pass the entire thing as the child list, because the hash
2322 :     # is ignored.
2323 :     if ($len > 1) {
2324 :     $hasChildren = 1;
2325 :     }
2326 :     } else {
2327 :     $hasChildren = 1;
2328 :     }
2329 :     # If we have children, create the child list with a recursive call.
2330 :     if ($hasChildren) {
2331 :     Trace("Processing children of $myLabel.") if T(4);
2332 :     push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2333 : parrello 1.27 Trace("Children of $myLabel finished.") if T(4);
2334 : parrello 1.16 }
2335 :     }
2336 :     }
2337 :     # Okay, it's time to pause and take stock. We have the label of the current node
2338 :     # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2339 :     # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2340 :     # Compute the image HTML. It's tricky, because we have to deal with the open and
2341 :     # closed images.
2342 :     my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2343 :     my $image = $images[$hasChildren];
2344 :     my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2345 :     if ($hasChildren) {
2346 :     # If there are children, we wrap the image in a toggle hyperlink.
2347 :     $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2348 :     $prefixHtml);
2349 :     }
2350 :     # Now the radio button, if any. Note we use "defined" in case the user wants the
2351 :     # value to be 0.
2352 :     if (defined $attrHash->{value}) {
2353 :     # Due to a glitchiness in the CGI stuff, we have to build the attribute
2354 :     # hash for the "input" method. If the item is pre-selected, we add
2355 :     # "checked => undef" to the hash. Otherwise, we can't have "checked"
2356 :     # at all.
2357 :     my $radioParms = { type => 'radio',
2358 :     name => $options->{name},
2359 :     value => $attrHash->{value},
2360 :     };
2361 :     if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2362 :     $radioParms->{checked} = undef;
2363 :     }
2364 :     $prefixHtml .= $cgi->input($radioParms);
2365 :     }
2366 :     # Next, we format the label.
2367 :     my $labelHtml = $myLabel;
2368 : parrello 1.27 Trace("Formatting tree node for \"$myLabel\".") if T(4);
2369 : parrello 1.16 # Apply a hyperlink if necessary.
2370 :     if (defined $attrHash->{link}) {
2371 :     $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2372 :     $labelHtml);
2373 :     }
2374 :     # Finally, roll up the child HTML. If there are no children, we'll get a null string
2375 :     # here.
2376 :     my $childHtml = join("\n", @childHtml);
2377 :     # Now we have all the pieces, so we can put them together.
2378 :     push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2379 :     }
2380 :     }
2381 :     # Close the tree branch.
2382 :     push @retVal, $cgi->end_ul();
2383 :     # Return the result.
2384 :     return @retVal;
2385 :     }
2386 :    
2387 :     =head3 GetDivID
2388 :    
2389 :     C<< my $idString = SearchHelper::GetDivID($name); >>
2390 :    
2391 :     Return a new HTML ID string.
2392 :    
2393 :     =over 4
2394 :    
2395 :     =item name
2396 :    
2397 :     Name to be prefixed to the ID string.
2398 :    
2399 :     =item RETURN
2400 :    
2401 :     Returns a hopefully-unique ID string.
2402 :    
2403 :     =back
2404 :    
2405 :     =cut
2406 :    
2407 :     sub GetDivID {
2408 :     # Get the parameters.
2409 :     my ($name) = @_;
2410 :     # Compute the ID.
2411 :     my $retVal = "elt_$name$divCount";
2412 :     # Increment the counter to make sure this ID is not re-used.
2413 :     $divCount++;
2414 :     # Return the result.
2415 :     return $retVal;
2416 :     }
2417 :    
2418 : parrello 1.31
2419 :     =head3 PrintLine
2420 :    
2421 :     C<< $shelp->PrintLine($message); >>
2422 :    
2423 :     Print a line of CGI output. This is used during the operation of the B<Find> method while
2424 :     searching, so the user sees progress in real-time.
2425 :    
2426 :     =over 4
2427 :    
2428 :     =item message
2429 :    
2430 :     HTML text to display.
2431 :    
2432 :     =back
2433 :    
2434 :     =cut
2435 :    
2436 :     sub PrintLine {
2437 :     # Get the parameters.
2438 :     my ($self, $message) = @_;
2439 :     # Send them to the output.
2440 :     print "$message\n";
2441 :     }
2442 :    
2443 : parrello 1.1 =head2 Feature Column Methods
2444 :    
2445 : parrello 1.19 The methods in this section manage feature column data. If you want to provide the
2446 : parrello 1.1 capability to include new types of data in feature columns, then all the changes
2447 :     are made to this section of the source file. Technically, this should be implemented
2448 :     using object-oriented methods, but this is simpler for non-programmers to maintain.
2449 :     To add a new column of feature data, you must first give it a name. For example,
2450 :     the name for the protein page link column is C<protlink>. If the column is to appear
2451 :     in the default list of feature columns, add it to the list returned by
2452 :     L</DefaultFeatureColumns>. Then add code to produce the column title to
2453 : parrello 1.28 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2454 :     feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2455 :     hash. Everything else will happen automatically.
2456 : parrello 1.1
2457 : parrello 1.28 There is a special column name syntax for extra columns (that is, nonstandard
2458 : parrello 1.1 feature columns). If the column name begins with C<X=>, then it is presumed to be
2459 :     an extra column. The column title is the text after the C<X=>, and its value is
2460 :     pulled from the extra column hash.
2461 :    
2462 : parrello 1.28 =cut
2463 :    
2464 :     # This hash is used to determine which columns should not be included in downloads.
2465 :     my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2466 :    
2467 : parrello 1.1 =head3 DefaultFeatureColumns
2468 :    
2469 : parrello 1.14 C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2470 : parrello 1.1
2471 : parrello 1.14 Return a list of the default feature column identifiers. These identifiers can
2472 :     be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2473 :     produce the column titles and row values.
2474 : parrello 1.1
2475 :     =cut
2476 :    
2477 :     sub DefaultFeatureColumns {
2478 :     # Get the parameters.
2479 :     my ($self) = @_;
2480 :     # Return the result.
2481 : parrello 1.14 return qw(orgName function gblink protlink);
2482 : parrello 1.1 }
2483 :    
2484 :     =head3 FeatureColumnTitle
2485 :    
2486 :     C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2487 :    
2488 :     Return the column heading title to be used for the specified feature column.
2489 :    
2490 :     =over 4
2491 :    
2492 :     =item name
2493 :    
2494 :     Name of the desired feature column.
2495 :    
2496 :     =item RETURN
2497 :    
2498 :     Returns the title to be used as the column header for the named feature column.
2499 :    
2500 :     =back
2501 :    
2502 :     =cut
2503 :    
2504 :     sub FeatureColumnTitle {
2505 :     # Get the parameters.
2506 :     my ($self, $colName) = @_;
2507 :     # Declare the return variable. We default to a blank column name.
2508 :     my $retVal = "&nbsp;";
2509 :     # Process the column name.
2510 :     if ($colName =~ /^X=(.+)$/) {
2511 :     # Here we have an extra column.
2512 :     $retVal = $1;
2513 : parrello 1.13 } elsif ($colName eq 'alias') {
2514 :     $retVal = "External Aliases";
2515 : parrello 1.1 } elsif ($colName eq 'fid') {
2516 :     $retVal = "FIG ID";
2517 :     } elsif ($colName eq 'function') {
2518 :     $retVal = "Functional Assignment";
2519 :     } elsif ($colName eq 'gblink') {
2520 :     $retVal = "GBrowse";
2521 : parrello 1.13 } elsif ($colName eq 'group') {
2522 :     $retVal = "NMDPR Group";
2523 :     } elsif ($colName =~ /^keyword:(.+)$/) {
2524 :     $retVal = ucfirst $1;
2525 :     } elsif ($colName eq 'orgName') {
2526 : parrello 1.21 $retVal = "Organism and Gene ID";
2527 : parrello 1.1 } elsif ($colName eq 'protlink') {
2528 :     $retVal = "NMPDR Protein Page";
2529 : parrello 1.28 } elsif ($colName eq 'viewerlink') {
2530 :     $retVal = "Annotation Page";
2531 : parrello 1.13 } elsif ($colName eq 'subsystem') {
2532 :     $retVal = "Subsystems";
2533 : parrello 1.31 } elsif ($colName eq 'pdb') {
2534 :     $retVal = "Best PDB Match";
2535 : parrello 1.1 }
2536 :     # Return the result.
2537 :     return $retVal;
2538 :     }
2539 :    
2540 : parrello 1.28 =head3 FeatureColumnDownload
2541 :    
2542 :     C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2543 :    
2544 :     Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2545 :    
2546 :     =over 4
2547 :    
2548 :     =item colName
2549 :    
2550 :     Name of the relevant feature column.
2551 :    
2552 :     =item RETURN
2553 :    
2554 :     Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2555 :     FALSE is returned if the column generates a button, image, or other purely-HTML value.
2556 :    
2557 :     =back
2558 :    
2559 :     =cut
2560 :    
2561 :     sub FeatureColumnDownload {
2562 :     # Get the parameters.
2563 :     my ($self, $colName) = @_;
2564 :     # Return the determination. We download the column if it's not in the skip-hash.
2565 :     # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2566 :     return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2567 :     }
2568 :    
2569 : parrello 1.13
2570 : parrello 1.1 =head3 FeatureColumnValue
2571 :    
2572 :     C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
2573 :    
2574 :     Return the value to be displayed in the specified feature column.
2575 :    
2576 :     =over 4
2577 :    
2578 :     =item colName
2579 :    
2580 :     Name of the column to be displayed.
2581 :    
2582 :     =item record
2583 :    
2584 : parrello 1.28 ERDBObject record for the feature being displayed in the current row.
2585 : parrello 1.1
2586 :     =item extraCols
2587 :    
2588 :     Reference to a hash of extra column names to values. If the incoming column name
2589 :     begins with C<X=>, its value will be taken from this hash.
2590 :    
2591 :     =item RETURN
2592 :    
2593 :     Returns the HTML to be displayed in the named column for the specified feature.
2594 :    
2595 :     =back
2596 :    
2597 :     =cut
2598 :    
2599 :     sub FeatureColumnValue {
2600 :     # Get the parameters.
2601 :     my ($self, $colName, $record, $extraCols) = @_;
2602 :     # Get the sprout and CGI objects.
2603 :     my $cgi = $self->Q();
2604 :     my $sprout = $self->DB();
2605 :     # Get the feature ID.
2606 :     my ($fid) = $record->Value('Feature(id)');
2607 :     # Declare the return variable. Denote that we default to a non-breaking space,
2608 :     # which will translate to an empty table cell (rather than a table cell with no
2609 :     # interior, which is what you get for a null string).
2610 :     my $retVal = "&nbsp;";
2611 :     # Process according to the column name.
2612 :     if ($colName =~ /^X=(.+)$/) {
2613 :     # Here we have an extra column. Only update if the value exists. Note that
2614 :     # a value of C<undef> is treated as a non-existent value, because the
2615 :     # caller may have put "colName => undef" in the "PutFeature" call in order
2616 :     # to insure we know the extra column exists.
2617 :     if (defined $extraCols->{$1}) {
2618 :     $retVal = $extraCols->{$1};
2619 :     }
2620 : parrello 1.13 } elsif ($colName eq 'alias') {
2621 :     # In this case, the user wants a list of external aliases for the feature.
2622 :     # These are very expensive, so we compute them when the row is displayed.
2623 : parrello 1.29 # To do the computation, we need to know the favored alias type and the
2624 :     # feature ID.
2625 :     my $favored = $cgi->param("FavoredAlias") || "fig";
2626 :     $retVal = "%%alias=$fid,$favored";
2627 : parrello 1.1 } elsif ($colName eq 'fid') {
2628 :     # Here we have the raw feature ID. We hyperlink it to the protein page.
2629 :     $retVal = HTML::set_prot_links($fid);
2630 :     } elsif ($colName eq 'function') {
2631 :     # The functional assignment is just a matter of getting some text.
2632 :     ($retVal) = $record->Value('Feature(assignment)');
2633 :     } elsif ($colName eq 'gblink') {
2634 :     # Here we want a link to the GBrowse page using the official GBrowse button.
2635 : parrello 1.23 $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2636 : parrello 1.18 fid => $fid);
2637 : parrello 1.13 } elsif ($colName eq 'group') {
2638 :     # Get the NMPDR group name.
2639 :     my (undef, $group) = $self->OrganismData($fid);
2640 :     # Dress it with a URL to the group's main page.
2641 :     my $nurl = $sprout->GroupPageName($group);
2642 :     $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2643 :     $group);
2644 :     } elsif ($colName =~ /^keyword:(.+)$/) {
2645 :     # Here we want keyword-related values. This is also expensive, so
2646 :     # we compute them when the row is displayed.
2647 : parrello 1.14 $retVal = "%%$colName=$fid";
2648 : parrello 1.13 } elsif ($colName eq 'orgName') {
2649 :     # Here we want the formatted organism name and feature number.
2650 :     $retVal = $self->FeatureName($fid);
2651 : parrello 1.1 } elsif ($colName eq 'protlink') {
2652 :     # Here we want a link to the protein page using the official NMPDR button.
2653 : parrello 1.23 $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2654 : parrello 1.18 prot => $fid, SPROUT => 1, new_framework => 0,
2655 :     user => '');
2656 : parrello 1.28 } elsif ($colName eq 'viewerlink') {
2657 :     # Here we want a link to the SEED viewer page using the official viewer button.
2658 :     $retVal = FakeButton('Annotation', "index.cgi", undef,
2659 :     action => 'ShowAnnotation', prot => $fid);
2660 :     } elsif ($colName eq 'subsystem') {
2661 : parrello 1.13 # Another run-time column: subsystem list.
2662 :     $retVal = "%%subsystem=$fid";
2663 : parrello 1.31 } elsif ($colName eq 'pdb') {
2664 :     $retVal = "%%pdb=$fid";
2665 : parrello 1.1 }
2666 :     # Return the result.
2667 :     return $retVal;
2668 :     }
2669 :    
2670 : parrello 1.3 =head3 RunTimeColumns
2671 :    
2672 :     C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2673 :    
2674 :     Return the HTML text for a run-time column. Run-time columns are evaluated when the
2675 :     list is displayed, rather than when it is generated.
2676 :    
2677 :     =over 4
2678 :    
2679 :     =item type
2680 :    
2681 :     Type of column.
2682 :    
2683 :     =item text
2684 :    
2685 :     Data relevant to this row of the column.
2686 :    
2687 :     =item RETURN
2688 :    
2689 :     Returns the fully-formatted HTML text to go in the specified column.
2690 :    
2691 :     =back
2692 :    
2693 :     =cut
2694 :    
2695 :     sub RunTimeColumns {
2696 :     # Get the parameters.
2697 :     my ($self, $type, $text) = @_;
2698 :     # Declare the return variable.
2699 :     my $retVal = "";
2700 :     # Get the Sprout and CGI objects.
2701 :     my $sprout = $self->DB();
2702 :     my $cgi = $self->Q();
2703 : parrello 1.14 Trace("Runtime column $type with text \"$text\" found.") if T(4);
2704 : parrello 1.3 # Separate the text into a type and data.
2705 : parrello 1.13 if ($type eq 'alias') {
2706 : parrello 1.3 # Here the caller wants external alias links for a feature. The text
2707 : parrello 1.29 # parameter for computing the alias is the feature ID followed by
2708 :     # the favored alias type.
2709 :     my ($fid, $favored) = split /\s*,\s*/, $text;
2710 :     # The complicated part is we have to hyperlink them and handle the
2711 :     # favorites. First, get the aliases.
2712 : parrello 1.3 Trace("Generating aliases for feature $fid.") if T(4);
2713 : parrello 1.29 my @aliases = sort $sprout->FeatureAliases($fid);
2714 : parrello 1.3 # Only proceed if we found some.
2715 :     if (@aliases) {
2716 : parrello 1.29 # Split the aliases into favored and unfavored.
2717 :     my @favored = ();
2718 :     my @unfavored = ();
2719 :     for my $alias (@aliases) {
2720 :     # Use substr instead of pattern match because $favored is specified by the user
2721 :     # and we don't want him to put funny meta-characters in there.
2722 :     if (substr($alias, 0, length($favored)) eq $favored) {
2723 :     push @favored, $alias;
2724 :     } else {
2725 :     push @unfavored, $alias;
2726 :     }
2727 :     }
2728 :     # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2729 :     my $aliasList = join(", ", @favored, @unfavored);
2730 : parrello 1.3 # Ask the HTML processor to hyperlink them.
2731 :     $retVal = HTML::set_prot_links($cgi, $aliasList);
2732 :     }
2733 : parrello 1.13 } elsif ($type eq 'subsystem') {
2734 :     # Here the caller wants the subsystems in which this feature participates.
2735 :     # The text is the feature ID. We will list the subsystem names with links
2736 :     # to the subsystem's summary page.
2737 :     my $fid = $text;
2738 :     # Get the subsystems.
2739 :     Trace("Generating subsystems for feature $fid.") if T(4);
2740 :     my %subs = $sprout->SubsystemsOf($fid);
2741 : parrello 1.19 # Extract the subsystem names.
2742 :     my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2743 : parrello 1.13 # String them into a list.
2744 : parrello 1.19 $retVal = join(", ", @names);
2745 : parrello 1.13 } elsif ($type =~ /^keyword:(.+)$/) {
2746 :     # Here the caller wants the value of the named keyword. The text is the
2747 :     # feature ID.
2748 :     my $keywordName = $1;
2749 :     my $fid = $text;
2750 :     # Get the attribute values.
2751 :     Trace("Getting $keywordName values for feature $fid.") if T(4);
2752 :     my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2753 :     "Feature($keywordName)");
2754 :     # String them into a list.
2755 :     $retVal = join(", ", @values);
2756 : parrello 1.31 } elsif ($type eq 'pdb') {
2757 :     # Here the caller wants the best PDB match to this feature. The text
2758 :     # is the feature ID. We will display the PDB with a link to the
2759 :     # PDB page along with the match score. If there are docking results we
2760 :     # will display a link to the docking result search.
2761 :     my $fid = $text;
2762 :     # Ask for the best PDB.
2763 :     my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2764 :     "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2765 :     [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2766 :     # Only proceed if there is a PDB.
2767 :     if ($bestPDB) {
2768 :     my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2769 :     # Convert the PDB ID to a hyperlink.
2770 :     my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2771 :     # Append the score.
2772 :     $retVal = "$pdbLink ($score)";
2773 :     # If there are docking results, append a docking results link.
2774 :     if ($dockingCount > 0) {
2775 :     my $dockString = "$dockingCount docking results";
2776 :     my $dockLink = $cgi->a({ href => $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2777 :     alt => "View computed docking results for $pdbID",
2778 :     title => "View computed docking results for $pdbID",
2779 :     target => "_blank"},
2780 :     $dockString);
2781 :     }
2782 :     }
2783 : parrello 1.33 } elsif ($type eq 'role') {
2784 :     # Here the caller wants a functional role assignment. The key is the feature ID.
2785 :     $retVal = $sprout->FunctionOf($text);
2786 :     } elsif ($type eq 'loc') {
2787 :     # This is a tough one. We need to find the nearest feature in the appropriate direction
2788 :     # on the contig, and then output its id, functional role, and link button.
2789 :     if ($text =~ /^(.)\/(.+)/) {
2790 :     my ($direction, $locString) = ($1, $2);
2791 :     Trace("Location request of type $direction for $locString.") if T(3);
2792 :     # Convert the location string into a location object.
2793 :     my $loc = BasicLocation->new($locString);
2794 :     # Get the contig ID.
2795 :     my $contigID = $loc->Contig;
2796 :     # Compute the contig length.
2797 :     my $contigLen = $sprout->ContigLength($contigID);
2798 :     # Widen by the area to search in both directions.
2799 :     $loc->Widen(5000);
2800 :     # Now, if we're doing a before (-) search, we set the end point to the area's mid point.
2801 :     # If we're doing an after (+) search, we set the begin point to the area's mid point.
2802 :     my $mid = ($loc->Left + $loc->Right) / 2;
2803 :     # Compute the search direction.
2804 :     my $searchDir = ($direction eq $loc->Dir ? 1 : -1);
2805 :     # Adjust the midpoint so that it is different in the before direction from what it would
2806 :     # be in the after direction.
2807 :     if ($mid != int($mid)) {
2808 :     # Here we need to round. The thing here is we want to round in a way that separates
2809 :     # the after-search choice from the before-search choice.
2810 :     if ($direction eq $loc->Dir) {
2811 :     $mid = ceil($mid);
2812 :     } else {
2813 :     $mid = floor($mid);
2814 :     }
2815 :     } elsif ($direction eq '+') {
2816 :     # Here the midpoint is on a nucleotide and we are doing the after search. We bump the
2817 :     # midpoint toward the end point.
2818 :     $mid += $loc->NumDirection;
2819 :     }
2820 :     # Now put the midpoint on the proper end of the region.
2821 :     if ($direction eq '+') {
2822 :     $loc->SetBegin($mid);
2823 :     } else {
2824 :     $loc->SetEnd($mid);
2825 :     }
2826 :     Trace("Search region is " . $loc->String . ".") if T(3);
2827 :     # Find all the genes in the region.
2828 :     my ($fidList, $beg, $end) = $sprout->GenesInRegion($loc->Contig, $loc->Left, $loc->Right);
2829 :     Trace(scalar(@{$fidList}) . " features found.") if T(3);
2830 :     # Look for the best match.
2831 :     my $distance = 5000;
2832 :     my $chosenFid = undef;
2833 :     for my $fid (@{$fidList}) {
2834 :     # Get the feature's location.
2835 :     my ($locString) = $sprout->FeatureLocation($fid);
2836 :     my $locObject = BasicLocation->new($locString);
2837 :     # Check its begin point to see if we should keep it.
2838 :     my $newDistance = ($mid - $locObject->Begin) * $searchDir;
2839 :     Trace("Distance from $mid to $locString is $newDistance.") if T(4);
2840 :     if ($newDistance > 0 && $newDistance < $distance) {
2841 :     $distance = $newDistance;
2842 :     $chosenFid = $fid;
2843 :     }
2844 :     }
2845 :     # Only proceed if we found something.
2846 :     if (defined $chosenFid) {
2847 :     my $role = $sprout->FunctionOf($chosenFid);
2848 :     my $linkButton = SearchHelper::FakeButton('NMPDR', "protein.cgi", undef,
2849 :     prot => $chosenFid, SPROUT => 1,
2850 :     new_framework => 0, user => '');
2851 :     $retVal = "$chosenFid&nbsp;$linkButton&nbsp;$role";
2852 :     }
2853 :     } else {
2854 :     Confess("Invalid location request %%loc=$text.");
2855 :     }
2856 : parrello 1.3 }
2857 :     # Return the result.
2858 :     return $retVal;
2859 :     }
2860 :    
2861 : parrello 1.10 =head3 SaveOrganismData
2862 :    
2863 : parrello 1.32 C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2864 : parrello 1.10
2865 :     Format the name of an organism and the display version of its group name. The incoming
2866 :     data should be the relevant fields from the B<Genome> record in the database. The
2867 :     data will also be stored in the genome cache for later use in posting search results.
2868 :    
2869 :     =over 4
2870 :    
2871 :     =item group
2872 :    
2873 :     Name of the genome's group as it appears in the database.
2874 :    
2875 :     =item genomeID
2876 :    
2877 :     ID of the relevant genome.
2878 :    
2879 :     =item genus
2880 :    
2881 :     Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2882 :     in the database. In this case, the organism name is derived from the genomeID and the group
2883 :     is automatically the supporting-genomes group.
2884 :    
2885 :     =item species
2886 :    
2887 :     Species of the genome's organism.
2888 :    
2889 :     =item strain
2890 :    
2891 :     Strain of the species represented by the genome.
2892 :    
2893 : parrello 1.32 =item taxonomy
2894 :    
2895 :     Taxonomy of the species represented by the genome.
2896 :    
2897 : parrello 1.10 =item RETURN
2898 :    
2899 : parrello 1.32 Returns a three-element list. The first element is the formatted genome name. The second
2900 :     element is the display name of the genome's group. The third is the genome's domain.
2901 : parrello 1.10
2902 :     =back
2903 :    
2904 :     =cut
2905 :    
2906 :     sub SaveOrganismData {
2907 :     # Get the parameters.
2908 : parrello 1.32 my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2909 : parrello 1.10 # Declare the return values.
2910 :     my ($name, $displayGroup);
2911 :     # If the organism does not exist, format an unknown name and a blank group.
2912 :     if (! defined($genus)) {
2913 :     $name = "Unknown Genome $genomeID";
2914 :     $displayGroup = "";
2915 :     } else {
2916 :     # It does exist, so format the organism name.
2917 :     $name = "$genus $species";
2918 :     if ($strain) {
2919 :     $name .= " $strain";
2920 :     }
2921 :     # Compute the display group. This is currently the same as the incoming group
2922 :     # name unless it's the supporting group, which is nulled out.
2923 :     $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2924 :     }
2925 : parrello 1.32 # Compute the domain from the taxonomy.
2926 :     my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2927 : parrello 1.10 # Cache the group and organism data.
2928 :     my $cache = $self->{orgs};
2929 : parrello 1.32 $cache->{$genomeID} = [$name, $displayGroup, $domain];
2930 : parrello 1.10 # Return the result.
2931 : parrello 1.32 return ($name, $displayGroup, $domain);
2932 : parrello 1.10 }
2933 :    
2934 : parrello 1.16 =head3 ValidateKeywords
2935 :    
2936 :     C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2937 :    
2938 :     Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2939 :     set.
2940 :    
2941 :     =over 4
2942 :    
2943 :     =item keywordString
2944 :    
2945 :     Keyword string specified as a parameter to the current search.
2946 :    
2947 :     =item required
2948 :    
2949 :     TRUE if there must be at least one keyword specified, else FALSE.
2950 :    
2951 :     =item RETURN
2952 :    
2953 :     Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2954 :     is acceptable if the I<$required> parameter is not specified.
2955 :    
2956 :     =back
2957 :    
2958 :     =cut
2959 :    
2960 :     sub ValidateKeywords {
2961 :     # Get the parameters.
2962 :     my ($self, $keywordString, $required) = @_;
2963 :     # Declare the return variable.
2964 :     my $retVal = 0;
2965 :     my @wordList = split /\s+/, $keywordString;
2966 :     # Right now our only real worry is a list of all minus words. The problem with it is that
2967 :     # it will return an incorrect result.
2968 :     my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2969 :     if (! @wordList) {
2970 :     if ($required) {
2971 :     $self->SetMessage("No search words specified.");
2972 : parrello 1.22 } else {
2973 :     $retVal = 1;
2974 : parrello 1.16 }
2975 :     } elsif (! @plusWords) {
2976 :     $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2977 :     } else {
2978 :     $retVal = 1;
2979 :     }
2980 :     # Return the result.
2981 :     return $retVal;
2982 :     }
2983 :    
2984 : parrello 1.23 =head3 FakeButton
2985 :    
2986 :     C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2987 :    
2988 :     Create a fake button that hyperlinks to the specified URL with the specified parameters.
2989 :     Unlike a real button, this one won't visibly click, but it will take the user to the
2990 :     correct place.
2991 :    
2992 :     The parameters of this method are deliberately identical to L</Formlet> so that we
2993 :     can switch easily from real buttons to fake ones in the code.
2994 :    
2995 :     =over 4
2996 :    
2997 :     =item caption
2998 :    
2999 :     Caption to be put on the button.
3000 :    
3001 :     =item url
3002 :    
3003 :     URL for the target page or script.
3004 :    
3005 :     =item target
3006 :    
3007 :     Frame or target in which the new page should appear. If C<undef> is specified,
3008 :     the default target will be used.
3009 :    
3010 :     =item parms
3011 :    
3012 :     Hash containing the parameter names as keys and the parameter values as values.
3013 :     These will be appended to the URL.
3014 :    
3015 :     =back
3016 :    
3017 :     =cut
3018 :    
3019 :     sub FakeButton {
3020 :     # Get the parameters.
3021 :     my ($caption, $url, $target, %parms) = @_;
3022 :     # Declare the return variable.
3023 :     my $retVal;
3024 :     # Compute the target URL.
3025 :     my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
3026 :     # Compute the target-frame HTML.
3027 :     my $targetHtml = ($target ? " target=\"$target\"" : "");
3028 :     # Assemble the result.
3029 : parrello 1.33 return "<a href=\"$targetUrl\" $targetHtml><span class=\"button2 button\">$caption</span></a>";
3030 : parrello 1.23 }
3031 :    
3032 : parrello 1.18 =head3 Formlet
3033 :    
3034 :     C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
3035 :    
3036 :     Create a mini-form that posts to the specified URL with the specified parameters. The
3037 :     parameters will be stored in hidden fields, and the form's only visible control will
3038 :     be a submit button with the specified caption.
3039 :    
3040 :     Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
3041 :     and tags that we don't want to deal with.
3042 :    
3043 :     =over 4
3044 :    
3045 :     =item caption
3046 :    
3047 :     Caption to be put on the form button.
3048 :    
3049 :     =item url
3050 :    
3051 :     URL to be put in the form's action parameter.
3052 :    
3053 :     =item target
3054 :    
3055 :     Frame or target in which the form results should appear. If C<undef> is specified,
3056 :     the default target will be used.
3057 :    
3058 :     =item parms
3059 :    
3060 :     Hash containing the parameter names as keys and the parameter values as values.
3061 :    
3062 :     =back
3063 :    
3064 :     =cut
3065 :    
3066 :     sub Formlet {
3067 :     # Get the parameters.
3068 :     my ($caption, $url, $target, %parms) = @_;
3069 :     # Compute the target HTML.
3070 :     my $targetHtml = ($target ? " target=\"$target\"" : "");
3071 :     # Start the form.
3072 :     my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
3073 :     # Add the parameters.
3074 :     for my $parm (keys %parms) {
3075 :     $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
3076 :     }
3077 :     # Put in the button.
3078 :     $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
3079 :     # Close the form.
3080 :     $retVal .= "</form>";
3081 :     # Return the result.
3082 :     return $retVal;
3083 :     }
3084 :    
3085 : parrello 1.30 =head3 TuningParameters
3086 :    
3087 :     C<< my $options = $shelp->TuningParameters(%parmHash); >>
3088 :    
3089 :     Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
3090 :     to their default values. The parameters and their values will be returned as a hash reference.
3091 :    
3092 :     =over 4
3093 :    
3094 :     =item parmHash
3095 :    
3096 :     Hash mapping parameter names to their default values.
3097 :    
3098 :     =item RETURN
3099 :    
3100 :     Returns a reference to a hash containing the parameter names mapped to their actual values.
3101 :    
3102 :     =back
3103 :    
3104 :     =cut
3105 :    
3106 :     sub TuningParameters {
3107 :     # Get the parameters.
3108 :     my ($self, %parmHash) = @_;
3109 :     # Declare the return variable.
3110 :     my $retVal = {};
3111 :     # Get the CGI Query Object.
3112 :     my $cgi = $self->Q();
3113 :     # Loop through the parameter names.
3114 :     for my $parm (keys %parmHash) {
3115 :     # Get the incoming value for this parameter.
3116 :     my $value = $cgi->param($parm);
3117 :     # Zero might be a valid value, so we do an is-defined check rather than an OR.
3118 :     if (defined($value)) {
3119 :     $retVal->{$parm} = $value;
3120 :     } else {
3121 :     $retVal->{$parm} = $parmHash{$parm};
3122 :     }
3123 :     }
3124 :     # Return the result.
3125 :     return $retVal;
3126 :     }
3127 :    
3128 : parrello 1.4 =head2 Virtual Methods
3129 :    
3130 :     =head3 Form
3131 :    
3132 :     C<< my $html = $shelp->Form(); >>
3133 :    
3134 :     Generate the HTML for a form to request a new search.
3135 :    
3136 :     =head3 Find
3137 :    
3138 :     C<< my $resultCount = $shelp->Find(); >>
3139 :    
3140 :     Conduct a search based on the current CGI query parameters. The search results will
3141 :     be written to the session cache file and the number of results will be
3142 :     returned. If the search parameters are invalid, a result count of C<undef> will be
3143 :     returned and a result message will be stored in this object describing the problem.
3144 :    
3145 :     =head3 Description
3146 :    
3147 :     C<< my $htmlText = $shelp->Description(); >>
3148 :    
3149 :     Return a description of this search. The description is used for the table of contents
3150 :     on the main search tools page. It may contain HTML, but it should be character-level,
3151 :     not block-level, since the description is going to appear in a list.
3152 :    
3153 :     =head3 SortKey
3154 :    
3155 : parrello 1.11 C<< my $key = $shelp->SortKey($fdata); >>
3156 : parrello 1.4
3157 : parrello 1.11 Return the sort key for the specified feature data. The default is to sort by feature name,
3158 : parrello 1.10 floating NMPDR organisms to the top. If a full-text search is used, then the default
3159 :     sort is by relevance followed by feature name. This sort may be overridden by the
3160 :     search class to provide fancier functionality. This method is called by
3161 :     B<PutFeature>, so it is only used for feature searches. A non-feature search
3162 :     would presumably have its own sort logic.
3163 : parrello 1.4
3164 :     =over 4
3165 :    
3166 :     =item record
3167 :    
3168 : parrello 1.11 The C<FeatureData> containing the current feature.
3169 : parrello 1.4
3170 :     =item RETURN
3171 :    
3172 :     Returns a key field that can be used to sort this row in among the results.
3173 :    
3174 :     =back
3175 :    
3176 :     =cut
3177 :    
3178 :     sub SortKey {
3179 :     # Get the parameters.
3180 : parrello 1.11 my ($self, $fdata) = @_;
3181 : parrello 1.4 # Get the feature ID from the record.
3182 : parrello 1.11 my $fid = $fdata->FID();
3183 : parrello 1.4 # Get the group from the feature ID.
3184 :     my $group = $self->FeatureGroup($fid);
3185 :     # Ask the feature query object to form the sort key.
3186 : parrello 1.11 my $retVal = $fdata->SortKey($self, $group);
3187 : parrello 1.4 # Return the result.
3188 :     return $retVal;
3189 :     }
3190 : parrello 1.9
3191 : parrello 1.31 =head3 SearchTitle
3192 :    
3193 :     C<< my $titleHtml = $shelp->SearchTitle(); >>
3194 :    
3195 :     Return the display title for this search. The display title appears above the search results.
3196 :     If no result is returned, no title will be displayed. The result should be an html string
3197 :     that can be legally put inside a block tag such as C<h3> or C<p>.
3198 :    
3199 :     =cut
3200 :    
3201 :     sub SearchTitle {
3202 :     # Get the parameters.
3203 :     my ($self) = @_;
3204 :     # Declare the return variable.
3205 :     my $retVal;
3206 :     # Return it.
3207 :     return $retVal;
3208 :     }
3209 :    
3210 :     =head3 DownloadFormatAvailable
3211 : parrello 1.28
3212 : parrello 1.31 C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3213 : parrello 1.28
3214 : parrello 1.31 This method returns TRUE if a specified download format is legal for this type of search
3215 :     and FALSE otherwise. For any feature-based search, there is no need to override this
3216 :     method.
3217 : parrello 1.28
3218 :     =over 4
3219 :    
3220 : parrello 1.31 =item format
3221 :    
3222 :     Download format type code.
3223 :    
3224 :     =item RETURN
3225 : parrello 1.28
3226 : parrello 1.31 Returns TRUE if the download format is legal for this search and FALSE otherwise.
3227 : parrello 1.28
3228 :     =back
3229 :    
3230 :     =cut
3231 :    
3232 : parrello 1.31 sub DownloadFormatAvailable {
3233 : parrello 1.28 # Get the parameters.
3234 : parrello 1.31 my ($self, $format) = @_;
3235 :     # Declare the return variable.
3236 :     my $retVal = 1;
3237 :     # Return the result.
3238 :     return $retVal;
3239 : parrello 1.28 }
3240 :    
3241 : parrello 1.32 =head3 ColumnTitle
3242 :    
3243 :     C<< my $title = $shelp->ColumnTitle($colName); >>
3244 :    
3245 :     Return the column heading title to be used for the specified column name. The
3246 :     default implementation is to simply call L</FeatureColumnTitle>.
3247 :    
3248 :     =over 4
3249 :    
3250 :     =item colName
3251 :    
3252 :     Name of the desired column.
3253 :    
3254 :     =item RETURN
3255 :    
3256 :     Returns the title to be used as the column header for the named column.
3257 :    
3258 :     =back
3259 :    
3260 :     =cut
3261 :    
3262 :     sub ColumnTitle {
3263 :     my ($self, $colName) = @_;
3264 :     return $self->FeatureColumnTitle($colName);
3265 :     }
3266 :    
3267 :    
3268 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3