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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (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.1
21 :     =head1 Search Helper Base Class
22 :    
23 :     =head2 Introduction
24 :    
25 :     The search helper is a base class for all search objects. It has methods for performing
26 :     all the common tasks required to build and manage a search cache. The subclass must
27 :     provide methods for generating and processing search forms. The base class has the
28 :     following object fields.
29 :    
30 :     =over 4
31 :    
32 :     =item cols
33 :    
34 :     Reference to a list of column header descriptions. If undefined, then the session cache
35 :     file has been opened but nothing has been written to it.
36 :    
37 :     =item fileHandle
38 :    
39 :     File handle for the session cache file.
40 :    
41 :     =item query
42 :    
43 :     CGI query object, which includes the search parameters and the various
44 :     session status variables kept between requests from the user.
45 :    
46 :     =item type
47 :    
48 :     Session type: C<old> if there is an existing cache file from which we are
49 :     displaying search results, or C<new> if the cache file needs to be built.
50 :    
51 :     =item class
52 :    
53 :     Name of the search helper class as it would appear in the CGI query object
54 :     (i.e. without the C<SH> prefix.
55 :    
56 :     =item sprout
57 :    
58 :     Sprout object for accessing the database.
59 :    
60 :     =item message
61 :    
62 :     Message to display if an error has been detected.
63 :    
64 :     =item orgs
65 :    
66 :     Reference to a hash mapping genome IDs to organism names.
67 :    
68 :     =item name
69 :    
70 :     Name to use for this object's form.
71 :    
72 :     =item scriptQueue
73 :    
74 :     List of JavaScript statements to be executed after the form is closed.
75 :    
76 :     =back
77 :    
78 : parrello 1.2 =head2 Adding a new Search Tool
79 :    
80 :     To add a new search tool to the system, you must
81 :    
82 :     =over 4
83 :    
84 :     =item 1
85 :    
86 :     Choose a class name for your search tool.
87 :    
88 :     =item 2
89 :    
90 :     Create a new subclass of this object and implement each of the virtual methods. The
91 :     name of the subclass must be C<SH>I<className>.
92 :    
93 :     =item 3
94 :    
95 :     Create an include file among the web server pages that describes how to use
96 :     the search tool. The include file must be in the B<includes> directory, and
97 :     its name must be C<SearchHelp_>I<className>C<.inc>.
98 :    
99 :     =item 4
100 :    
101 :     In the C<SearchSkeleton.cgi> script, add a C<use> statement for your search tool
102 :     and then put the class name in the C<@advancedClasses> list.
103 :    
104 :     =back
105 :    
106 :     =head3 Building a Search Form
107 :    
108 :     All search forms are three-column tables. In general, you want one form
109 :     variable per table row. The first column should contain the label and
110 :     the second should contain the form control for specifying the variable
111 :     value. If the control is wide, you should use C<colspan="2"> to give it
112 :     extra room. B<Do not> specify a width in any of your table cells, as
113 :     width management is handled by this class.
114 :    
115 :     The general code for creating the form should be
116 :    
117 :     sub Form {
118 :     my ($self) = @_;
119 :     # Get the CGI object.
120 :     my $cgi = @self->Q();
121 :     # Start the form.
122 :     my $retVal = $self->FormStart("form title");
123 :     # Assemble the table rows.
124 :     my @rows = ();
125 :     ... push table row Html into @rows ...
126 :     push @rows, $self->SubmitRow();
127 :     ... push more Html into @rows ...
128 :     # Build the table from the rows.
129 :     $retVal .= $self->MakeTable(\@rows);
130 :     # Close the form.
131 :     $retVal .= $self->FormEnd();
132 :     # Return the form Html.
133 :     return $retVal;
134 :     }
135 :    
136 :     Several helper methods are provided for particular purposes.
137 :    
138 :     =over 4
139 :    
140 :     =item 1
141 :    
142 :     L</NmpdrGenomeMenu> generates a control for selecting one or more genomes.
143 :    
144 :     =item 2
145 :    
146 :     L</FeatureFilterRow> formats several rows of controls for filtering features.
147 :     When you start building the code for the L</Find> method, you can use a
148 :     B<FeatureQuery> object to automatically filter each genome's features using
149 :     the values from the filter controls.
150 :    
151 :     =item 3
152 :    
153 :     L</QueueFormScript> allows you to queue JavaScript statements for execution
154 :     after the form is fully generated. If you are using very complicated
155 :     form controls, the L</QueueFormScript> method allows you to perform
156 :     JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
157 :     facility to display a list of the pre-selected genomes.
158 :    
159 :     =back
160 :    
161 :     Finally, when generating the code for your controls, be sure to use any incoming
162 :     query parameters as default values so that the search request is persistent.
163 :    
164 :     =head3 Finding Search Results
165 :    
166 :     The L</Find> method is used to create the search results. For a search that
167 :     wants to return features (which is most of them), the basic code structure
168 :     would work as follows. It is assumed that the L</FeatureFilterRows> method
169 :     has been used to create feature filtering parameters.
170 :    
171 :     sub Find {
172 :     my ($self) = @_;
173 :     # Get the CGI and Sprout objects.
174 :     my $cgi = $self->Q();
175 :     my $sprout = $self->DB();
176 :     # Declare the return variable. If it remains undefined, the caller will
177 :     # know that an error occurred.
178 :     my $retVal;
179 :     ... validate the parameters ...
180 :     if (... invalid parameters...) {
181 :     $self->SetMessage(...appropriate message...);
182 :     } elsif (FeatureQuery::Valid($self)) {
183 :     # Initialize the session file.
184 :     $self->OpenSession();
185 :     # Initialize the result counter.
186 :     $retVal = 0;
187 :     ... get a list of genomes ...
188 :     for my $genomeID (... each genome ...) {
189 :     my $fq = FeatureQuery->new($self, $genomeID);
190 :     while (my $feature = $fq->Fetch()) {
191 :     ... examine the feature ...
192 :     if (... we want to keep it ...) {
193 :     $self->PutFeature($fq);
194 :     $retVal++;
195 :     }
196 :     }
197 :     }
198 :     }
199 :     # Close the session file.
200 :     $self->CloseSession();
201 :     # Return the result count.
202 :     return $retVal;
203 :     }
204 :    
205 :     A Find method is of course much more complicated than generating a form, and there
206 :     are variations on the above them. For example, you could eschew feature filtering
207 :     entirely in favor of your own custom filtering, you could include extra columns
208 :     in the output, or you could search for something that's not a feature at all. The
209 :     above code is just a loose framework.
210 :    
211 :     If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
212 :     method of the feature query object.
213 :    
214 :     $fq->AddExtraColumns(score => $sc);
215 :    
216 :     The L</Find> method must return C<undef> if the search parameters are invalid. If this
217 :     is the case, then a message describing the problem should be passed to the framework
218 :     by calling L</SetMessage>. If the parameters are valid, then the method must return
219 :     the number of items found.
220 :    
221 :     =head2 Virtual Methods
222 :    
223 :     =head3 Form
224 :    
225 :     C<< my $html = $shelp->Form(); >>
226 :    
227 :     Generate the HTML for a form to request a new search.
228 :    
229 :     =head3 Find
230 :    
231 :     C<< my $resultCount = $shelp->Find(); >>
232 :    
233 :     Conduct a search based on the current CGI query parameters. The search results will
234 :     be written to the session cache file and the number of results will be
235 :     returned. If the search parameters are invalid, a result count of C<undef> will be
236 :     returned and a result message will be stored in this object describing the problem.
237 :    
238 :     =head3 Description
239 :    
240 :     C<< my $htmlText = $shelp->Description(); >>
241 :    
242 :     Return a description of this search. The description is used for the table of contents
243 :     on the main search tools page. It may contain HTML, but it should be character-level,
244 :     not block-level, since the description is going to appear in a list.
245 :    
246 : parrello 1.1 =cut
247 :    
248 :     # This counter is used to insure every form on the page has a unique name.
249 :     my $formCount = 0;
250 :    
251 :     =head2 Public Methods
252 :    
253 :     =head3 new
254 :    
255 :     C<< my $shelp = SearchHelper->new($query); >>
256 :    
257 :     Construct a new SearchHelper object.
258 :    
259 :     =over 4
260 :    
261 :     =item query
262 :    
263 :     The CGI query object for the current script.
264 :    
265 :     =back
266 :    
267 :     =cut
268 :    
269 :     sub new {
270 :     # Get the parameters.
271 :     my ($class, $query) = @_;
272 :     # Check for a session ID.
273 :     my $session_id = $query->param("SessionID");
274 :     my $type = "old";
275 :     if (! $session_id) {
276 :     # Here we're starting a new session. We create the session ID and
277 :     # store it in the query object.
278 :     $session_id = NewSessionID();
279 :     $type = "new";
280 :     $query->param(-name => 'SessionID', -value => $session_id);
281 :     }
282 :     # Compute the subclass name.
283 :     $class =~ /SH(.+)$/;
284 :     my $subClass = $1;
285 :     # Insure everybody knows we're in Sprout mode.
286 :     $query->param(-name => 'SPROUT', -value => 1);
287 :     # Generate the form name.
288 :     my $formName = "$class$formCount";
289 :     $formCount++;
290 :     # Create the shelp object. It contains the query object (with the session ID)
291 :     # as well as an indicator as to whether or not the session is new, plus the
292 : parrello 1.2 # class name and a placeholder for the Sprout object.
293 : parrello 1.1 my $retVal = {
294 :     query => $query,
295 :     type => $type,
296 :     class => $subClass,
297 : parrello 1.2 sprout => undef,
298 : parrello 1.1 orgs => {},
299 :     name => $formName,
300 :     scriptQueue => [],
301 :     };
302 :     # Bless and return it.
303 :     bless $retVal, $class;
304 :     return $retVal;
305 :     }
306 :    
307 :     =head3 Q
308 :    
309 :     C<< my $query = $shelp->Q(); >>
310 :    
311 :     Return the CGI query object.
312 :    
313 :     =cut
314 :    
315 :     sub Q {
316 :     # Get the parameters.
317 :     my ($self) = @_;
318 :     # Return the result.
319 :     return $self->{query};
320 :     }
321 :    
322 :     =head3 DB
323 :    
324 :     C<< my $sprout = $shelp->DB(); >>
325 :    
326 :     Return the Sprout database object.
327 :    
328 :     =cut
329 :    
330 :     sub DB {
331 :     # Get the parameters.
332 :     my ($self) = @_;
333 : parrello 1.2 # Insure we have a database.
334 :     my $retVal = $self->{sprout};
335 :     if (! defined $retVal) {
336 :     $retVal = SFXlate->new_sprout_only();
337 :     $self->{sprout} = $retVal;
338 :     }
339 : parrello 1.1 # Return the result.
340 : parrello 1.2 return $retVal;
341 : parrello 1.1 }
342 :    
343 :     =head3 IsNew
344 :    
345 :     C<< my $flag = $shelp->IsNew(); >>
346 :    
347 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
348 :     session already has search results ready to process.
349 :    
350 :     =cut
351 :    
352 :     sub IsNew {
353 :     # Get the parameters.
354 :     my ($self) = @_;
355 :     # Return the result.
356 :     return ($self->{type} eq 'new');
357 :     }
358 :    
359 :     =head3 ID
360 :    
361 :     C<< my $sessionID = $shelp->ID(); >>
362 :    
363 :     Return the current session ID.
364 :    
365 :     =cut
366 :    
367 :     sub ID {
368 :     # Get the parameters.
369 :     my ($self) = @_;
370 :     # Return the result.
371 :     return $self->Q()->param("SessionID");
372 :     }
373 :    
374 :     =head3 FormName
375 :    
376 :     C<< my $name = $shelp->FormName(); >>
377 :    
378 :     Return the name of the form this helper object will generate.
379 :    
380 :     =cut
381 :    
382 :     sub FormName {
383 :     # Get the parameters.
384 :     my ($self) = @_;
385 :     # Return the result.
386 :     return $self->{name};
387 :     }
388 :    
389 :     =head3 QueueFormScript
390 :    
391 :     C<< $shelp->QueueFormScript($statement); >>
392 :    
393 :     Add the specified statement to the queue of JavaScript statements that are to be
394 :     executed when the form has been fully defined. This is necessary because until
395 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
396 :     name. When generating the statement, you can refer to the variable C<thisForm>
397 :     in order to reference the form in progress. Thus,
398 :    
399 :     thisForm.simLimit.value = 1e-10;
400 :    
401 :     would set the value of the form element C<simLimit> in the current form to
402 :     C<1e-10>.
403 :    
404 :     =over 4
405 :    
406 :     =item statement
407 :    
408 :     JavaScript statement to be queued for execution after the form is built.
409 :     The trailing semi-colon is required. Theoretically, you could include
410 :     multiple statements separated by semi-colons, but one at a time works
411 :     just as well.
412 :    
413 :     =back
414 :    
415 :     =cut
416 :    
417 :     sub QueueFormScript {
418 :     # Get the parameters.
419 :     my ($self, $statement) = @_;
420 :     # Push the statement onto the script queue.
421 :     push @{$self->{scriptQueue}}, $statement;
422 :     }
423 :    
424 :     =head3 FormStart
425 :    
426 :     C<< my $html = $shelp->FormStart($title); >>
427 :    
428 :     Return the initial section of a form designed to perform another search of the
429 :     same type. The form header is included along with hidden fields to persist the
430 :     tracing, sprout status, and search class.
431 :    
432 :     A call to L</FormEnd> is required to close the form.
433 :    
434 :     =over 4
435 :    
436 :     =item title
437 :    
438 :     Title to be used for the form.
439 :    
440 :     =item RETURN
441 :    
442 :     Returns the initial HTML for the search form.
443 :    
444 :     =back
445 :    
446 :     =cut
447 :    
448 :     sub FormStart {
449 :     # Get the parameters.
450 :     my ($self, $title) = @_;
451 :     # Get the CGI object.
452 :     my $cgi = $self->Q();
453 :     # Start the form.
454 :     my $retVal = "<div class=\"search\">\n" .
455 :     $cgi->start_form(-method => 'POST',
456 :     -action => $cgi->url(-relative => 1),
457 :     -name => $self->FormName()) .
458 :     $cgi->hidden(-name => 'Class',
459 :     -value => $self->{class}) .
460 :     $cgi->hidden(-name => 'SPROUT',
461 :     -value => 1) .
462 :     $cgi->h3($title);
463 :     # If tracing is on, add it to the form.
464 :     if ($cgi->param('Trace')) {
465 :     $retVal .= $cgi->hidden(-name => 'Trace',
466 :     -value => $cgi->param('Trace')) .
467 :     $cgi->hidden(-name => 'TF',
468 :     -value => ($cgi->param('TF') ? 1 : 0));
469 :     }
470 :     # Put in an anchor tag in case there's a table of contents.
471 :     my $anchorName = $self->FormName();
472 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
473 :     # Return the result.
474 :     return $retVal;
475 :     }
476 :    
477 :     =head3 FormEnd
478 :    
479 :     C<< my $htmlText = $shelp->FormEnd(); >>
480 :    
481 :     Return the HTML text for closing a search form. This closes both the C<form> and
482 :     C<div> tags.
483 :    
484 :     =cut
485 :    
486 :     sub FormEnd {
487 :     # Get the parameters.
488 :     my ($self) = @_;
489 :     # Declare the return variable, closing the form and the DIV block.
490 :     my $retVal = "</form></div>\n";
491 :     # Now we flush out the statement queue.
492 :     my @statements = @{$self->{scriptQueue}};
493 :     if (@statements > 0) {
494 :     # Switch to JavaScript and set the "thisForm" variable.
495 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
496 :     " thisForm = document.$self->{name};\n";
497 :     # Unroll the statements.
498 :     while (@statements > 0) {
499 :     my $statement = shift @statements;
500 :     $retVal .= " $statement\n";
501 :     }
502 :     # Close the JavaScript.
503 :     $retVal .= "</SCRIPT>\n";
504 :     }
505 :     # Return the result.
506 :     return $retVal;
507 :     }
508 :    
509 :     =head3 SetMessage
510 :    
511 :     C<< $shelp->SetMessage($msg); >>
512 :    
513 :     Store the specified text as the result message. The result message is displayed
514 :     if an invalid parameter value is specified.
515 :    
516 :     =over 4
517 :    
518 :     =item msg
519 :    
520 :     Text of the result message to be displayed.
521 :    
522 :     =back
523 :    
524 :     =cut
525 :    
526 :     sub SetMessage {
527 :     # Get the parameters.
528 :     my ($self, $msg) = @_;
529 :     # Store the message.
530 :     $self->{message} = $msg;
531 :     }
532 :    
533 :     =head3 Message
534 :    
535 :     C<< my $text = $shelp->Message(); >>
536 :    
537 :     Return the result message. The result message is displayed if an invalid parameter
538 :     value is specified.
539 :    
540 :     =cut
541 :    
542 :     sub Message {
543 :     # Get the parameters.
544 :     my ($self) = @_;
545 :     # Return the result.
546 :     return $self->{message};
547 :     }
548 :    
549 :     =head3 OpenSession
550 :    
551 :     C<< $shelp->OpenSession(); >>
552 :    
553 :     Set up to open the session cache file for writing. Note we don't actually
554 :     open the file until after we know the column headers.
555 :    
556 :     =cut
557 :    
558 :     sub OpenSession {
559 :     # Get the parameters.
560 :     my ($self) = @_;
561 :     # Denote we have not yet written out the column headers.
562 :     $self->{cols} = undef;
563 :     }
564 :    
565 :     =head3 GetCacheFileName
566 :    
567 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
568 :    
569 :     Return the name to be used for this session's cache file.
570 :    
571 :     =cut
572 :    
573 :     sub GetCacheFileName {
574 :     # Get the parameters.
575 :     my ($self) = @_;
576 :     # Return the result.
577 :     return $self->GetTempFileName('cache');
578 :     }
579 :    
580 :     =head3 GetTempFileName
581 :    
582 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
583 :    
584 :     Return the name to be used for a temporary file of the specified type. The
585 :     name is computed from the session name with the type as a suffix.
586 :    
587 :     =over 4
588 :    
589 :     =item type
590 :    
591 :     Type of temporary file to be generated.
592 :    
593 :     =item RETURN
594 :    
595 :     Returns a file name generated from the session name and the specified type.
596 :    
597 :     =back
598 :    
599 :     =cut
600 :    
601 :     sub GetTempFileName {
602 :     # Get the parameters.
603 :     my ($self, $type) = @_;
604 :     # Compute the file name. Note it gets stuffed in the FIG temporary
605 :     # directory.
606 :     my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";
607 :     # Return the result.
608 :     return $retVal;
609 :     }
610 :    
611 :     =head3 PutFeature
612 :    
613 : parrello 1.2 C<< $shelp->PutFeature($fquery); >>
614 : parrello 1.1
615 :     Store a feature in the result cache. This is the workhorse method for most
616 :     searches, since the primary data item in the database is features.
617 :    
618 :     For each feature, there are certain columns that are standard: the feature name, the
619 :     GBrowse and protein page links, the functional assignment, and so forth. If additional
620 : parrello 1.2 columns are required by a particular search subclass, they should be stored in
621 :     the feature query object using the B<AddExtraColumns> method. For example, the following
622 :     code adds columns for essentiality and virulence.
623 : parrello 1.1
624 : parrello 1.2 $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
625 :     $shelp->PutFeature($fq);
626 : parrello 1.1
627 :     For correct results, all values should be specified for all extra columns in all calls to
628 :     B<PutFeature>. (In particular, the column header names are computed on the first
629 :     call.) If a column is to be blank for the current feature, its value can be given
630 :     as C<undef>.
631 :    
632 :     if (! $essentialFlag) {
633 :     $essentialFlag = undef;
634 :     }
635 : parrello 1.2 $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
636 :     $shelp->PutFeature($fq);
637 : parrello 1.1
638 :     =over 4
639 :    
640 : parrello 1.2 =item fquery
641 : parrello 1.1
642 : parrello 1.2 FeatureQuery object containing the current feature data.
643 : parrello 1.1
644 :     =back
645 :    
646 :     =cut
647 :    
648 :     sub PutFeature {
649 : parrello 1.2 # Get the parameters.
650 :     my ($self, $fq) = @_;
651 :     # Get the feature data.
652 :     my $record = $fq->Feature();
653 :     my $extraCols = $fq->ExtraCols();
654 : parrello 1.1 # Check for a first-call situation.
655 :     if (! defined $self->{cols}) {
656 :     # Here we need to set up the column information. Start with the defaults.
657 :     $self->{cols} = $self->DefaultFeatureColumns();
658 : parrello 1.2 # Append the extras, sorted by column name.
659 :     for my $col (sort keys %{$extraCols}) {
660 :     push @{$self->{cols}}, "X=$col";
661 : parrello 1.1 }
662 :     # Write out the column headers. This also prepares the cache file to receive
663 :     # output.
664 :     $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
665 :     }
666 :     # Get the feature ID.
667 :     my ($fid) = $record->Value('Feature(id)');
668 :     # Loop through the column headers, producing the desired data.
669 :     my @output = ();
670 :     for my $colName (@{$self->{cols}}) {
671 : parrello 1.2 push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
672 : parrello 1.1 }
673 :     # Compute the sort key. The sort key floats NMPDR organism features to the
674 :     # top of the return list.
675 :     my $group = $self->FeatureGroup($fid);
676 :     my $key = ($group ? "A$group" : "ZZ");
677 :     # Write the feature data.
678 :     $self->WriteColumnData($key, @output);
679 :     }
680 :    
681 :     =head3 WriteColumnHeaders
682 :    
683 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
684 :    
685 :     Write out the column headers for the current search session. The column headers
686 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
687 :     the handle saved.
688 :    
689 :     =over 4
690 :    
691 :     =item colNames
692 :    
693 :     A list of column names in the desired presentation order.
694 :    
695 :     =back
696 :    
697 :     =cut
698 :    
699 :     sub WriteColumnHeaders {
700 :     # Get the parameters.
701 :     my ($self, @colNames) = @_;
702 :     # Get the cache file name and open it for output.
703 :     my $fileName = $self->GetCacheFileName();
704 :     my $handle1 = Open(undef, ">$fileName");
705 :     # Write the column headers and close the file.
706 :     Tracer::PutLine($handle1, \@colNames);
707 :     close $handle1;
708 :     # Now open the sort pipe and save the file handle. Note how we append the
709 :     # sorted data to the column header row already in place. The output will
710 :     # contain a sort key followed by the real columns. The sort key is
711 :     # hacked off before going to the output file.
712 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
713 :     }
714 :    
715 :     =head3 WriteColumnData
716 :    
717 :     C<< $shelp->WriteColumnData($key, @colValues); >>
718 :    
719 :     Write a row of column values to the current search session. It is assumed that
720 :     the session file is already open for output.
721 :    
722 :     =over 4
723 :    
724 :     =item key
725 :    
726 :     Sort key.
727 :    
728 :     =item colValues
729 :    
730 :     List of column values to write to the search result cache file for this session.
731 :    
732 :     =back
733 :    
734 :     =cut
735 :    
736 :     sub WriteColumnData {
737 :     # Get the parameters.
738 :     my ($self, $key, @colValues) = @_;
739 :     # Write them to the cache file.
740 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
741 :     }
742 :    
743 :     =head3 CloseSession
744 :    
745 :     C<< $shelp->CloseSession(); >>
746 :    
747 :     Close the session file.
748 :    
749 :     =cut
750 :    
751 :     sub CloseSession {
752 :     # Get the parameters.
753 :     my ($self) = @_;
754 :     # Check for an open session file.
755 :     if (defined $self->{fileHandle}) {
756 :     # We found one, so close it.
757 :     close $self->{fileHandle};
758 :     }
759 :     }
760 :    
761 :     =head3 NewSessionID
762 :    
763 :     C<< my $id = SearchHelpers::NewSessionID(); >>
764 :    
765 :     Generate a new session ID for the current user.
766 :    
767 :     =cut
768 :    
769 :     sub NewSessionID {
770 :     # Declare the return variable.
771 :     my $retVal;
772 :     # Get a digest encoder.
773 :     my $md5 = Digest::MD5->new();
774 :     # If we have a randomization file, use it to seed the digester.
775 :     if (open(R, "/dev/urandom")) {
776 :     my $b;
777 :     read(R, $b, 1024);
778 :     $md5->add($b);
779 :     }
780 :     # Add the PID and the time stamp.
781 :     $md5->add($$, gettimeofday);
782 :     # Hash it up and clean the result so that it works as a file name.
783 :     $retVal = $md5->b64digest();
784 :     $retVal =~ s,/,\$,g;
785 :     $retVal =~ s,\+,@,g;
786 :     # Return it.
787 :     return $retVal;
788 :     }
789 :    
790 :     =head3 OrganismData
791 :    
792 :     C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
793 :    
794 :     Return the name and status of the organism corresponding to the specified genome ID.
795 :     For performance reasons, this information is cached in a special hash table, so we
796 :     only compute it once per run.
797 :    
798 :     =over 4
799 :    
800 :     =item genomeID
801 :    
802 :     ID of the genome whose name is desired.
803 :    
804 :     =item RETURN
805 :    
806 :     Returns a list of two items. The first item in the list is the organism name,
807 :     and the second is the name of the NMPDR group, or an empty string if the
808 :     organism is not in an NMPDR group.
809 :    
810 :     =back
811 :    
812 :     =cut
813 :    
814 :     sub OrganismData {
815 :     # Get the parameters.
816 :     my ($self, $genomeID) = @_;
817 :     # Declare the return variables.
818 :     my ($orgName, $group);
819 :     # Check the cache.
820 :     my $cache = $self->{orgs};
821 :     if (exists $cache->{$genomeID}) {
822 :     ($orgName, $group) = @{$cache->{$genomeID}};
823 :     } else {
824 :     # Here we have to use the database.
825 :     my $sprout = $self->DB();
826 :     my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,
827 :     ['Genome(genus)', 'Genome(species)',
828 :     'Genome(unique-characterization)',
829 :     'Genome(primary-group)']);
830 :     # Null out the supporting group.
831 :     $group = "" if ($group eq $FIG_Config::otherGroup);
832 :     # If the organism does not exist, format an unknown name.
833 :     if (! defined($genus)) {
834 :     $orgName = "Unknown Genome $genomeID";
835 :     } else {
836 :     # It does exist, so format the organism name.
837 :     $orgName = "$genus $species";
838 :     if ($strain) {
839 :     $orgName .= " $strain";
840 :     }
841 :     }
842 :     # Save this organism in the cache.
843 :     $cache->{$genomeID} = [$orgName, $group];
844 :     }
845 :     # Return the result.
846 :     return ($orgName, $group);
847 :     }
848 :    
849 :     =head3 Organism
850 :    
851 :     C<< my $orgName = $shelp->Organism($genomeID); >>
852 :    
853 :     Return the name of the relevant organism. The name is computed from the genus,
854 :     species, and unique characterization. A cache is used to improve performance.
855 :    
856 :     =over 4
857 :    
858 :     =item genomeID
859 :    
860 :     ID of the genome whose name is desired.
861 :    
862 :     =item RETURN
863 :    
864 :     Returns the display name of the specified organism.
865 :    
866 :     =back
867 :    
868 :     =cut
869 :    
870 :     sub Organism {
871 :     # Get the parameters.
872 :     my ($self, $genomeID) = @_;
873 :     # Get the organism data.
874 :     my ($retVal, $group) = $self->OrganismData($genomeID);
875 :     # Return the result.
876 :     return $retVal;
877 :     }
878 :    
879 :     =head3 FeatureGroup
880 :    
881 :     C<< my $groupName = $shelp->FeatureGroup($fid); >>
882 :    
883 :     Return the group name for the specified feature.
884 :    
885 :     =over 4
886 :    
887 :     =item fid
888 :    
889 :     ID of the relevant feature.
890 :    
891 :     =item RETURN
892 :    
893 :     Returns the name of the NMPDR group to which the feature belongs, or an empty
894 :     string if it is not part of an NMPDR group.
895 :    
896 :     =back
897 :    
898 :     =cut
899 :    
900 :     sub FeatureGroup {
901 :     # Get the parameters.
902 :     my ($self, $fid) = @_;
903 :     # Parse the feature ID to get the genome ID.
904 :     my ($genomeID) = FIGRules::ParseFeatureID($fid);
905 :     # Get the organism data.
906 :     my (undef, $retVal) = $self->OrganismData($genomeID);
907 :     # Return the result.
908 :     return $retVal;
909 :     }
910 :    
911 :     =head3 FeatureName
912 :    
913 :     C<< my $fidName = $shelp->FeatureName($fid); >>
914 :    
915 :     Return the display name of the specified feature.
916 :    
917 :     =over 4
918 :    
919 :     =item fid
920 :    
921 :     ID of the feature whose name is desired.
922 :    
923 :     =item RETURN
924 :    
925 :     A displayable feature name, consisting of the organism name plus some feature
926 :     type and location information.
927 :    
928 :     =back
929 :    
930 :     =cut
931 :    
932 :     sub FeatureName {
933 :     # Get the parameters.
934 :     my ($self, $fid) = @_;
935 :     # Declare the return variable
936 :     my $retVal;
937 :     # Parse the feature ID.
938 :     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);
939 :     if (! defined $genomeID) {
940 :     # Here the feature ID has an invalid format.
941 :     $retVal = "External: $fid";
942 :     } else {
943 :     # Here we can get its genome data.
944 :     $retVal = $self->Organism($genomeID);
945 :     # Append the type and number.
946 :     $retVal .= " [$type $num]";
947 :     }
948 :     # Return the result.
949 :     return $retVal;
950 :     }
951 :    
952 :     =head3 ComputeFASTA
953 :    
954 :     C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>
955 :    
956 :     Parse a sequence input and convert it into a FASTA string of the desired type. Note
957 :     that it is possible to convert a DNA sequence into a protein sequence, but the reverse
958 :     is not possible.
959 :    
960 :     =over 4
961 :    
962 :     =item incomingType
963 :    
964 :     C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.
965 :    
966 :     =item desiredType
967 :    
968 :     C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the
969 :     I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.
970 :    
971 :     =item sequence
972 :    
973 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
974 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
975 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
976 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
977 :     line will be provided.
978 :    
979 :     =item RETURN
980 :    
981 :     Returns a string in FASTA format representing the content of the desired sequence with
982 :     an appropriate label. If the input is invalid, a message will be stored and we will
983 :     return C<undef>. Note that the output will include a trailing new-line.
984 :    
985 :     =back
986 :    
987 :     =cut
988 :    
989 :     sub ComputeFASTA {
990 :     # Get the parameters.
991 :     my ($self, $incomingType, $desiredType, $sequence) = @_;
992 :     # Declare the return variable. If an error occurs, it will remain undefined.
993 :     my $retVal;
994 :     # Create variables to hold the FASTA label and data.
995 :     my ($fastaLabel, $fastaData);
996 :     # Check for a feature specification.
997 :     if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
998 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
999 :     # it.
1000 :     my $fid = $1;
1001 :     my $sprout = $self->DB();
1002 :     # Get the FIG ID. Note that we only use the first feature found. We are not
1003 :     # supposed to have redundant aliases, though we may have an ID that doesn't
1004 :     # exist.
1005 :     my ($figID) = $sprout->FeaturesByAlias($fid);
1006 :     if (! $figID) {
1007 :     $self->SetMessage("No feature found with the ID \"$fid\".");
1008 :     } else {
1009 :     # Set the FASTA label.
1010 :     my $fastaLabel = $fid;
1011 :     # Now proceed according to the sequence type.
1012 :     if ($desiredType =~ /prot/i) {
1013 :     # We want protein, so get the translation.
1014 :     $fastaData = $sprout->FeatureTranslation($figID);
1015 :     } else {
1016 :     # We want DNA, so get the DNA sequence. This is a two-step process.
1017 :     my @locList = $sprout->FeatureLocation($figID);
1018 :     $fastaData = $sprout->DNASeq(\@locList);
1019 :     }
1020 :     }
1021 :     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {
1022 :     # Here we're being asked to do an impossible conversion.
1023 :     $self->SetMessage("Cannot convert a protein sequence to DNA.");
1024 :     } else {
1025 :     # Here we are expecting a FASTA. We need to see if there's a label.
1026 :     if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {
1027 :     # Here we have a label, so we split it from the data.
1028 :     $fastaLabel = $1;
1029 :     $fastaData = $2;
1030 :     } else {
1031 :     # Here we have no label, so we create one and use the entire sequence
1032 :     # as data.
1033 :     $fastaLabel = "User-specified $incomingType sequence";
1034 :     $fastaData = $sequence;
1035 :     }
1036 :     # The next step is to clean the junk out of the sequence.
1037 :     $fastaData =~ s/\n//g;
1038 :     $fastaData =~ s/\s+//g;
1039 :     # Finally, if the user wants to convert to protein, we do it here. Note that
1040 :     # we've already prevented a conversion from protein to DNA.
1041 :     if ($incomingType ne $desiredType) {
1042 :     $fastaData = Sprout::Protein($fastaData);
1043 :     }
1044 :     }
1045 :     # At this point, either "$fastaLabel" and "$fastaData" have values or an error is
1046 :     # in progress.
1047 :     if (defined $fastaLabel) {
1048 :     # We need to format the sequence into 60-byte chunks. We use the infamous
1049 :     # grep-split trick. The split, because of the presence of the parentheses,
1050 :     # includes the matched delimiters in the output list. The grep strips out
1051 :     # the empty list items that appear between the so-called delimiters, since
1052 :     # the delimiters are what we want.
1053 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1054 :     my $retVal = join("\n", ">$fastaLabel", @chunks, "");
1055 :     }
1056 :     # Return the result.
1057 :     return $retVal;
1058 :     }
1059 :    
1060 :     =head3 NmpdrGenomeMenu
1061 :    
1062 :     C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>
1063 :    
1064 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1065 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
1066 :     easier to select all genomes from a particular category.
1067 :    
1068 :     =over 4
1069 :    
1070 :     =item menuName
1071 :    
1072 :     Name to give to the menu.
1073 :    
1074 :     =item options
1075 :    
1076 :     Reference to a hash containing the options to be applied to the C<SELECT> tag form the menu.
1077 :     Typical options would include C<multiple> to specify
1078 :     that multiple selections are allowed and C<size> to set the number of rows to display
1079 :     in the menu.
1080 :    
1081 :     =item selected
1082 :    
1083 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
1084 :     is not intended to allow multiple selections, the list should be a singleton. If the
1085 :     list is empty, nothing will be pre-selected.
1086 :    
1087 :     =item RETURN
1088 :    
1089 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
1090 :    
1091 :     =back
1092 :    
1093 :     =cut
1094 :    
1095 :     sub NmpdrGenomeMenu {
1096 :     # Get the parameters.
1097 :     my ($self, $menuName, $options, $selected) = @_;
1098 :     # Get the Sprout and CGI objects.
1099 :     my $sprout = $self->DB();
1100 :     my $cgi = $self->Q();
1101 :     # Get the form name.
1102 :     my $formName = $self->FormName();
1103 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
1104 :     # by name (genus,species,strain), but putting primary-group in front enables us to
1105 :     # take advantage of an existing index.
1106 :     my @genomeList = $sprout->GetAll(['Genome'],
1107 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1108 :     [], ['Genome(primary-group)', 'Genome(id)',
1109 :     'Genome(genus)', 'Genome(species)',
1110 :     'Genome(unique-characterization)']);
1111 :     # Create a hash to organize the genomes by group. Each group will contain a list of
1112 :     # 2-tuples, the first element being the genome ID and the second being the genome
1113 :     # name.
1114 :     my %groupHash = ();
1115 :     for my $genome (@genomeList) {
1116 :     # Get the genome data.
1117 :     my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1118 :     # Form the genome name.
1119 :     my $name = "$genus $species";
1120 :     if ($strain) {
1121 :     $name .= " $strain";
1122 :     }
1123 :     # Push the genome into the group's list.
1124 :     push @{$groupHash{$group}}, [$genomeID, $name];
1125 :     }
1126 :     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1127 :     # the supporting-genome group last.
1128 :     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;
1129 :     push @groups, $FIG_Config::otherGroup;
1130 :     # Next, create a hash that specifies the pre-selected entries.
1131 :     my %selectedHash = map { $_ => 1 } @{$selected};
1132 :     # Now it gets complicated. We need a way to mark all the NMPDR genomes.
1133 :     # Create the type counters.
1134 :     my $groupCount = 1;
1135 :     # Compute the ID for the status display.
1136 :     my $divID = "${formName}_${menuName}_status";
1137 :     # Compute the JavaScript call for updating the status.
1138 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
1139 :     # If multiple selection is supported, create an onChange event.
1140 :     my $onChange = "";
1141 :     if ($options->{multiple}) {
1142 :     $onChange = " onChange=\"$showSelect\"";
1143 :     }
1144 :     # Create the SELECT tag and stuff it into the output array.
1145 :     my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";
1146 :     my @lines = ($select);
1147 :     # Loop through the groups.
1148 :     for my $group (@groups) {
1149 :     # Create the option group tag.
1150 :     my $tag = "<OPTGROUP label=\"$group\">";
1151 :     push @lines, " $tag";
1152 :     # Compute the label for this group's options. This is seriously dirty stuff, as the
1153 :     # label option may have functionality in future browsers. If that happens, we'll need
1154 :     # to modify the genome text so that the "selectSome" method can tell which are NMPDR
1155 :     # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript
1156 :     # hierarchy.
1157 :     my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");
1158 :     # Get the genomes in the group.
1159 :     for my $genome (@{$groupHash{$group}}) {
1160 :     my ($genomeID, $name) = @{$genome};
1161 :     # See if it's selected.
1162 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
1163 :     # Generate the option tag.
1164 :     my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";
1165 :     push @lines, " $optionTag";
1166 :     }
1167 :     # Close the option group.
1168 :     push @lines, " </OPTGROUP>";
1169 :     }
1170 :     # Close the SELECT tag.
1171 :     push @lines, "</SELECT>";
1172 :     # Check for multiple selection.
1173 :     if ($options->{multiple}) {
1174 :     # Since multi-select is on, we can set up some buttons to set and clear selections.
1175 :     push @lines, "<br />";
1176 :     push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1177 :     push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1178 :     push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";
1179 :     push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";
1180 :     # Add the status display, too.
1181 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1182 :     # Queue to update the status display when the form loads. We need to modify the show statement
1183 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1184 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1185 :     # in case we decide to twiddle the parameters.
1186 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1187 :     $self->QueueFormScript($showSelect);
1188 :     }
1189 :     # Assemble all the lines into a string.
1190 :     my $retVal = join("\n", @lines, "");
1191 :     # Return the result.
1192 :     return $retVal;
1193 :     }
1194 :    
1195 :     =head3 MakeTable
1196 :    
1197 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1198 :    
1199 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1200 :     other words, each must have the TR and TD tags included.
1201 :    
1202 :     The purpose of this method is to provide a uniform look for search form tables. It is
1203 :     almost impossible to control a table using styles, so rather than have a table style,
1204 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1205 :     be updated with an explicit width so the forms look pretty when they are all on one
1206 :     page.
1207 :    
1208 :     =over 4
1209 :    
1210 :     =item rows
1211 :    
1212 :     Reference to a list of table rows. Each table row must be in HTML form with all
1213 :     the TR and TD tags set up. The first TD or TH tag in each row will be modified to
1214 :     set the width. Everything else will be left as is.
1215 :    
1216 :     =item RETURN
1217 :    
1218 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1219 :    
1220 :     =back
1221 :    
1222 :     =cut
1223 :    
1224 :     sub MakeTable {
1225 :     # Get the parameters.
1226 :     my ($self, $rows) = @_;
1227 :     # Get the CGI object.
1228 :     my $cgi = $self->Q();
1229 :     # Fix the widths on the first column. Note that we eschew the use of the "g"
1230 :     # modifier becase we only want to change the first tag. Also, if a width
1231 :     # is already specified on the first column bad things will happen.
1232 :     for my $row (@{$rows}) {
1233 :     $row =~ s/(<td|th)/$1 width="150"/i;
1234 :     }
1235 :     # Create the table.
1236 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1237 :     width => 700, class => 'search'},
1238 :     @{$rows});
1239 :     # Return the result.
1240 :     return $retVal;
1241 :     }
1242 :    
1243 :     =head3 SubmitRow
1244 :    
1245 :     C<< my $htmlText = $shelp->SubmitRow(); >>
1246 :    
1247 :     Returns the HTML text for the row containing the page size control
1248 :     and the submit button. All searches should have this row somewhere
1249 :     near the top of the form.
1250 :    
1251 :     =cut
1252 :    
1253 :     sub SubmitRow {
1254 :     # Get the parameters.
1255 :     my ($self) = @_;
1256 :     my $cgi = $self->Q();
1257 :     # Declare the return variable.
1258 :     my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1259 :     $cgi->td($cgi->popup_menu(-name => 'PageSize',
1260 :     -values => [10, 25, 45, 100, 1000],
1261 :     -default => $cgi->param('PageSize'))),
1262 :     $cgi->td($cgi->submit(-class => 'goButton',
1263 :     -name => 'Search',
1264 :     -value => 'Go')));
1265 :     # Return the result.
1266 :     return $retVal;
1267 :     }
1268 : parrello 1.2
1269 :     =head3 FeatureFilterRows
1270 :    
1271 :     C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1272 :    
1273 :     This method creates table rows that can be used to filter features. There are
1274 :     two rows returned, and the values can be used to select features by genome
1275 :     using the B<FeatureQuery> object.
1276 :    
1277 :     =cut
1278 :    
1279 :     sub FeatureFilterRows {
1280 :     # Get the parameters.
1281 :     my ($self) = @_;
1282 :     # Return the result.
1283 :     return FeatureQuery::FilterRows($self);
1284 :     }
1285 :    
1286 : parrello 1.1 =head3 GBrowseFeatureURL
1287 :    
1288 :     C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
1289 :    
1290 :     Compute the URL required to pull up a Gbrowse page for the the specified feature.
1291 :     In order to do this, we need to pull out the ID of the feature's Genome, its
1292 :     contig ID, and some rough starting and stopping offsets.
1293 :    
1294 :     =over 4
1295 :    
1296 :     =item sprout
1297 :    
1298 :     Sprout object for accessing the database.
1299 :    
1300 :     =item feat
1301 :    
1302 :     ID of the feature whose Gbrowse URL is desired.
1303 :    
1304 :     =item RETURN
1305 :    
1306 :     Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome
1307 :     ID, contig ID, starting offset, and stopping offset.
1308 :    
1309 :     =back
1310 :    
1311 :     =cut
1312 :    
1313 :     sub GBrowseFeatureURL {
1314 :     # Get the parameters.
1315 :     my ($sprout, $feat) = @_;
1316 :     # Declare the return variable.
1317 :     my $retVal;
1318 :     # Compute the genome ID.
1319 :     my ($genomeID) = FIGRules::ParseFeatureID($feat);
1320 :     # Only proceed if the feature ID produces a valid genome.
1321 :     if ($genomeID) {
1322 :     # Get the feature location string.
1323 :     my $loc = $sprout->FeatureLocation($feat);
1324 :     # Compute the contig, start, and stop points.
1325 :     my($start, $stop, $contig) = BasicLocation::Parse($loc);
1326 :     # Now we need to do some goofiness to insure that the location is not too
1327 :     # big and that we get some surrounding stuff.
1328 :     my $mid = int(($start + $stop) / 2);
1329 :     my $chunk_len = 20000;
1330 :     my $max_feature = 40000;
1331 :     my $feat_len = abs($stop - $start);
1332 :     if ($feat_len > $chunk_len) {
1333 :     if ($feat_len > $max_feature) {
1334 :     $chunk_len = $max_feature;
1335 :     } else {
1336 :     $chunk_len = $feat_len + 100;
1337 :     }
1338 :     }
1339 :     my($show_start, $show_stop);
1340 :     if ($chunk_len == $max_feature) {
1341 :     $show_start = $start - 300;
1342 :     } else {
1343 :     $show_start = $mid - int($chunk_len / 2);
1344 :     }
1345 :     if ($show_start < 1) {
1346 :     $show_start = 1;
1347 :     }
1348 :     $show_stop = $show_start + $chunk_len - 1;
1349 :     my $clen = $sprout->ContigLength($contig);
1350 :     if ($show_stop > $clen) {
1351 :     $show_stop = $clen;
1352 :     }
1353 :     my $seg_id = $contig;
1354 :     $seg_id =~ s/:/--/g;
1355 :     # Assemble all the pieces.
1356 :     $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";
1357 :     }
1358 :     # Return the result.
1359 :     return $retVal;
1360 :     }
1361 :    
1362 :     =head2 Feature Column Methods
1363 :    
1364 :     The methods in this column manage feature column data. If you want to provide the
1365 :     capability to include new types of data in feature columns, then all the changes
1366 :     are made to this section of the source file. Technically, this should be implemented
1367 :     using object-oriented methods, but this is simpler for non-programmers to maintain.
1368 :     To add a new column of feature data, you must first give it a name. For example,
1369 :     the name for the protein page link column is C<protlink>. If the column is to appear
1370 :     in the default list of feature columns, add it to the list returned by
1371 :     L</DefaultFeatureColumns>. Then add code to produce the column title to
1372 :     L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
1373 :     everything else will happen automatically.
1374 :    
1375 :     There is one special column name syntax for extra columns (that is, nonstandard
1376 :     feature columns). If the column name begins with C<X=>, then it is presumed to be
1377 :     an extra column. The column title is the text after the C<X=>, and its value is
1378 :     pulled from the extra column hash.
1379 :    
1380 :     =head3 DefaultFeatureColumns
1381 :    
1382 :     C<< my $colNames = $shelp->DefaultFeatureColumns(); >>
1383 :    
1384 :     Return a reference to a list of the default feature column identifiers. These
1385 :     identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in
1386 :     order to produce the column titles and row values.
1387 :    
1388 :     =cut
1389 :    
1390 :     sub DefaultFeatureColumns {
1391 :     # Get the parameters.
1392 :     my ($self) = @_;
1393 :     # Return the result.
1394 :     return ['orgName', 'function', 'gblink', 'protlink'];
1395 :     }
1396 :    
1397 :     =head3 FeatureColumnTitle
1398 :    
1399 :     C<< my $title = $shelp->FeatureColumnTitle($colName); >>
1400 :    
1401 :     Return the column heading title to be used for the specified feature column.
1402 :    
1403 :     =over 4
1404 :    
1405 :     =item name
1406 :    
1407 :     Name of the desired feature column.
1408 :    
1409 :     =item RETURN
1410 :    
1411 :     Returns the title to be used as the column header for the named feature column.
1412 :    
1413 :     =back
1414 :    
1415 :     =cut
1416 :    
1417 :     sub FeatureColumnTitle {
1418 :     # Get the parameters.
1419 :     my ($self, $colName) = @_;
1420 :     # Declare the return variable. We default to a blank column name.
1421 :     my $retVal = "&nbsp;";
1422 :     # Process the column name.
1423 :     if ($colName =~ /^X=(.+)$/) {
1424 :     # Here we have an extra column.
1425 :     $retVal = $1;
1426 :     } elsif ($colName eq 'orgName') {
1427 :     $retVal = "Name";
1428 :     } elsif ($colName eq 'fid') {
1429 :     $retVal = "FIG ID";
1430 :     } elsif ($colName eq 'alias') {
1431 :     $retVal = "External Aliases";
1432 :     } elsif ($colName eq 'function') {
1433 :     $retVal = "Functional Assignment";
1434 :     } elsif ($colName eq 'gblink') {
1435 :     $retVal = "GBrowse";
1436 :     } elsif ($colName eq 'protlink') {
1437 :     $retVal = "NMPDR Protein Page";
1438 :     } elsif ($colName eq 'group') {
1439 :     $retVal = "NMDPR Group";
1440 :     }
1441 :     # Return the result.
1442 :     return $retVal;
1443 :     }
1444 :    
1445 :     =head3 FeatureColumnValue
1446 :    
1447 :     C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
1448 :    
1449 :     Return the value to be displayed in the specified feature column.
1450 :    
1451 :     =over 4
1452 :    
1453 :     =item colName
1454 :    
1455 :     Name of the column to be displayed.
1456 :    
1457 :     =item record
1458 :    
1459 :     DBObject record for the feature being displayed in the current row.
1460 :    
1461 :     =item extraCols
1462 :    
1463 :     Reference to a hash of extra column names to values. If the incoming column name
1464 :     begins with C<X=>, its value will be taken from this hash.
1465 :    
1466 :     =item RETURN
1467 :    
1468 :     Returns the HTML to be displayed in the named column for the specified feature.
1469 :    
1470 :     =back
1471 :    
1472 :     =cut
1473 :    
1474 :     sub FeatureColumnValue {
1475 :     # Get the parameters.
1476 :     my ($self, $colName, $record, $extraCols) = @_;
1477 :     # Get the sprout and CGI objects.
1478 :     my $cgi = $self->Q();
1479 :     my $sprout = $self->DB();
1480 :     # Get the feature ID.
1481 :     my ($fid) = $record->Value('Feature(id)');
1482 :     # Declare the return variable. Denote that we default to a non-breaking space,
1483 :     # which will translate to an empty table cell (rather than a table cell with no
1484 :     # interior, which is what you get for a null string).
1485 :     my $retVal = "&nbsp;";
1486 :     # Process according to the column name.
1487 :     if ($colName =~ /^X=(.+)$/) {
1488 :     # Here we have an extra column. Only update if the value exists. Note that
1489 :     # a value of C<undef> is treated as a non-existent value, because the
1490 :     # caller may have put "colName => undef" in the "PutFeature" call in order
1491 :     # to insure we know the extra column exists.
1492 :     if (defined $extraCols->{$1}) {
1493 :     $retVal = $extraCols->{$1};
1494 :     }
1495 :     } elsif ($colName eq 'orgName') {
1496 :     # Here we want the formatted organism name and feature number.
1497 :     $retVal = $self->FeatureName($fid);
1498 :     } elsif ($colName eq 'fid') {
1499 :     # Here we have the raw feature ID. We hyperlink it to the protein page.
1500 :     $retVal = HTML::set_prot_links($fid);
1501 :     } elsif ($colName eq 'alias') {
1502 :     # In this case, the user wants a list of external aliases for the feature.
1503 :     # The complicated part is we have to hyperlink them. First, get the
1504 :     # aliases.
1505 :     my @aliases = $sprout->FeatureAliases($fid);
1506 :     # Only proceed if we found some.
1507 :     if (@aliases) {
1508 :     # Join the aliases into a comma-delimited list.
1509 :     my $aliasList = join(", ", @aliases);
1510 :     # Ask the HTML processor to hyperlink them.
1511 :     $retVal = HTML::set_prot_links($aliasList);
1512 :     }
1513 :     } elsif ($colName eq 'function') {
1514 :     # The functional assignment is just a matter of getting some text.
1515 :     ($retVal) = $record->Value('Feature(assignment)');
1516 :     } elsif ($colName eq 'gblink') {
1517 :     # Here we want a link to the GBrowse page using the official GBrowse button.
1518 :     my $gurl = "GetGBrowse.cgi?fid=$fid";
1519 :     $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },
1520 :     $cgi->img({ src => "../images/button-gbrowse.png",
1521 :     border => 0 })
1522 :     );
1523 :     } elsif ($colName eq 'protlink') {
1524 :     # Here we want a link to the protein page using the official NMPDR button.
1525 :     my $hurl = HTML::fid_link($cgi, $fid, 0, 1);
1526 :     $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },
1527 :     $cgi->img({ src => "../images/button-nmpdr.png",
1528 :     border => 0 })
1529 :     );
1530 :     } elsif ($colName eq 'group') {
1531 :     # Get the NMPDR group name.
1532 :     my (undef, $group) = $self->OrganismData($fid);
1533 :     # Dress it with a URL to the group's main page.
1534 :     my $nurl = $sprout->GroupPageName($group);
1535 :     $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
1536 :     $group);
1537 :     }
1538 :     # Return the result.
1539 :     return $retVal;
1540 :     }
1541 :    
1542 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3