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

Annotation of /Sprout/RHLocations.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package RHLocations;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use BasicLocation;
8 :     use ERDBObject;
9 :     use POSIX;
10 :     use base 'ResultHelper';
11 :    
12 :     =head1 Location Result Helper
13 :    
14 :     =head2 Introduction
15 :    
16 :     The location result helper is used to display the results of a search that returns
17 :     DNA or protein locations. A DNA location is specified as a location inside a contig.
18 :     A protein location is specified as a location inside a feature.
19 :    
20 :     =cut
21 :    
22 :     =head2 Data Structures
23 :    
24 :     =head3 NEIGHBORHOOD
25 :    
26 :     Maximum distance in nucleotides for two locations to be considered in the same neighborhood.
27 :    
28 :     =cut
29 :    
30 :     use constant { NEIGHBORHOOD => 4000 };
31 :    
32 :     =head2 Public Methods
33 :    
34 :     =head3 new
35 :    
36 :     C<< my $rhelp = RHLocations->new($shelp); >>
37 :    
38 :     Construct a new RHLocations object.
39 :    
40 :     =over 4
41 :    
42 :     =item shelp
43 :    
44 :     Parent search helper object for this result helper.
45 :    
46 :     =back
47 :    
48 :     =cut
49 :    
50 :     sub new {
51 :     # Get the parameters.
52 :     my ($class, $shelp) = @_;
53 :     # Create the helper object.
54 :     my $retVal = ResultHelper::new($class, $shelp);
55 :     # Bless and return it.
56 :     bless $retVal, $class;
57 :     return $retVal;
58 :     }
59 :    
60 :     =head3 BuildLocationRecord
61 :    
62 :     C<< my $erdbObject = RHLocations::BuildLocationRecord($hitLocString); >>
63 :    
64 :     Build an B<ERDBObject> containing data about a specified location. Unlike most
65 :     result objects, a location does not exist in the Sprout database. This method
66 :     is used to parse the location string into fields and package them as an
67 :     object for use by the column methods.
68 :    
69 :     This method is provided as a static function so that the other methods of
70 :     this object have the privilege of knowing what data is in the B<ERDBObject>
71 :     generated. This is less important for the other result helpers because they
72 :     deal in database objects whose fields can be deduced from the database design.
73 :    
74 :     =over 4
75 :    
76 :     =item hitLocString
77 :    
78 :     A string representation of a hit location, in a standard form that can
79 :     be parsed using the B<BasicLocation> constructor (e.g. C<fig|100226.1.peg.3361_140_10>
80 :     or C<100226.1:NC_003888_3766170+612>).
81 :    
82 :     =item RETURN
83 :    
84 :     Returns an B<ERDBObject> containing all the values parsed out of the hit location.
85 :    
86 :     =back
87 :    
88 :     =cut
89 :    
90 :     sub BuildLocationRecord {
91 :     # Get the parameters.
92 :     my ($hitLocString) = @_;
93 :     # Parse the location string into a location object.
94 :     my $hitLocObject = BasicLocation->new($hitLocString);
95 :     # Compute the genome ID from the Contig. Note that if this is a protein
96 :     # location, the Contig is actually a feature ID. In both cases, however,
97 :     # the genome ID is encoded as part of the ID in clear text.
98 :     my $contig = $hitLocObject->Contig;
99 :     $contig =~ /(\d+\.\d+)/;
100 :     my $genome = $1;
101 :     # Convert the components into data fields in an ERDBObject.
102 :     my $retVal = ERDBObject->new('Location(container)' => [$contig],
103 :     'Location(genome)' => [$genome],
104 :     'Location(begin)' => [$hitLocObject->Begin],
105 :     'Location(dir)' => [$hitLocObject->Dir],
106 :     'Location(length)' => [$hitLocObject->Length],
107 :     'Location(string)' => [$hitLocObject->String]);
108 :     # Return the result.
109 :     return $retVal;
110 :     }
111 :    
112 :     =head3 HitLocation
113 :    
114 :     C<< my $locString = $rhelp->HitLocation(); >>
115 :    
116 :     Return the hit location string for the current output line.
117 :    
118 :     =cut
119 :    
120 :     sub HitLocation {
121 :     # Get the parameters.
122 :     my ($self) = @_;
123 :     # Get the record.
124 :     my $record = $self->Record;
125 :     # Pull out the location string.
126 :     return $record->PrimaryValue('Location(string)');
127 :     }
128 :    
129 :     =head3 FindNearbyFeature
130 :    
131 :     C<< my $featureObject = $rhelp->FindNearbyFeature($hitLoc); >>
132 :    
133 :     Find a nearby feature for this hit location. If the hit location is a protein
134 :     location (i.e. inside a known feature), then the feature is returned without
135 :     preamble. If the hit location is on a contig, the feature chosen will be the
136 :     one whose begin point or end point is closest to the location's midpoint.
137 :    
138 :     This method is used by the run-time-value methods, so there will not be
139 :     a copy of the current record available.
140 :    
141 :     =over 4
142 :    
143 :     =item hitLoc
144 :    
145 :     String describing the relevant hit location.
146 :    
147 :     =item RETURN
148 :    
149 :     Returns a record for the nearest feature.
150 :    
151 :     =back
152 :    
153 :     =cut
154 :    
155 :     sub FindNearbyFeature {
156 :     # Get the parameters.
157 :     my ($self, $hitLoc) = @_;
158 :     # Declare the return variable.
159 :     my $retVal;
160 :     # Get a sprout object.
161 :     my $shelp = $self->Parent();
162 :     my $sprout = $shelp->DB();
163 :     # Compute the hit location object and the target object name.
164 :     my $hitLocObj = BasicLocation->new($hitLoc);
165 :     # Get the location's target object.
166 :     my $targetObjectName = $hitLocObj->Contig;
167 :     # Check its type.
168 :     if ($targetObjectName =~ /^fig\|/) {
169 :     # Here the target object is a feature, so we return the feature itself.
170 :     $retVal = $sprout->GetEntity(Feature => $targetObjectName);
171 :     Trace("Feature $targetObjectName chosen as nearby to $hitLoc.") if T(4);
172 :     Trace("Feature object not found.") if T(4) && ! defined $retVal;
173 :     } else {
174 :     # Here it's a contig, so we have to search the hard way. First, we need the
175 :     # neighborhood size.
176 :     my $tuningParms = $shelp->TuningParameters(neighborhood => NEIGHBORHOOD);
177 :     my $neighborhood = $tuningParms->{neighborhood};
178 :     Trace("Neighborhood is $neighborhood.") if T(4);
179 :     # Widen the location by the neighborhood distance on both sides. This requires knowing
180 :     # the contig length.
181 :     my $contigLength = $sprout->ContigLength($targetObjectName);
182 :     my $wideLocObj = BasicLocation->new($hitLocObj);
183 :     $wideLocObj->Widen($neighborhood, $contigLength);
184 :     Trace("Search neighborhood is " . $hitLocObj->String . ".") if T(4);
185 :     # Look for features in the computed region.
186 :     my @features = $sprout->GeneDataInRegion($targetObjectName, $wideLocObj->Left, $wideLocObj->Right);
187 :     # Get the midpoint of the hit location.
188 :     my $hitMidpoint = ($hitLocObj->Begin + $hitLocObj->EndPoint) / 2;
189 :     # Search for the best choice. This will be a feature whose start or end point is closest to our
190 :     # mid point.
191 :     my $bestFeature;
192 :     my $bestDistance = INT_MAX;
193 :     for my $feature (@features) {
194 :     # Get this feature's last location.
195 :     my @locList = split /\s*,\s*/, $feature->PrimaryValue('Feature(location-string)');
196 :     for my $featureLoc (@locList) {
197 :     my $currentLoc = BasicLocation->new($featureLoc);
198 :     for my $point ($currentLoc->Begin, $currentLoc->EndPoint) {
199 :     my $newDistance = abs($point - $hitMidpoint);
200 :     Trace("Distance is $newDistance. Best is $bestDistance.") if T(4);
201 :     # Now we determine whether or not this feature is better than the best one so far.
202 :     my $better = 0;
203 :     if ($newDistance < $bestDistance) {
204 :     # Here it's closer, so it is automatically better.
205 :     $better = 1;
206 :     } elsif ($newDistance == $bestDistance && $currentLoc->Dir eq $hitLocObj->Dir) {
207 :     # If the distances are the same, we break ties in favor of the location on the same strand.
208 :     $better = 1;
209 :     }
210 :     if ($better) {
211 :     $bestFeature = $feature;
212 :     $bestDistance = $newDistance;
213 :     }
214 :     }
215 :     }
216 :     }
217 :     # Return the feature with the best distance.
218 :     $retVal = $bestFeature;
219 :     }
220 :     # Return the result.
221 :     return $retVal;
222 :     }
223 :    
224 :     =head3 NearbyFeature
225 :    
226 :     C<< my $featureRecord = $rhelp->NearbyFeature($hitLoc); >>
227 :    
228 :     Return the nearby feature. If it has already been found, we return it from the
229 :     cache. Otherwise we find it and then cache it on our way out.
230 :    
231 :     =over 4
232 :    
233 :     =item hitLoc
234 :    
235 :     Location string for the current hit.
236 :    
237 :     =item RETURN
238 :    
239 :     Returns an C<ERDBObject> for the desired feature, or C<undef> if no such
240 :     feature exists.
241 :    
242 :     =back
243 :    
244 :     =cut
245 :    
246 :     sub NearbyFeature {
247 :     # Get the parameters.
248 :     my ($self, $hitLoc) = @_;
249 :     # Declare the return variable.
250 :     my $retVal;
251 :     # Check the cache.
252 :     my $cache = $self->Cache;
253 :     if (exists $cache->{nearby}) {
254 :     # Here we've already cached the value.
255 :     $retVal = $cache->{nearby};
256 :     } else {
257 :     # Here we need to find it the hard way.
258 :     $retVal = $self->FindNearbyFeature($hitLoc);
259 :     # Save it for next time.
260 :     $cache->{nearby} = $retVal;
261 :     }
262 :     # Return the result.
263 :     return $retVal;
264 :     }
265 :    
266 :     =head2 Virtual Overrides
267 :    
268 :     =head3 DefaultResultColumns
269 :    
270 :     C<< my @colNames = $rhelp->DefaultResultColumns(); >>
271 :    
272 :     Return a list of the default columns to be used by searches with this
273 :     type of result. Note that the actual default columns are computed by
274 :     the search helper. This method is only needed if the search helper doesn't
275 :     care.
276 :    
277 :     The columns returned should be in the form of column names, all of which
278 :     must be defined by the result helper class.
279 :    
280 :     =cut
281 :    
282 :     sub DefaultResultColumns {
283 :     return qw(orgName compareLink nextFeature nextFeatureFunction nextFeatureLink);
284 :     }
285 :    
286 :     =head2 Column Methods
287 :    
288 :     =head3 compareLink
289 :    
290 :     C<< my $colDatum = RHLocations::compareLink($type => $rhelp, $key); >>
291 :    
292 :     This method computes the various things we need to know into order to process
293 :     the compareLink column.
294 :    
295 :     =over 4
296 :    
297 :     =item type
298 :    
299 :     Type of data about the column that is required: C<title> for the column title,
300 :     C<download> for the download flag, and so forth.
301 :    
302 :     =item rhelp
303 :    
304 :     Result helper being used to format the search output.
305 :    
306 :     =item key (optional)
307 :    
308 :     The key to be used to compute a run-time value.
309 :    
310 :     =item RETURN
311 :    
312 :     Returns the desired information about the compareLink column.
313 :    
314 :     =back
315 :    
316 :     =cut
317 :    
318 :     sub compareLink {
319 :     # Get the parameters.
320 :     my ($type, $rhelp, $key) = @_;
321 :     # Declare the return variable.
322 :     my $retVal;
323 :     # Process according to the information requested.
324 :     if ($type eq 'title') {
325 :     # Return the title for this column. Button columns
326 :     # generally don't have titles.
327 :     $retVal = '';
328 :     } elsif ($type eq 'download') {
329 :     # This field should not be included in a download. It relies on the
330 :     # existence of files that may expire soon.
331 :     $retVal = '';
332 :     } elsif ($type eq 'style') {
333 :     # Here the caller wants the style class used to format this column.
334 :     $retVal = 'leftAlign';
335 :     } elsif ($type eq 'value') {
336 :     # This is a run-time value that depends on the hit location.
337 :     my $newKey = $rhelp->HitLocation;
338 :     $retVal = "%%compareLink=$newKey";
339 :     } elsif ($type eq 'runTimeValue') {
340 :     my $feature = $rhelp->NearbyFeature($key);
341 :     if (! defined($feature)) {
342 :     # No nearby feature, so we don't return anything.
343 :     $retVal = "";
344 :     } else {
345 :     # Here we want to create a formlet. We need the session ID
346 :     # and the feature id.
347 :     my $shelp = $rhelp->Parent;
348 :     my $session = $shelp->ID();
349 :     my $fid = $feature->PrimaryValue('Feature(id)');
350 :     $retVal = $rhelp->Formlet('Context', "patscanresult.cgi", undef,
351 :     page => 'genome_regions', peg => $fid,
352 :     file => "tmp_$session.cache",
353 :     SPROUT => 1);
354 :     }
355 :     }
356 :     return $retVal;
357 :     }
358 :    
359 :     =head3 nextFeature
360 :    
361 :     C<< my $colDatum = RHLocations::nextFeature($type => $rhelp, $key); >>
362 :    
363 :     This method computes the various things we need to know into order to process
364 :     the nextFeature column.
365 :    
366 :     =over 4
367 :    
368 :     =item type
369 :    
370 :     Type of data about the column that is required: C<title> for the column title,
371 :     C<download> for the download flag, and so forth.
372 :    
373 :     =item rhelp
374 :    
375 :     Result helper being used to format the search output.
376 :    
377 :     =item key (optional)
378 :    
379 :     The key to be used to compute a run-time value.
380 :    
381 :     =item RETURN
382 :    
383 :     Returns the desired information about the nextFeature column.
384 :    
385 :     =back
386 :    
387 :     =cut
388 :    
389 :     sub nextFeature {
390 :     # Get the parameters.
391 :     my ($type, $rhelp, $key) = @_;
392 :     # Declare the return variable.
393 :     my $retVal;
394 :     # Process according to the information requested.
395 :     if ($type eq 'title') {
396 :     # Return the title for this column.
397 :     $retVal = 'Nearest Feature';
398 :     } elsif ($type eq 'download') {
399 :     # This field should be included in a download.
400 :     $retVal = 'text';
401 :     } elsif ($type eq 'style') {
402 :     # Here the caller wants the style class used to format this column.
403 :     $retVal = 'leftAlign';
404 :     } elsif ($type eq 'value') {
405 :     # This is a run-time value that depends on the hit location.
406 :     my $newKey = $rhelp->HitLocation;
407 :     $retVal = "%%nextFeature=$newKey";
408 :     } elsif ($type eq 'runTimeValue') {
409 :     my $feature = $rhelp->NearbyFeature($key);
410 :     if (! defined($feature)) {
411 :     # No nearby feature, so we don't return anything.
412 :     $retVal = "";
413 :     } else {
414 :     # Get the feature's ID.
415 :     $retVal = $rhelp->PreferredID($feature);
416 :     }
417 :     }
418 :     return $retVal;
419 :     }
420 :    
421 :     =head3 nextFeatureFunction
422 :    
423 :     C<< my $colDatum = RHLocations::nextFeatureFunction($type => $rhelp, $key); >>
424 :    
425 :     This method computes the various things we need to know into order to process
426 :     the nextFeatureFunction column.
427 :    
428 :     =over 4
429 :    
430 :     =item type
431 :    
432 :     Type of data about the column that is required: C<title> for the column title,
433 :     C<download> for the download flag, and so forth.
434 :    
435 :     =item rhelp
436 :    
437 :     Result helper being used to format the search output.
438 :    
439 :     =item key (optional)
440 :    
441 :     The key to be used to compute a run-time value.
442 :    
443 :     =item RETURN
444 :    
445 :     Returns the desired information about the nextFeatureFunction column.
446 :    
447 :     =back
448 :    
449 :     =cut
450 :    
451 :     sub nextFeatureFunction {
452 :     # Get the parameters.
453 :     my ($type, $rhelp, $key) = @_;
454 :     # Declare the return variable.
455 :     my $retVal;
456 :     # Process according to the information requested.
457 :     if ($type eq 'title') {
458 :     # Return the title for this column.
459 :     $retVal = 'Assignment';
460 :     } elsif ($type eq 'download') {
461 :     # This field should be included in a download.
462 :     $retVal = 'text';
463 :     } elsif ($type eq 'style') {
464 :     # Here the caller wants the style class used to format this column.
465 :     $retVal = 'leftAlign';
466 :     } elsif ($type eq 'value') {
467 :     # This is a run-time value that depends on the hit location.
468 :     my $newKey = $rhelp->HitLocation;
469 :     $retVal = "%%nextFeatureFunction=$newKey";
470 :     } elsif ($type eq 'runTimeValue') {
471 :     my $feature = $rhelp->NearbyFeature($key);
472 :     if (! defined($feature)) {
473 :     # No nearby feature, so we don't return anything.
474 :     $retVal = "";
475 :     } else {
476 :     # Get the feature's assignment.
477 :     $retVal = $feature->PrimaryValue('Feature(assignment)');
478 :     }
479 :     }
480 :     return $retVal;
481 :     }
482 :    
483 :     =head3 nextFeatureLink
484 :    
485 :     C<< my $colDatum = RHLocations::nextFeatureLink($type => $rhelp, $key); >>
486 :    
487 :     This method computes the various things we need to know into order to process
488 :     the nextFeatureLink column.
489 :    
490 :     =over 4
491 :    
492 :     =item type
493 :    
494 :     Type of data about the column that is required: C<title> for the column title,
495 :     C<download> for the download flag, and so forth.
496 :    
497 :     =item rhelp
498 :    
499 :     Result helper being used to format the search output.
500 :    
501 :     =item key (optional)
502 :    
503 :     The key to be used to compute a run-time value.
504 :    
505 :     =item RETURN
506 :    
507 :     Returns the desired information about the nextFeatureLink column.
508 :    
509 :     =back
510 :    
511 :     =cut
512 :    
513 :     sub nextFeatureLink {
514 :     # Get the parameters.
515 :     my ($type, $rhelp, $key) = @_;
516 :     # Declare the return variable.
517 :     my $retVal;
518 :     # Process according to the information requested.
519 :     if ($type eq 'title') {
520 :     # Formlets don't need a column title.
521 :     $retVal = '';
522 :     } elsif ($type eq 'download') {
523 :     # This field should be included in a download.
524 :     $retVal = 'link';
525 :     } elsif ($type eq 'style') {
526 :     # Here the caller wants the style class used to format this column.
527 :     $retVal = 'leftAlign';
528 :     } elsif ($type eq 'value') {
529 :     # This is a run-time value that depends on the hit location.
530 :     my $newKey = $rhelp->HitLocation;
531 :     $retVal = "%%nextFeatureLink=$newKey";
532 :     } elsif ($type eq 'runTimeValue') {
533 :     my $feature = $rhelp->NearbyFeature($key);
534 :     if (! defined($feature)) {
535 :     # No nearby feature, so we don't return anything.
536 :     $retVal = "";
537 :     } else {
538 :     # Create a formlet for the feature's page.
539 :     my $fid = $feature->PrimaryValue('Feature(id)');
540 :     $retVal = $rhelp->Formlet('NMPDR', "protein.cgi", undef,
541 :     prot => $fid, SPROUT => 1, new_framework => 0,
542 :     user => '');
543 :     }
544 :     }
545 :     return $retVal;
546 :     }
547 :    
548 :     =head3 orgName
549 :    
550 :     C<< my $colDatum = RHLocations::orgName($type => $rhelp, $key); >>
551 :    
552 :     This method computes the various things we need to know into order to process
553 :     the orgName column.
554 :    
555 :     =over 4
556 :    
557 :     =item type
558 :    
559 :     Type of data about the column that is required: C<title> for the column title,
560 :     C<download> for the download flag, and so forth.
561 :    
562 :     =item rhelp
563 :    
564 :     Result helper being used to format the search output.
565 :    
566 :     =item key (optional)
567 :    
568 :     The key to be used to compute a run-time value.
569 :    
570 :     =item RETURN
571 :    
572 :     Returns the desired information about the orgName column.
573 :    
574 :     =back
575 :    
576 :     =cut
577 :    
578 :     sub orgName {
579 :     # Get the parameters.
580 :     my ($type, $rhelp, $key) = @_;
581 :     # Declare the return variable.
582 :     my $retVal;
583 :     # Process according to the information requested.
584 :     if ($type eq 'title') {
585 :     # Return the title for this column.
586 :     $retVal = 'Organism Name';
587 :     } elsif ($type eq 'download') {
588 :     # This field should be included in a download.
589 :     $retVal = 'text';
590 :     } elsif ($type eq 'style') {
591 :     # Here the caller wants the style class used to format this column.
592 :     $retVal = 'leftAlign';
593 :     } elsif ($type eq 'value') {
594 :     # Get the data record and the parent search helper.
595 :     my $record = $rhelp->Record;
596 :     my $shelp = $rhelp->Parent;
597 :     # Extract the genome ID.
598 :     my $genomeID = $record->PrimaryValue('Location(genome)');
599 :     # Ask the parent for the organism name. This will usually be in a cache.
600 :     $retVal = $shelp->Organism($genomeID);
601 :     } elsif ($type eq 'runTimeValue') {
602 :     # Run-time support is not needed for this column.
603 :     }
604 :     return $retVal;
605 :     }
606 :    
607 :    
608 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3