| Filename | /Users/ap13/perl5/lib/perl5/Bio/Location/Atomic.pm |
| Statements | Executed 8 statements in 1.62ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 278µs | 726µs | Bio::Location::Atomic::BEGIN@79 |
| 1 | 1 | 1 | 16µs | 28µs | Bio::Location::Atomic::BEGIN@77 |
| 1 | 1 | 1 | 11µs | 3.78ms | Bio::Location::Atomic::BEGIN@81 |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::coordinate_policy |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::each_Location |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::end_pos_type |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::flip_strand |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::is_remote |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::length |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::location_type |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::max_end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::max_start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::min_end |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::min_start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::new |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::seq_id |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::start |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::start_pos_type |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::strand |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::to_FTstring |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::trunc |
| 0 | 0 | 0 | 0s | 0s | Bio::Location::Atomic::valid_Location |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | # | ||||
| 2 | # BioPerl module for Bio::Location::Atomic | ||||
| 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::Atomic - Implementation of a Atomic Location on a Sequence | ||||
| 15 | |||||
| 16 | =head1 SYNOPSIS | ||||
| 17 | |||||
| 18 | use Bio::Location::Atomic; | ||||
| 19 | |||||
| 20 | my $location = Bio::Location::Atomic->new(-start => 1, -end => 100, | ||||
| 21 | -strand => 1 ); | ||||
| 22 | |||||
| 23 | if( $location->strand == -1 ) { | ||||
| 24 | printf "complement(%d..%d)\n", $location->start, $location->end; | ||||
| 25 | } else { | ||||
| 26 | printf "%d..%d\n", $location->start, $location->end; | ||||
| 27 | } | ||||
| 28 | |||||
| 29 | =head1 DESCRIPTION | ||||
| 30 | |||||
| 31 | This is an implementation of Bio::LocationI to manage simple location | ||||
| 32 | information on a Sequence. | ||||
| 33 | |||||
| 34 | =head1 FEEDBACK | ||||
| 35 | |||||
| 36 | User feedback is an integral part of the evolution of this and other | ||||
| 37 | Bioperl modules. Send your comments and suggestions preferably to one | ||||
| 38 | of the Bioperl mailing lists. Your participation is much appreciated. | ||||
| 39 | |||||
| 40 | bioperl-l@bioperl.org - General discussion | ||||
| 41 | http://bioperl.org/wiki/Mailing_lists - About the mailing lists | ||||
| 42 | |||||
| 43 | =head2 Support | ||||
| 44 | |||||
| 45 | Please direct usage questions or support issues to the mailing list: | ||||
| 46 | |||||
| 47 | I<bioperl-l@bioperl.org> | ||||
| 48 | |||||
| 49 | rather than to the module maintainer directly. Many experienced and | ||||
| 50 | reponsive experts will be able look at the problem and quickly | ||||
| 51 | address it. Please include a thorough description of the problem | ||||
| 52 | with code and data examples if at all possible. | ||||
| 53 | |||||
| 54 | =head2 Reporting Bugs | ||||
| 55 | |||||
| 56 | Report bugs to the Bioperl bug tracking system to help us keep track | ||||
| 57 | the bugs and their resolution. Bug reports can be submitted via the | ||||
| 58 | web: | ||||
| 59 | |||||
| 60 | https://github.com/bioperl/bioperl-live/issues | ||||
| 61 | |||||
| 62 | =head1 AUTHOR - Jason Stajich | ||||
| 63 | |||||
| 64 | Email jason-at-bioperl-dot-org | ||||
| 65 | |||||
| 66 | =head1 APPENDIX | ||||
| 67 | |||||
| 68 | The rest of the documentation details each of the object | ||||
| 69 | methods. Internal methods are usually preceded with a _ | ||||
| 70 | |||||
| 71 | =cut | ||||
| 72 | |||||
| 73 | # Let the code begin... | ||||
| 74 | |||||
| 75 | |||||
| 76 | package Bio::Location::Atomic; | ||||
| 77 | 2 | 23µs | 2 | 40µs | # spent 28µs (16+11) within Bio::Location::Atomic::BEGIN@77 which was called:
# once (16µs+11µs) by base::import at line 77 # spent 28µs making 1 call to Bio::Location::Atomic::BEGIN@77
# spent 12µs making 1 call to strict::import |
| 78 | |||||
| 79 | 2 | 157µs | 1 | 726µs | # spent 726µs (278+448) within Bio::Location::Atomic::BEGIN@79 which was called:
# once (278µs+448µs) by base::import at line 79 # spent 726µs making 1 call to Bio::Location::Atomic::BEGIN@79 |
| 80 | |||||
| 81 | 2 | 1.43ms | 2 | 3.78ms | # spent 3.78ms (11µs+3.77) within Bio::Location::Atomic::BEGIN@81 which was called:
# once (11µs+3.77ms) by base::import at line 81 # spent 3.78ms making 1 call to Bio::Location::Atomic::BEGIN@81
# spent 3.77ms making 1 call to base::import, recursion: max depth 1, sum of overlapping time 3.77ms |
| 82 | |||||
| 83 | 1 | 5µs | 1 | 42µs | our $coord_policy = Bio::Location::WidestCoordPolicy->new(); # spent 42µs making 1 call to Bio::Location::WidestCoordPolicy::new |
| 84 | |||||
| 85 | sub new { | ||||
| 86 | my ($class, @args) = @_; | ||||
| 87 | $class = ref $class || $class; | ||||
| 88 | my $self = {}; | ||||
| 89 | # This is for the case when we've done something like this | ||||
| 90 | # get a 2 features from somewhere (like Bio::Tools::GFF) | ||||
| 91 | # Do | ||||
| 92 | # my $location = $f1->location->union($f2->location); | ||||
| 93 | # We get an error without the following code which | ||||
| 94 | # explictly loads the Bio::Location::Simple class | ||||
| 95 | unless( $class->can('start') ) { | ||||
| 96 | eval { Bio::Root::Root->_load_module($class) }; | ||||
| 97 | if ( $@ ) { | ||||
| 98 | Bio::Root::Root->throw("$class cannot be found\nException $@"); | ||||
| 99 | } | ||||
| 100 | } | ||||
| 101 | bless $self,$class; | ||||
| 102 | |||||
| 103 | my ($v,$start,$end,$strand,$seqid) = $self->_rearrange([qw(VERBOSE | ||||
| 104 | START | ||||
| 105 | END | ||||
| 106 | STRAND | ||||
| 107 | SEQ_ID)],@args); | ||||
| 108 | defined $v && $self->verbose($v); | ||||
| 109 | defined $strand && $self->strand($strand); | ||||
| 110 | |||||
| 111 | defined $start && $self->start($start); | ||||
| 112 | defined $end && $self->end($end); | ||||
| 113 | if( defined $self->start && defined $self->end && | ||||
| 114 | $self->start > $self->end && $self->strand != -1 ) { | ||||
| 115 | $self->warn("When building a location, start ($start) is expected to be less than end ($end), ". | ||||
| 116 | "however it was not. Switching start and end and setting strand to -1"); | ||||
| 117 | |||||
| 118 | $self->strand(-1); | ||||
| 119 | my $e = $self->end; | ||||
| 120 | my $s = $self->start; | ||||
| 121 | $self->start($e); | ||||
| 122 | $self->end($s); | ||||
| 123 | } | ||||
| 124 | $seqid && $self->seq_id($seqid); | ||||
| 125 | |||||
| 126 | return $self; | ||||
| 127 | } | ||||
| 128 | |||||
| 129 | =head2 start | ||||
| 130 | |||||
| 131 | Title : start | ||||
| 132 | Usage : $start = $loc->start(); | ||||
| 133 | Function: get/set the start of this range | ||||
| 134 | Returns : the start of this range | ||||
| 135 | Args : optionaly allows the start to be set | ||||
| 136 | : using $loc->start($start) | ||||
| 137 | |||||
| 138 | =cut | ||||
| 139 | |||||
| 140 | sub start { | ||||
| 141 | my ($self, $value) = @_; | ||||
| 142 | $self->min_start($value) if( defined $value ); | ||||
| 143 | return $self->SUPER::start(); | ||||
| 144 | } | ||||
| 145 | |||||
| 146 | =head2 end | ||||
| 147 | |||||
| 148 | Title : end | ||||
| 149 | Usage : $end = $loc->end(); | ||||
| 150 | Function: get/set the end of this range | ||||
| 151 | Returns : the end of this range | ||||
| 152 | Args : optionaly allows the end to be set | ||||
| 153 | : using $loc->end($start) | ||||
| 154 | |||||
| 155 | =cut | ||||
| 156 | |||||
| 157 | sub end { | ||||
| 158 | my ($self, $value) = @_; | ||||
| 159 | |||||
| 160 | $self->min_end($value) if( defined $value ); | ||||
| 161 | return $self->SUPER::end(); | ||||
| 162 | } | ||||
| 163 | |||||
| 164 | =head2 strand | ||||
| 165 | |||||
| 166 | Title : strand | ||||
| 167 | Usage : $strand = $loc->strand(); | ||||
| 168 | Function: get/set the strand of this range | ||||
| 169 | Returns : the strandidness (-1, 0, +1) | ||||
| 170 | Args : optionaly allows the strand to be set | ||||
| 171 | : using $loc->strand($strand) | ||||
| 172 | |||||
| 173 | =cut | ||||
| 174 | |||||
| 175 | sub strand { | ||||
| 176 | my $self = shift; | ||||
| 177 | |||||
| 178 | if ( @_ ) { | ||||
| 179 | my $value = shift; | ||||
| 180 | if ( defined($value) ) { | ||||
| 181 | if ( $value eq '+' ) { $value = 1; } | ||||
| 182 | elsif ( $value eq '-' ) { $value = -1; } | ||||
| 183 | elsif ( $value eq '.' ) { $value = 0; } | ||||
| 184 | elsif ( $value != -1 && $value != 1 && $value != 0 ) { | ||||
| 185 | $self->throw("$value is not a valid strand info"); | ||||
| 186 | } | ||||
| 187 | $self->{'_strand'} = $value; | ||||
| 188 | } | ||||
| 189 | } | ||||
| 190 | # do not pretend the strand has been set if in fact it wasn't | ||||
| 191 | return $self->{'_strand'}; | ||||
| 192 | #return $self->{'_strand'} || 0; | ||||
| 193 | } | ||||
| 194 | |||||
| 195 | =head2 flip_strand | ||||
| 196 | |||||
| 197 | Title : flip_strand | ||||
| 198 | Usage : $location->flip_strand(); | ||||
| 199 | Function: Flip-flop a strand to the opposite | ||||
| 200 | Returns : None | ||||
| 201 | Args : None | ||||
| 202 | |||||
| 203 | =cut | ||||
| 204 | |||||
| 205 | |||||
| 206 | sub flip_strand { | ||||
| 207 | my $self= shift; | ||||
| 208 | # Initialize strand if necessary to flip it | ||||
| 209 | if (not defined $self->strand) { | ||||
| 210 | $self->strand(1) | ||||
| 211 | } | ||||
| 212 | $self->strand($self->strand * -1); | ||||
| 213 | } | ||||
| 214 | |||||
| 215 | |||||
| 216 | =head2 seq_id | ||||
| 217 | |||||
| 218 | Title : seq_id | ||||
| 219 | Usage : my $seqid = $location->seq_id(); | ||||
| 220 | Function: Get/Set seq_id that location refers to | ||||
| 221 | Returns : seq_id (a string) | ||||
| 222 | Args : [optional] seq_id value to set | ||||
| 223 | |||||
| 224 | =cut | ||||
| 225 | |||||
| 226 | |||||
| 227 | sub seq_id { | ||||
| 228 | my ($self, $seqid) = @_; | ||||
| 229 | if( defined $seqid ) { | ||||
| 230 | $self->{'_seqid'} = $seqid; | ||||
| 231 | } | ||||
| 232 | return $self->{'_seqid'}; | ||||
| 233 | } | ||||
| 234 | |||||
| 235 | =head2 length | ||||
| 236 | |||||
| 237 | Title : length | ||||
| 238 | Usage : $len = $loc->length(); | ||||
| 239 | Function: get the length in the coordinate space this location spans | ||||
| 240 | Example : | ||||
| 241 | Returns : an integer | ||||
| 242 | Args : none | ||||
| 243 | |||||
| 244 | |||||
| 245 | =cut | ||||
| 246 | |||||
| 247 | sub length { | ||||
| 248 | my ($self) = @_; | ||||
| 249 | return abs($self->end() - $self->start()) + 1; | ||||
| 250 | } | ||||
| 251 | |||||
| 252 | =head2 min_start | ||||
| 253 | |||||
| 254 | Title : min_start | ||||
| 255 | Usage : my $minstart = $location->min_start(); | ||||
| 256 | Function: Get minimum starting location of feature startpoint | ||||
| 257 | Returns : integer or undef if no minimum starting point. | ||||
| 258 | Args : none | ||||
| 259 | |||||
| 260 | =cut | ||||
| 261 | |||||
| 262 | sub min_start { | ||||
| 263 | my ($self,$value) = @_; | ||||
| 264 | |||||
| 265 | if(defined($value)) { | ||||
| 266 | $self->{'_start'} = $value; | ||||
| 267 | } | ||||
| 268 | return $self->{'_start'}; | ||||
| 269 | } | ||||
| 270 | |||||
| 271 | =head2 max_start | ||||
| 272 | |||||
| 273 | Title : max_start | ||||
| 274 | Usage : my $maxstart = $location->max_start(); | ||||
| 275 | Function: Get maximum starting location of feature startpoint. | ||||
| 276 | |||||
| 277 | In this implementation this is exactly the same as min_start(). | ||||
| 278 | |||||
| 279 | Returns : integer or undef if no maximum starting point. | ||||
| 280 | Args : none | ||||
| 281 | |||||
| 282 | =cut | ||||
| 283 | |||||
| 284 | sub max_start { | ||||
| 285 | my ($self,@args) = @_; | ||||
| 286 | return $self->min_start(@args); | ||||
| 287 | } | ||||
| 288 | |||||
| 289 | =head2 start_pos_type | ||||
| 290 | |||||
| 291 | Title : start_pos_type | ||||
| 292 | Usage : my $start_pos_type = $location->start_pos_type(); | ||||
| 293 | Function: Get start position type (ie <,>, ^). | ||||
| 294 | |||||
| 295 | In this implementation this will always be 'EXACT'. | ||||
| 296 | |||||
| 297 | Returns : type of position coded as text | ||||
| 298 | ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') | ||||
| 299 | Args : none | ||||
| 300 | |||||
| 301 | =cut | ||||
| 302 | |||||
| 303 | sub start_pos_type { | ||||
| 304 | my($self) = @_; | ||||
| 305 | return 'EXACT'; | ||||
| 306 | } | ||||
| 307 | |||||
| 308 | =head2 min_end | ||||
| 309 | |||||
| 310 | Title : min_end | ||||
| 311 | Usage : my $minend = $location->min_end(); | ||||
| 312 | Function: Get minimum ending location of feature endpoint | ||||
| 313 | Returns : integer or undef if no minimum ending point. | ||||
| 314 | Args : none | ||||
| 315 | |||||
| 316 | =cut | ||||
| 317 | |||||
| 318 | sub min_end { | ||||
| 319 | my($self,$value) = @_; | ||||
| 320 | |||||
| 321 | if(defined($value)) { | ||||
| 322 | $self->{'_end'} = $value; | ||||
| 323 | } | ||||
| 324 | return $self->{'_end'}; | ||||
| 325 | } | ||||
| 326 | |||||
| 327 | =head2 max_end | ||||
| 328 | |||||
| 329 | Title : max_end | ||||
| 330 | Usage : my $maxend = $location->max_end(); | ||||
| 331 | Function: Get maximum ending location of feature endpoint | ||||
| 332 | |||||
| 333 | In this implementation this is exactly the same as min_end(). | ||||
| 334 | |||||
| 335 | Returns : integer or undef if no maximum ending point. | ||||
| 336 | Args : none | ||||
| 337 | |||||
| 338 | =cut | ||||
| 339 | |||||
| 340 | sub max_end { | ||||
| 341 | my($self,@args) = @_; | ||||
| 342 | return $self->min_end(@args); | ||||
| 343 | } | ||||
| 344 | |||||
| 345 | =head2 end_pos_type | ||||
| 346 | |||||
| 347 | Title : end_pos_type | ||||
| 348 | Usage : my $end_pos_type = $location->end_pos_type(); | ||||
| 349 | Function: Get end position type (ie <,>, ^) | ||||
| 350 | |||||
| 351 | In this implementation this will always be 'EXACT'. | ||||
| 352 | |||||
| 353 | Returns : type of position coded as text | ||||
| 354 | ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') | ||||
| 355 | Args : none | ||||
| 356 | |||||
| 357 | =cut | ||||
| 358 | |||||
| 359 | sub end_pos_type { | ||||
| 360 | my($self) = @_; | ||||
| 361 | return 'EXACT'; | ||||
| 362 | } | ||||
| 363 | |||||
| 364 | =head2 location_type | ||||
| 365 | |||||
| 366 | Title : location_type | ||||
| 367 | Usage : my $location_type = $location->location_type(); | ||||
| 368 | Function: Get location type encoded as text | ||||
| 369 | Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN') | ||||
| 370 | Args : none | ||||
| 371 | |||||
| 372 | =cut | ||||
| 373 | |||||
| 374 | sub location_type { | ||||
| 375 | my ($self) = @_; | ||||
| 376 | return 'EXACT'; | ||||
| 377 | } | ||||
| 378 | |||||
| 379 | =head2 is_remote | ||||
| 380 | |||||
| 381 | Title : is_remote | ||||
| 382 | Usage : $is_remote_loc = $loc->is_remote() | ||||
| 383 | Function: Whether or not a location is a remote location. | ||||
| 384 | |||||
| 385 | A location is said to be remote if it is on a different | ||||
| 386 | 'object' than the object which 'has' this | ||||
| 387 | location. Typically, features on a sequence will sometimes | ||||
| 388 | have a remote location, which means that the location of | ||||
| 389 | the feature is on a different sequence than the one that is | ||||
| 390 | attached to the feature. In such a case, $loc->seq_id will | ||||
| 391 | be different from $feat->seq_id (usually they will be the | ||||
| 392 | same). | ||||
| 393 | |||||
| 394 | While this may sound weird, it reflects the location of the | ||||
| 395 | kind of AL445212.9:83662..166657 which can be found in GenBank/EMBL | ||||
| 396 | feature tables. | ||||
| 397 | |||||
| 398 | Example : | ||||
| 399 | Returns : TRUE if the location is a remote location, and FALSE otherwise | ||||
| 400 | Args : Value to set to | ||||
| 401 | |||||
| 402 | =cut | ||||
| 403 | |||||
| 404 | sub is_remote { | ||||
| 405 | my $self = shift; | ||||
| 406 | if( @_ ) { | ||||
| 407 | my $value = shift; | ||||
| 408 | $self->{'is_remote'} = $value; | ||||
| 409 | } | ||||
| 410 | return $self->{'is_remote'}; | ||||
| 411 | } | ||||
| 412 | |||||
| 413 | =head2 each_Location | ||||
| 414 | |||||
| 415 | Title : each_Location | ||||
| 416 | Usage : @locations = $locObject->each_Location($order); | ||||
| 417 | Function: Conserved function call across Location:: modules - will | ||||
| 418 | return an array containing the component Location(s) in | ||||
| 419 | that object, regardless if the calling object is itself a | ||||
| 420 | single location or one containing sublocations. | ||||
| 421 | Returns : an array of Bio::LocationI implementing objects - for | ||||
| 422 | Simple locations, the return value is just itself. | ||||
| 423 | Args : | ||||
| 424 | |||||
| 425 | =cut | ||||
| 426 | |||||
| 427 | sub each_Location { | ||||
| 428 | my ($self) = @_; | ||||
| 429 | return ($self); | ||||
| 430 | } | ||||
| 431 | |||||
| 432 | =head2 to_FTstring | ||||
| 433 | |||||
| 434 | Title : to_FTstring | ||||
| 435 | Usage : my $locstr = $location->to_FTstring() | ||||
| 436 | Function: returns the FeatureTable string of this location | ||||
| 437 | Returns : string | ||||
| 438 | Args : none | ||||
| 439 | |||||
| 440 | =cut | ||||
| 441 | |||||
| 442 | sub to_FTstring { | ||||
| 443 | my($self) = @_; | ||||
| 444 | if( $self->start == $self->end ) { | ||||
| 445 | return $self->start; | ||||
| 446 | } | ||||
| 447 | my $str = $self->start . ".." . $self->end; | ||||
| 448 | if( $self->strand == -1 ) { | ||||
| 449 | $str = sprintf("complement(%s)", $str); | ||||
| 450 | } | ||||
| 451 | return $str; | ||||
| 452 | } | ||||
| 453 | |||||
| 454 | =head2 valid_Location | ||||
| 455 | |||||
| 456 | Title : valid_Location | ||||
| 457 | Usage : if ($location->valid_location) {...}; | ||||
| 458 | Function: boolean method to determine whether location is considered valid | ||||
| 459 | (has minimum requirements for Simple implementation) | ||||
| 460 | Returns : Boolean value: true if location is valid, false otherwise | ||||
| 461 | Args : none | ||||
| 462 | |||||
| 463 | =cut | ||||
| 464 | |||||
| 465 | sub valid_Location { | ||||
| 466 | my ($self) = @_; | ||||
| 467 | return 1 if $self->{'_start'} && $self->{'_end'}; | ||||
| 468 | return 0; | ||||
| 469 | } | ||||
| 470 | |||||
| 471 | =head2 coordinate_policy | ||||
| 472 | |||||
| 473 | Title : coordinate_policy | ||||
| 474 | Usage : $policy = $location->coordinate_policy(); | ||||
| 475 | $location->coordinate_policy($mypolicy); # set may not be possible | ||||
| 476 | Function: Get the coordinate computing policy employed by this object. | ||||
| 477 | |||||
| 478 | See L<Bio::Location::CoordinatePolicyI> for documentation | ||||
| 479 | about the policy object and its use. | ||||
| 480 | |||||
| 481 | The interface *does not* require implementing classes to | ||||
| 482 | accept setting of a different policy. The implementation | ||||
| 483 | provided here does, however, allow to do so. | ||||
| 484 | |||||
| 485 | Implementors of this interface are expected to initialize | ||||
| 486 | every new instance with a | ||||
| 487 | L<Bio::Location::CoordinatePolicyI> object. The | ||||
| 488 | implementation provided here will return a default policy | ||||
| 489 | object if none has been set yet. To change this default | ||||
| 490 | policy object call this method as a class method with an | ||||
| 491 | appropriate argument. Note that in this case only | ||||
| 492 | subsequently created Location objects will be affected. | ||||
| 493 | |||||
| 494 | Returns : A L<Bio::Location::CoordinatePolicyI> implementing object. | ||||
| 495 | Args : On set, a L<Bio::Location::CoordinatePolicyI> implementing object. | ||||
| 496 | |||||
| 497 | See L<Bio::Location::CoordinatePolicyI> for more information | ||||
| 498 | |||||
| 499 | |||||
| 500 | =cut | ||||
| 501 | |||||
| 502 | sub coordinate_policy { | ||||
| 503 | my ($self, $policy) = @_; | ||||
| 504 | |||||
| 505 | if(defined($policy)) { | ||||
| 506 | if(! $policy->isa('Bio::Location::CoordinatePolicyI')) { | ||||
| 507 | $self->throw("Object of class ".ref($policy)." does not implement". | ||||
| 508 | " Bio::Location::CoordinatePolicyI"); | ||||
| 509 | } | ||||
| 510 | if(ref($self)) { | ||||
| 511 | $self->{'_coordpolicy'} = $policy; | ||||
| 512 | } else { | ||||
| 513 | # called as class method | ||||
| 514 | $coord_policy = $policy; | ||||
| 515 | } | ||||
| 516 | } | ||||
| 517 | return (ref($self) && exists($self->{'_coordpolicy'}) ? | ||||
| 518 | $self->{'_coordpolicy'} : $coord_policy); | ||||
| 519 | } | ||||
| 520 | |||||
| 521 | =head2 trunc | ||||
| 522 | |||||
| 523 | Title : trunc | ||||
| 524 | Usage : $trunc_location = $location->trunc($start, $end, $relative_ori); | ||||
| 525 | Function: To truncate a location and keep annotations and features | ||||
| 526 | within the truncated segment intact. | ||||
| 527 | |||||
| 528 | This might do things differently where the truncation | ||||
| 529 | splits the location in half. | ||||
| 530 | CAVEAT : As yet, this is an untested and unannounced method. Use | ||||
| 531 | with caution! | ||||
| 532 | Returns : A L<Bio::Location::Atomic> object. | ||||
| 533 | Args : The start and end position for the trunction, and the relative | ||||
| 534 | orientation. | ||||
| 535 | |||||
| 536 | =cut | ||||
| 537 | |||||
| 538 | sub trunc { | ||||
| 539 | my ($self,$start,$end,$relative_ori) = @_; | ||||
| 540 | |||||
| 541 | my $newstart = $self->start - $start+1; | ||||
| 542 | my $newend = $self->end - $start+1; | ||||
| 543 | my $newstrand = $relative_ori * $self->strand; | ||||
| 544 | |||||
| 545 | my $out; | ||||
| 546 | if( $newstart < 1 || $newend > ($end-$start+1) ) { | ||||
| 547 | $out = Bio::Location::Atomic->new(); | ||||
| 548 | $out->start($self->start); | ||||
| 549 | $out->end($self->end); | ||||
| 550 | $out->strand($self->strand); | ||||
| 551 | $out->seq_id($self->seqid); | ||||
| 552 | $out->is_remote(1); | ||||
| 553 | } else { | ||||
| 554 | $out = Bio::Location::Atomic->new(); | ||||
| 555 | $out->start($newstart); | ||||
| 556 | $out->end($newend); | ||||
| 557 | $out->strand($newstrand); | ||||
| 558 | $out->seq_id(); | ||||
| 559 | } | ||||
| 560 | |||||
| 561 | return $out; | ||||
| 562 | } | ||||
| 563 | |||||
| 564 | 1 | 4µs | 1; |