Filename | /Users/ap13/perl5/lib/perl5/Bio/Location/Split.pm |
Statements | Executed 6 statements in 1.79ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 12µs | 12µs | BEGIN@99 | Bio::Location::Split::
1 | 1 | 1 | 8µs | 581µs | BEGIN@101 | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | add_sub_Location | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | each_Location | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | end | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | end_pos_type | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | flip_strand | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | guide_strand | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | is_single_sequence | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | length | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | max_end | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | max_start | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | min_end | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | min_start | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | new | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | seq_id | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | splittype | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | start | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | start_pos_type | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | strand | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | sub_Location | Bio::Location::Split::
0 | 0 | 0 | 0s | 0s | to_FTstring | Bio::Location::Split::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # | ||||
2 | # BioPerl module for Bio::Location::Split | ||||
3 | # Please direct questions and support issues to <bioperl-l@bioperl.org> | ||||
4 | # | ||||
5 | # Cared for by Jason Stajich <jason@bioperl.org> | ||||
6 | # | ||||
7 | # Copyright Jason Stajich | ||||
8 | # | ||||
9 | # You may distribute this module under the same terms as perl itself | ||||
10 | # POD documentation - main docs before the code | ||||
11 | |||||
12 | =head1 NAME | ||||
13 | |||||
14 | Bio::Location::Split - Implementation of a Location on a Sequence | ||||
15 | which has multiple locations (start/end points) | ||||
16 | |||||
17 | =head1 SYNOPSIS | ||||
18 | |||||
19 | use Bio::Location::Split; | ||||
20 | |||||
21 | my $splitlocation = Bio::Location::Split->new(); | ||||
22 | $splitlocation->add_sub_Location(Bio::Location::Simple->new(-start=>1, | ||||
23 | -end=>30, | ||||
24 | -strand=>1)); | ||||
25 | $splitlocation->add_sub_Location(Bio::Location::Simple->new(-start=>50, | ||||
26 | -end=>61, | ||||
27 | -strand=>1)); | ||||
28 | my @sublocs = $splitlocation->sub_Location(); | ||||
29 | |||||
30 | my $count = 1; | ||||
31 | # print the start/end points of the sub locations | ||||
32 | foreach my $location ( sort { $a->start <=> $b->start } | ||||
33 | @sublocs ) { | ||||
34 | printf "sub feature %d [%d..%d]\n", | ||||
35 | $count, $location->start,$location->end, "\n"; | ||||
36 | $count++; | ||||
37 | } | ||||
38 | |||||
39 | =head1 DESCRIPTION | ||||
40 | |||||
41 | This implementation handles locations which span more than one | ||||
42 | start/end location, or and/or lie on different sequences, and can | ||||
43 | work with split locations that depend on the specific order of the | ||||
44 | sublocations ('join') or don't have a specific order but represent | ||||
45 | a feature spanning noncontiguous sublocations ('order', 'bond'). | ||||
46 | |||||
47 | Note that the order in which sublocations are added may be very important, | ||||
48 | depending on the specific split location type. For instance, a 'join' | ||||
49 | must have the sublocations added in the order that one expects to | ||||
50 | join the sublocations, whereas all other types are sorted based on the | ||||
51 | sequence location. | ||||
52 | |||||
53 | =head1 FEEDBACK | ||||
54 | |||||
55 | User feedback is an integral part of the evolution of this and other | ||||
56 | Bioperl modules. Send your comments and suggestions preferably to one | ||||
57 | of the Bioperl mailing lists. Your participation is much appreciated. | ||||
58 | |||||
59 | bioperl-l@bioperl.org - General discussion | ||||
60 | http://bioperl.org/wiki/Mailing_lists - About the mailing lists | ||||
61 | |||||
62 | =head2 Support | ||||
63 | |||||
64 | Please direct usage questions or support issues to the mailing list: | ||||
65 | |||||
66 | I<bioperl-l@bioperl.org> | ||||
67 | |||||
68 | rather than to the module maintainer directly. Many experienced and | ||||
69 | reponsive experts will be able look at the problem and quickly | ||||
70 | address it. Please include a thorough description of the problem | ||||
71 | with code and data examples if at all possible. | ||||
72 | |||||
73 | =head2 Reporting Bugs | ||||
74 | |||||
75 | Report bugs to the Bioperl bug tracking system to help us keep track | ||||
76 | the bugs and their resolution. Bug reports can be submitted via the | ||||
77 | web: | ||||
78 | |||||
79 | https://github.com/bioperl/bioperl-live/issues | ||||
80 | |||||
81 | =head1 AUTHOR - Jason Stajich | ||||
82 | |||||
83 | Email jason-AT-bioperl_DOT_org | ||||
84 | |||||
85 | =head1 APPENDIX | ||||
86 | |||||
87 | The rest of the documentation details each of the object | ||||
88 | methods. Internal methods are usually preceded with a _ | ||||
89 | |||||
90 | =cut | ||||
91 | |||||
92 | # Let the code begin... | ||||
93 | |||||
94 | package Bio::Location::Split; | ||||
95 | |||||
96 | # as defined by BSANE 0.03 | ||||
97 | 1 | 2µs | our @CORBALOCATIONOPERATOR = ('NONE','JOIN', undef, 'ORDER');; | ||
98 | |||||
99 | 2 | 28µs | 1 | 12µs | # spent 12µs within Bio::Location::Split::BEGIN@99 which was called:
# once (12µs+0s) by Bio::SeqFeature::Generic::BEGIN@147 at line 99 # spent 12µs making 1 call to Bio::Location::Split::BEGIN@99 |
100 | |||||
101 | 2 | 1.76ms | 2 | 1.15ms | # spent 581µs (8+573) within Bio::Location::Split::BEGIN@101 which was called:
# once (8µs+573µs) by Bio::SeqFeature::Generic::BEGIN@147 at line 101 # spent 581µs making 1 call to Bio::Location::Split::BEGIN@101
# spent 573µs making 1 call to base::import |
102 | |||||
103 | sub new { | ||||
104 | my ($class, @args) = @_; | ||||
105 | my $self = $class->SUPER::new(@args); | ||||
106 | # initialize | ||||
107 | $self->{'_sublocations'} = []; | ||||
108 | my ( $type, $seqid, $locations ) = | ||||
109 | $self->_rearrange([qw(SPLITTYPE | ||||
110 | SEQ_ID | ||||
111 | LOCATIONS | ||||
112 | )], @args); | ||||
113 | if( defined $locations && ref($locations) =~ /array/i ) { | ||||
114 | $self->add_sub_Location(@$locations); | ||||
115 | } | ||||
116 | $seqid && $self->seq_id($seqid); | ||||
117 | $type ||= 'JOIN'; | ||||
118 | $type = lc ($type); | ||||
119 | $self->splittype($type); | ||||
120 | return $self; | ||||
121 | } | ||||
122 | |||||
123 | =head2 each_Location | ||||
124 | |||||
125 | Title : each_Location | ||||
126 | Usage : @locations = $locObject->each_Location($order); | ||||
127 | Function: Conserved function call across Location:: modules - will | ||||
128 | return an array containing the component Location(s) in | ||||
129 | that object, regardless if the calling object is itself a | ||||
130 | single location or one containing sublocations. | ||||
131 | Returns : an array of Bio::LocationI implementing objects | ||||
132 | Args : Optional sort order to be passed to sub_Location() | ||||
133 | |||||
134 | =cut | ||||
135 | |||||
136 | sub each_Location { | ||||
137 | my ($self, $order) = @_; | ||||
138 | my @locs = (); | ||||
139 | foreach my $subloc ($self->sub_Location($order)) { | ||||
140 | # Recursively check to get hierarchical split locations: | ||||
141 | push @locs, $subloc->each_Location($order); | ||||
142 | } | ||||
143 | return @locs; | ||||
144 | } | ||||
145 | |||||
146 | =head2 sub_Location | ||||
147 | |||||
148 | Title : sub_Location | ||||
149 | Usage : @sublocs = $splitloc->sub_Location(); | ||||
150 | Function: Returns the array of sublocations making up this compound (split) | ||||
151 | location. Those sublocations referring to the same sequence as | ||||
152 | the root split location will be sorted by start position (forward | ||||
153 | sort) or end position (reverse sort) and come first (before | ||||
154 | those on other sequences). | ||||
155 | |||||
156 | The sort order can be optionally specified or suppressed by the | ||||
157 | value of the first argument. The default is no sort. | ||||
158 | |||||
159 | Returns : an array of Bio::LocationI implementing objects | ||||
160 | Args : Optionally 1, 0, or -1 for specifying a forward, no, or reverse | ||||
161 | sort order | ||||
162 | |||||
163 | =cut | ||||
164 | |||||
165 | sub sub_Location { | ||||
166 | my ($self, $order) = @_; | ||||
167 | $order = 0 unless defined $order; | ||||
168 | if( defined($order) && ($order !~ /^-?\d+$/) ) { | ||||
169 | $self->throw("value $order passed in to sub_Location is $order, an invalid value"); | ||||
170 | } | ||||
171 | $order = 1 if($order > 1); | ||||
172 | $order = -1 if($order < -1); | ||||
173 | my @sublocs = defined $self->{'_sublocations'} ? @{$self->{'_sublocations'}} : (); | ||||
174 | |||||
175 | # return the array if no ordering requested | ||||
176 | return @sublocs if( ($order == 0) || (! @sublocs) ); | ||||
177 | |||||
178 | # sort those locations that are on the same sequence as the top (`master') | ||||
179 | # if the top seq is undefined, we take the first defined in a sublocation | ||||
180 | my $seqid = $self->seq_id(); | ||||
181 | my $i = 0; | ||||
182 | while((! defined($seqid)) && ($i <= $#sublocs)) { | ||||
183 | $seqid = $sublocs[$i++]->seq_id(); | ||||
184 | } | ||||
185 | if((! $self->seq_id()) && $seqid) { | ||||
186 | $self->warn("sorted sublocation array requested but ". | ||||
187 | "root location doesn't define seq_id ". | ||||
188 | "(at least one sublocation does!)"); | ||||
189 | } | ||||
190 | my @locs = ($seqid ? | ||||
191 | grep { $_->seq_id() eq $seqid; } @sublocs : | ||||
192 | @sublocs); | ||||
193 | if(@locs) { | ||||
194 | if($order == 1) { | ||||
195 | # Schwartzian transforms for performance boost | ||||
196 | @locs = map { $_->[0] } | ||||
197 | sort { | ||||
198 | (defined $a && defined $b) ? $a->[1] <=> $b->[1] : | ||||
199 | $a ? -1 : 1 | ||||
200 | } | ||||
201 | map { | ||||
202 | [$_, (defined $_->start ? $_->start : $_->end)] | ||||
203 | } @locs;; | ||||
204 | } else { # $order == -1 | ||||
205 | @locs = map { $_->[0]} | ||||
206 | sort { | ||||
207 | (defined $a && defined $b) ? $b->[1] <=> $a->[1] : | ||||
208 | $a ? -1 : 1 | ||||
209 | } | ||||
210 | map { | ||||
211 | [$_, (defined $_->end ? $_->end : $_->start)] | ||||
212 | } @locs; | ||||
213 | } | ||||
214 | } | ||||
215 | # push the rest unsorted | ||||
216 | if($seqid) { | ||||
217 | push(@locs, grep { $_->seq_id() ne $seqid; } @sublocs); | ||||
218 | } | ||||
219 | # done! | ||||
220 | |||||
221 | return @locs; | ||||
222 | } | ||||
223 | |||||
224 | =head2 add_sub_Location | ||||
225 | |||||
226 | Title : add_sub_Location | ||||
227 | Usage : $splitloc->add_sub_Location(@locationIobjs); | ||||
228 | Function: add an additional sublocation | ||||
229 | Returns : number of current sub locations | ||||
230 | Args : list of Bio::LocationI implementing object(s) to add | ||||
231 | |||||
232 | =cut | ||||
233 | |||||
234 | sub add_sub_Location { | ||||
235 | my ($self,@args) = @_; | ||||
236 | my @locs; | ||||
237 | foreach my $loc ( @args ) { | ||||
238 | if( !ref($loc) || ! $loc->isa('Bio::LocationI') ) { | ||||
239 | $self->throw("Trying to add $loc as a sub Location but it doesn't implement Bio::LocationI!"); | ||||
240 | next; | ||||
241 | } | ||||
242 | push @{$self->{'_sublocations'}}, $loc; | ||||
243 | } | ||||
244 | |||||
245 | return scalar @{$self->{'_sublocations'}}; | ||||
246 | } | ||||
247 | |||||
248 | =head2 splittype | ||||
249 | |||||
250 | Title : splittype | ||||
251 | Usage : $splittype = $location->splittype(); | ||||
252 | Function: get/set the split splittype | ||||
253 | Returns : the splittype of split feature (join, order) | ||||
254 | Args : splittype to set | ||||
255 | |||||
256 | =cut | ||||
257 | |||||
258 | sub splittype { | ||||
259 | my ($self, $value) = @_; | ||||
260 | if( defined $value || ! defined $self->{'_splittype'} ) { | ||||
261 | $value = 'JOIN' unless( defined $value ); | ||||
262 | $self->{'_splittype'} = uc ($value); | ||||
263 | } | ||||
264 | return $self->{'_splittype'}; | ||||
265 | } | ||||
266 | |||||
267 | =head2 is_single_sequence | ||||
268 | |||||
269 | Title : is_single_sequence | ||||
270 | Usage : if($splitloc->is_single_sequence()) { | ||||
271 | print "Location object $splitloc is split ". | ||||
272 | "but only across a single sequence\n"; | ||||
273 | } | ||||
274 | Function: Determine whether this location is split across a single or | ||||
275 | multiple sequences. | ||||
276 | |||||
277 | This implementation ignores (sub-)locations that do not define | ||||
278 | seq_id(). The same holds true for the root location. | ||||
279 | |||||
280 | Returns : TRUE if all sublocations lie on the same sequence as the root | ||||
281 | location (feature), and FALSE otherwise. | ||||
282 | Args : none | ||||
283 | |||||
284 | =cut | ||||
285 | |||||
286 | sub is_single_sequence { | ||||
287 | my ($self) = @_; | ||||
288 | |||||
289 | my $seqid = $self->seq_id(); | ||||
290 | foreach my $loc ($self->sub_Location(0)) { | ||||
291 | $seqid = $loc->seq_id() if(! $seqid); | ||||
292 | if(defined($loc->seq_id()) && ($loc->seq_id() ne $seqid)) { | ||||
293 | return 0; | ||||
294 | } | ||||
295 | } | ||||
296 | return 1; | ||||
297 | } | ||||
298 | |||||
299 | =head2 guide_strand | ||||
300 | |||||
301 | Title : guide_strand | ||||
302 | Usage : $str = $loc->guide_strand(); | ||||
303 | Function: Get/Set the guide strand. Of use only if the split type is | ||||
304 | a 'join' (this helps determine the order of sublocation | ||||
305 | retrieval) | ||||
306 | Returns : value of guide strand (1, -1, or undef) | ||||
307 | Args : new value (-1 or 1, optional) | ||||
308 | |||||
309 | =cut | ||||
310 | |||||
311 | sub guide_strand { | ||||
312 | my $self = shift; | ||||
313 | return $self->{'strand'} = shift if @_; | ||||
314 | |||||
315 | # Sublocations strand values consistency check to set Guide Strand | ||||
316 | my @subloc_strands; | ||||
317 | foreach my $loc ($self->sub_Location(0)) { | ||||
318 | push @subloc_strands, $loc->strand || 1; | ||||
319 | } | ||||
320 | if ($self->isa('Bio::Location::SplitLocationI')) { | ||||
321 | my $identical = 0; | ||||
322 | my $first_value = $subloc_strands[0]; | ||||
323 | foreach my $strand (@subloc_strands) { | ||||
324 | $identical++ if ($strand == $first_value); | ||||
325 | } | ||||
326 | |||||
327 | if ($identical == scalar @subloc_strands) { | ||||
328 | $self->{'strand'} = $first_value; | ||||
329 | } | ||||
330 | else { | ||||
331 | $self->{'strand'} = undef; | ||||
332 | } | ||||
333 | } | ||||
334 | return $self->{'strand'}; | ||||
335 | } | ||||
336 | |||||
337 | =head1 LocationI methods | ||||
338 | |||||
339 | =head2 strand | ||||
340 | |||||
341 | Title : strand | ||||
342 | Usage : $obj->strand($newval) | ||||
343 | Function: For SplitLocations, setting the strand of the container | ||||
344 | (this object) is a short-cut for setting the strand of all | ||||
345 | sublocations. | ||||
346 | |||||
347 | In get-mode, checks if no sub-location is remote, and if | ||||
348 | all have the same strand. If so, it returns that shared | ||||
349 | strand value. Otherwise it returns undef. | ||||
350 | |||||
351 | Example : | ||||
352 | Returns : on get, value of strand if identical between sublocations | ||||
353 | (-1, 1, or undef) | ||||
354 | Args : new value (-1 or 1, optional) | ||||
355 | |||||
356 | |||||
357 | =cut | ||||
358 | |||||
359 | sub strand{ | ||||
360 | my ($self,$value) = @_; | ||||
361 | if( defined $value) { | ||||
362 | $self->{'strand'} = $value; | ||||
363 | # propagate to all sublocs | ||||
364 | foreach my $loc ($self->sub_Location(0)) { | ||||
365 | $loc->strand($value); | ||||
366 | } | ||||
367 | } else { | ||||
368 | my ($strand, $lstrand); | ||||
369 | foreach my $loc ($self->sub_Location(0)) { | ||||
370 | # we give up upon any location that's remote or doesn't have | ||||
371 | # the strand specified, or has a differing one set than | ||||
372 | # previously seen. | ||||
373 | # calling strand() is potentially expensive if the subloc is also | ||||
374 | # a split location, so we cache it | ||||
375 | $lstrand = $loc->strand(); | ||||
376 | if((! $lstrand) || | ||||
377 | ($strand && ($strand != $lstrand)) || | ||||
378 | $loc->is_remote()) { | ||||
379 | $strand = undef; | ||||
380 | last; | ||||
381 | } elsif(! $strand) { | ||||
382 | $strand = $lstrand; | ||||
383 | } | ||||
384 | } | ||||
385 | return $strand; | ||||
386 | } | ||||
387 | } | ||||
388 | |||||
389 | =head2 flip_strand | ||||
390 | |||||
391 | Title : flip_strand | ||||
392 | Usage : $location->flip_strand(); | ||||
393 | Function: Flip-flop a strand to the opposite. Also sets Split strand | ||||
394 | to be consistent with the sublocation strands | ||||
395 | (1, -1 or undef for mixed strand values) | ||||
396 | Returns : None | ||||
397 | Args : None | ||||
398 | |||||
399 | =cut | ||||
400 | |||||
401 | sub flip_strand { | ||||
402 | my $self = shift; | ||||
403 | my @sublocs; | ||||
404 | my @subloc_strands; | ||||
405 | |||||
406 | for my $loc ( $self->sub_Location(0) ) { | ||||
407 | # Atomic "flip_strand" now initialize strand if necessary | ||||
408 | my $new_strand = $loc->flip_strand; | ||||
409 | |||||
410 | # Store strand values for later consistency check | ||||
411 | push @sublocs, $loc; | ||||
412 | push @subloc_strands, $new_strand; | ||||
413 | } | ||||
414 | |||||
415 | # Sublocations strand values consistency check to set Guide Strand | ||||
416 | if ($self->isa('Bio::Location::SplitLocationI')) { | ||||
417 | my $identical = 0; | ||||
418 | my $first_value = $subloc_strands[0]; | ||||
419 | foreach my $strand (@subloc_strands) { | ||||
420 | $identical++ if ($strand == $first_value); | ||||
421 | } | ||||
422 | |||||
423 | if ($identical == scalar @subloc_strands) { | ||||
424 | $self->guide_strand($first_value); | ||||
425 | } | ||||
426 | else { | ||||
427 | # Mixed strand values, must reverse the sublocations order | ||||
428 | $self->guide_strand(undef); | ||||
429 | @{ $self->{_sublocations} } = reverse @sublocs; | ||||
430 | } | ||||
431 | } | ||||
432 | } | ||||
433 | |||||
434 | =head2 start | ||||
435 | |||||
436 | Title : start | ||||
437 | Usage : $start = $location->start(); | ||||
438 | Function: get the starting point of the first (sorted) sublocation | ||||
439 | Returns : integer | ||||
440 | Args : none | ||||
441 | |||||
442 | =cut | ||||
443 | |||||
444 | sub start { | ||||
445 | my ($self,$value) = @_; | ||||
446 | if( defined $value ) { | ||||
447 | $self->throw("Trying to set the starting point of a split location, ". | ||||
448 | "that is not possible, try manipulating the sub Locations"); | ||||
449 | } | ||||
450 | return $self->SUPER::start(); | ||||
451 | } | ||||
452 | |||||
453 | =head2 end | ||||
454 | |||||
455 | Title : end | ||||
456 | Usage : $end = $location->end(); | ||||
457 | Function: get the ending point of the last (sorted) sublocation | ||||
458 | Returns : integer | ||||
459 | Args : none | ||||
460 | |||||
461 | =cut | ||||
462 | |||||
463 | sub end { | ||||
464 | my ($self,$value) = @_; | ||||
465 | if( defined $value ) { | ||||
466 | $self->throw("Trying to set the ending point of a split location, ". | ||||
467 | "that is not possible, try manipulating the sub Locations"); | ||||
468 | } | ||||
469 | return $self->SUPER::end(); | ||||
470 | } | ||||
471 | |||||
472 | =head2 min_start | ||||
473 | |||||
474 | Title : min_start | ||||
475 | Usage : $min_start = $location->min_start(); | ||||
476 | Function: get the minimum starting point | ||||
477 | Returns : the minimum starting point from the contained sublocations | ||||
478 | Args : none | ||||
479 | |||||
480 | =cut | ||||
481 | |||||
482 | sub min_start { | ||||
483 | my ($self, $value) = @_; | ||||
484 | |||||
485 | if( defined $value ) { | ||||
486 | $self->throw("Trying to set the minimum starting point of a split ". | ||||
487 | "location, that is not possible, try manipulating the sub Locations"); | ||||
488 | } | ||||
489 | my @locs = $self->sub_Location(1); | ||||
490 | return $locs[0]->min_start() if @locs; | ||||
491 | return; | ||||
492 | } | ||||
493 | |||||
494 | =head2 max_start | ||||
495 | |||||
496 | Title : max_start | ||||
497 | Usage : my $maxstart = $location->max_start(); | ||||
498 | Function: Get maximum starting location of feature startpoint | ||||
499 | Returns : integer or undef if no maximum starting point. | ||||
500 | Args : none | ||||
501 | |||||
502 | =cut | ||||
503 | |||||
504 | sub max_start { | ||||
505 | my ($self,$value) = @_; | ||||
506 | |||||
507 | if( defined $value ) { | ||||
508 | $self->throw("Trying to set the maximum starting point of a split ". | ||||
509 | "location, that is not possible, try manipulating the sub Locations"); | ||||
510 | } | ||||
511 | my @locs = $self->sub_Location(1); | ||||
512 | return $locs[0]->max_start() if @locs; | ||||
513 | return; | ||||
514 | } | ||||
515 | |||||
516 | =head2 start_pos_type | ||||
517 | |||||
518 | Title : start_pos_type | ||||
519 | Usage : my $start_pos_type = $location->start_pos_type(); | ||||
520 | Function: Get start position type (ie <,>, ^) | ||||
521 | Returns : type of position coded as text | ||||
522 | ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') | ||||
523 | Args : none | ||||
524 | |||||
525 | =cut | ||||
526 | |||||
527 | sub start_pos_type { | ||||
528 | my ($self,$value) = @_; | ||||
529 | |||||
530 | if( defined $value ) { | ||||
531 | $self->throw("Trying to set the start_pos_type of a split location, ". | ||||
532 | "that is not possible, try manipulating the sub Locations"); | ||||
533 | } | ||||
534 | my @locs = $self->sub_Location(); | ||||
535 | return ( @locs ) ? $locs[0]->start_pos_type() : undef; | ||||
536 | } | ||||
537 | |||||
538 | =head2 min_end | ||||
539 | |||||
540 | Title : min_end | ||||
541 | Usage : my $minend = $location->min_end(); | ||||
542 | Function: Get minimum ending location of feature endpoint | ||||
543 | Returns : integer or undef if no minimum ending point. | ||||
544 | Args : none | ||||
545 | |||||
546 | =cut | ||||
547 | |||||
548 | sub min_end { | ||||
549 | my ($self,$value) = @_; | ||||
550 | |||||
551 | if( defined $value ) { | ||||
552 | $self->throw("Trying to set the minimum end point of a split location, ". | ||||
553 | "that is not possible, try manipulating the sub Locations"); | ||||
554 | } | ||||
555 | # reverse sort locations by largest ending to smallest ending | ||||
556 | my @locs = $self->sub_Location(-1); | ||||
557 | return $locs[0]->min_end() if @locs; | ||||
558 | return; | ||||
559 | } | ||||
560 | |||||
561 | =head2 max_end | ||||
562 | |||||
563 | Title : max_end | ||||
564 | Usage : my $maxend = $location->max_end(); | ||||
565 | Function: Get maximum ending location of feature endpoint | ||||
566 | Returns : integer or undef if no maximum ending point. | ||||
567 | Args : none | ||||
568 | |||||
569 | =cut | ||||
570 | |||||
571 | sub max_end { | ||||
572 | my ($self,$value) = @_; | ||||
573 | |||||
574 | if( defined $value ) { | ||||
575 | $self->throw("Trying to set the maximum end point of a split location, ". | ||||
576 | "that is not possible, try manipulating the sub Locations"); | ||||
577 | } | ||||
578 | # reverse sort locations by largest ending to smallest ending | ||||
579 | my @locs = $self->sub_Location(-1); | ||||
580 | return $locs[0]->max_end() if @locs; | ||||
581 | return; | ||||
582 | } | ||||
583 | |||||
584 | =head2 end_pos_type | ||||
585 | |||||
586 | Title : end_pos_type | ||||
587 | Usage : my $end_pos_type = $location->end_pos_type(); | ||||
588 | Function: Get end position type (ie <,>, ^) | ||||
589 | Returns : type of position coded as text | ||||
590 | ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') | ||||
591 | Args : none | ||||
592 | |||||
593 | =cut | ||||
594 | |||||
595 | sub end_pos_type { | ||||
596 | my ($self,$value) = @_; | ||||
597 | |||||
598 | if( defined $value ) { | ||||
599 | $self->throw("Trying to set end_pos_type of a split location, ". | ||||
600 | "that is not possible, try manipulating the sub Locations"); | ||||
601 | } | ||||
602 | my @locs = $self->sub_Location(); | ||||
603 | return ( @locs ) ? $locs[0]->end_pos_type() : undef; | ||||
604 | } | ||||
605 | |||||
606 | =head2 length | ||||
607 | |||||
608 | Title : length | ||||
609 | Usage : $len = $loc->length(); | ||||
610 | Function: get the length in the coordinate space this location spans | ||||
611 | Example : | ||||
612 | Returns : an integer | ||||
613 | Args : none | ||||
614 | |||||
615 | =cut | ||||
616 | |||||
617 | sub length { | ||||
618 | my ($self) = @_; | ||||
619 | my $length = 0; | ||||
620 | # Mixed strand values means transplicing (where exons can even | ||||
621 | # be in different chromosomes), so in that case only give the sum | ||||
622 | # of the lengths of the individual segments | ||||
623 | if (! defined $self->guide_strand) { | ||||
624 | for my $loc ( $self->sub_Location(0) ) { | ||||
625 | $length += abs($loc->end - $loc->start) + 1 | ||||
626 | } | ||||
627 | } | ||||
628 | else { | ||||
629 | my @sublocs = $self->sub_Location(0); | ||||
630 | my $start = $sublocs[0]->start; | ||||
631 | my $end = $sublocs[-1]->end; | ||||
632 | |||||
633 | # If Start > ·End, its a possible case of cut by origin | ||||
634 | # location in circular sequences (e.g "join(16..20,1..2)") | ||||
635 | if ($start > $end) { | ||||
636 | # Figure out which segments are located before | ||||
637 | # and which are located after coordinate 1 | ||||
638 | # (END_SEQ - 1 - START_SEQ) | ||||
639 | my @end_seq_segments; | ||||
640 | my @start_seq_segments; | ||||
641 | my $switch = 0; | ||||
642 | foreach my $subloc (@sublocs) { | ||||
643 | if ($switch == 0) { | ||||
644 | if ($subloc->start == 1) { | ||||
645 | $switch = 1; | ||||
646 | push @start_seq_segments, $subloc; | ||||
647 | } | ||||
648 | else { | ||||
649 | push @end_seq_segments, $subloc; | ||||
650 | } | ||||
651 | } | ||||
652 | else { | ||||
653 | push @start_seq_segments, $subloc; | ||||
654 | } | ||||
655 | } | ||||
656 | |||||
657 | # If its a cut by origin location, sum the whole length of each group | ||||
658 | if (scalar @end_seq_segments > 0 and @start_seq_segments > 0) { | ||||
659 | my $end_segments_length = abs( $end_seq_segments[0]->start | ||||
660 | - $end_seq_segments[-1]->end) | ||||
661 | + 1; | ||||
662 | my $start_segments_length = abs( $start_seq_segments[0]->start | ||||
663 | - $start_seq_segments[-1]->end) | ||||
664 | + 1; | ||||
665 | $length = $end_segments_length + $start_segments_length; | ||||
666 | } | ||||
667 | } | ||||
668 | else { | ||||
669 | $length = $end - $start + 1; | ||||
670 | } | ||||
671 | } | ||||
672 | |||||
673 | # If for some reason nothing worked, fall back to previous behaviour | ||||
674 | if ($length == 0) { | ||||
675 | $length = abs($self->end - $self->start) + 1 | ||||
676 | } | ||||
677 | |||||
678 | return $length; | ||||
679 | } | ||||
680 | |||||
681 | =head2 seq_id | ||||
682 | |||||
683 | Title : seq_id | ||||
684 | Usage : my $seqid = $location->seq_id(); | ||||
685 | Function: Get/Set seq_id that location refers to | ||||
686 | |||||
687 | We override this here in order to propagate to all sublocations | ||||
688 | which are not remote (provided this root is not remote either) | ||||
689 | Returns : seq_id | ||||
690 | Args : [optional] seq_id value to set | ||||
691 | |||||
692 | |||||
693 | =cut | ||||
694 | |||||
695 | sub seq_id { | ||||
696 | my $self = shift; | ||||
697 | |||||
698 | if(@_ && !$self->is_remote()) { | ||||
699 | foreach my $subloc ($self->sub_Location(0)) { | ||||
700 | $subloc->seq_id(@_) if !$subloc->is_remote(); | ||||
701 | } | ||||
702 | } | ||||
703 | return $self->SUPER::seq_id(@_); | ||||
704 | } | ||||
705 | |||||
706 | =head2 coordinate_policy | ||||
707 | |||||
708 | Title : coordinate_policy | ||||
709 | Usage : $policy = $location->coordinate_policy(); | ||||
710 | $location->coordinate_policy($mypolicy); # set may not be possible | ||||
711 | Function: Get the coordinate computing policy employed by this object. | ||||
712 | |||||
713 | See Bio::Location::CoordinatePolicyI for documentation about | ||||
714 | the policy object and its use. | ||||
715 | |||||
716 | The interface *does not* require implementing classes to accept | ||||
717 | setting of a different policy. The implementation provided here | ||||
718 | does, however, allow to do so. | ||||
719 | |||||
720 | Implementors of this interface are expected to initialize every | ||||
721 | new instance with a CoordinatePolicyI object. The implementation | ||||
722 | provided here will return a default policy object if none has | ||||
723 | been set yet. To change this default policy object call this | ||||
724 | method as a class method with an appropriate argument. Note that | ||||
725 | in this case only subsequently created Location objects will be | ||||
726 | affected. | ||||
727 | |||||
728 | Returns : A Bio::Location::CoordinatePolicyI implementing object. | ||||
729 | Args : On set, a Bio::Location::CoordinatePolicyI implementing object. | ||||
730 | |||||
731 | =head2 to_FTstring | ||||
732 | |||||
733 | Title : to_FTstring | ||||
734 | Usage : my $locstr = $location->to_FTstring() | ||||
735 | Function: returns the FeatureTable string of this location | ||||
736 | Returns : string | ||||
737 | Args : none | ||||
738 | |||||
739 | =cut | ||||
740 | |||||
741 | sub to_FTstring { | ||||
742 | my ($self) = @_; | ||||
743 | my @strs; | ||||
744 | my $strand = $self->strand() || 0; | ||||
745 | my $stype = lc($self->splittype()); | ||||
746 | |||||
747 | if( $strand < 0 ) { | ||||
748 | $self->flip_strand; # this will recursively set the strand | ||||
749 | # to +1 for all the sub locations | ||||
750 | } | ||||
751 | |||||
752 | foreach my $loc ( $self->sub_Location(0) ) { | ||||
753 | $loc->verbose($self->verbose); | ||||
754 | my $str = $loc->to_FTstring(); | ||||
755 | # we only append the remote seq_id if it hasn't been done already | ||||
756 | # by the sub-location (which it should if it knows it's remote) | ||||
757 | # (and of course only if it's necessary) | ||||
758 | if( (! $loc->is_remote) && | ||||
759 | defined($self->seq_id) && defined($loc->seq_id) && | ||||
760 | ($loc->seq_id ne $self->seq_id) ) { | ||||
761 | $str = sprintf("%s:%s", $loc->seq_id, $str); | ||||
762 | } | ||||
763 | push @strs, $str; | ||||
764 | } | ||||
765 | $self->flip_strand if $strand < 0; | ||||
766 | my $str; | ||||
767 | if( @strs == 1 ) { | ||||
768 | ($str) = @strs; | ||||
769 | } elsif( @strs == 0 ) { | ||||
770 | $self->warn("no Sublocations for this splitloc, so not returning anything\n"); | ||||
771 | } else { | ||||
772 | $str = sprintf("%s(%s)",lc $self->splittype, join(",", @strs)); | ||||
773 | } | ||||
774 | if( $strand < 0 ) { # wrap this in a complement if it was unrolled | ||||
775 | $str = sprintf("%s(%s)",'complement',$str); | ||||
776 | } | ||||
777 | |||||
778 | return $str; | ||||
779 | } | ||||
780 | |||||
781 | =head2 valid_Location | ||||
782 | |||||
783 | Title : valid_Location | ||||
784 | Usage : if ($location->valid_location) {...}; | ||||
785 | Function: boolean method to determine whether location is considered valid | ||||
786 | (has minimum requirements for Simple implementation) | ||||
787 | Returns : Boolean value: true if location is valid, false otherwise | ||||
788 | Args : none | ||||
789 | |||||
790 | =cut | ||||
791 | |||||
792 | # we'll probably need to override the RangeI methods since our locations will | ||||
793 | # not be contiguous. | ||||
794 | |||||
795 | 1 | 4µs | 1; |