| 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 | Bio::Location::Split::BEGIN@99 |
| 1 | 1 | 1 | 8µs | 581µs | Bio::Location::Split::BEGIN@101 |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::add_sub_Location |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::each_Location |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::end_pos_type |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::flip_strand |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::guide_strand |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::is_single_sequence |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::length |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::max_end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::max_start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::min_end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::min_start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::new |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::seq_id |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::splittype |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::start_pos_type |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::strand |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::sub_Location |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Split::to_FTstring |
| 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; |