lib/Bio/Location/Atomic.pm

   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
  78 use strict;
  79
  80 use Bio::Location::WidestCoordPolicy;
  81
  82 use base qw(Bio::Root::Root Bio::LocationI);
  83
  84 our $coord_policy = Bio::Location::WidestCoordPolicy->new();
  85
  86 sub new {
  87     my ($class, @args) = @_;
  88     $class = ref $class || $class;
  89     my $self = {};
  90     # This is for the case when we've done something like this
  91     # get a 2 features from somewhere (like Bio::Tools::GFF)
  92     # Do
  93     # my $location = $f1->location->union($f2->location);
  94     # We get an error without the following code which
  95     # explicitly loads the Bio::Location::Simple class
  96     unless( $class->can('start') ) {
  97         eval { Bio::Root::Root->_load_module($class) };
  98         if ( $@ ) {
  99             Bio::Root::Root->throw("$class cannot be found\nException $@");
 100         }
 101     }
 102     bless $self,$class;
 103
 104     my ($v,$start,$end,$strand,$seqid) = $self->_rearrange([qw(VERBOSE
 105                                                                START
 106                                                                END
 107                                                                STRAND
 108                                                                SEQ_ID)],@args);
 109     defined $v && $self->verbose($v);
 110     defined $strand && $self->strand($strand);
 111
 112     defined $start  && $self->start($start);
 113     defined $end    && $self->end($end);
 114     if( defined $self->start && defined $self->end &&
 115         $self->start > $self->end && $self->strand != -1 ) {
 116         $self->warn("When building a location, start ($start) is expected to be less than end ($end), ".
 117                     "however it was not. Switching start and end and setting strand to -1");
 118
 119         $self->strand(-1);
 120         my $e = $self->end;
 121         my $s = $self->start;
 122         $self->start($e);
 123         $self->end($s);
 124     }
 125     $seqid          && $self->seq_id($seqid);
 126
 127     return $self;
 128 }
 129
 130 =head2 start
 131
 132   Title   : start
 133   Usage   : $start = $loc->start();
 134   Function: get/set the start of this range
 135   Returns : the start of this range
 136   Args    : optionally allows the start to be set
 137           : using $loc->start($start)
 138
 139 =cut
 140
 141 sub start {
 142   my ($self, $value) = @_;
 143   $self->min_start($value) if( defined $value );
 144   return $self->SUPER::start();
 145 }
 146
 147 =head2 end
 148
 149   Title   : end
 150   Usage   : $end = $loc->end();
 151   Function: get/set the end of this range
 152   Returns : the end of this range
 153   Args    : optionally allows the end to be set
 154           : using $loc->end($start)
 155
 156 =cut
 157
 158 sub end {
 159   my ($self, $value) = @_;
 160
 161   $self->min_end($value) if( defined $value );
 162   return $self->SUPER::end();
 163 }
 164
 165 =head2 strand
 166
 167   Title   : strand
 168   Usage   : $strand = $loc->strand();
 169   Function: get/set the strand of this range
 170   Returns : the strandidness (-1, 0, +1)
 171   Args    : optionally allows the strand to be set
 172           : using $loc->strand($strand)
 173
 174 =cut
 175
 176 sub strand {
 177   my $self = shift;
 178
 179   if ( @_ ) {
 180        my $value = shift;
 181        if ( defined($value) ) {
 182            if ( $value eq '+' ) { $value = 1; }
 183            elsif ( $value eq '-' ) { $value = -1; }
 184            elsif ( $value eq '.' ) { $value = 0; }
 185            elsif ( $value != -1 && $value != 1 && $value != 0 ) {
 186                $self->throw("$value is not a valid strand info");
 187            }
 188            $self->{'_strand'} = $value;
 189        }
 190   }
 191   # do not pretend the strand has been set if in fact it wasn't
 192   return $self->{'_strand'};
 193   #return $self->{'_strand'} || 0;
 194 }
 195
 196 =head2 flip_strand
 197
 198   Title   : flip_strand
 199   Usage   : $location->flip_strand();
 200   Function: Flip-flop a strand to the opposite
 201   Returns : None
 202   Args    : None
 203
 204 =cut
 205
 206
 207 sub flip_strand {
 208     my $self= shift;
 209     # Initialize strand if necessary to flip it
 210     if (not defined $self->strand) {
 211         $self->strand(1)
 212     }
 213     $self->strand($self->strand * -1);
 214 }
 215
 216
 217 =head2 seq_id
 218
 219   Title   : seq_id
 220   Usage   : my $seqid = $location->seq_id();
 221   Function: Get/Set seq_id that location refers to
 222   Returns : seq_id (a string)
 223   Args    : [optional] seq_id value to set
 224
 225 =cut
 226
 227
 228 sub seq_id {
 229     my ($self, $seqid) = @_;
 230     if( defined $seqid ) {
 231         $self->{'_seqid'} = $seqid;
 232     }
 233     return $self->{'_seqid'};
 234 }
 235
 236 =head2 length
 237
 238  Title   : length
 239  Usage   : $len = $loc->length();
 240  Function: get the length in the coordinate space this location spans
 241  Example :
 242  Returns : an integer
 243  Args    : none
 244
 245
 246 =cut
 247
 248 sub length {
 249    my ($self) = @_;
 250    return abs($self->end() - $self->start()) + 1;
 251 }
 252
 253 =head2 min_start
 254
 255   Title   : min_start
 256   Usage   : my $minstart = $location->min_start();
 257   Function: Get minimum starting location of feature startpoint
 258   Returns : integer or undef if no minimum starting point.
 259   Args    : none
 260
 261 =cut
 262
 263 sub min_start {
 264     my ($self,$value) = @_;
 265
 266     if(defined($value)) {
 267         $self->{'_start'} = $value;
 268     }
 269     return $self->{'_start'};
 270 }
 271
 272 =head2 max_start
 273
 274   Title   : max_start
 275   Usage   : my $maxstart = $location->max_start();
 276   Function: Get maximum starting location of feature startpoint.
 277
 278             In this implementation this is exactly the same as min_start().
 279
 280   Returns : integer or undef if no maximum starting point.
 281   Args    : none
 282
 283 =cut
 284
 285 sub max_start {
 286     my ($self,@args) = @_;
 287     return $self->min_start(@args);
 288 }
 289
 290 =head2 start_pos_type
 291
 292   Title   : start_pos_type
 293   Usage   : my $start_pos_type = $location->start_pos_type();
 294   Function: Get start position type (ie <,>, ^).
 295
 296             In this implementation this will always be 'EXACT'.
 297
 298   Returns : type of position coded as text
 299             ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN')
 300   Args    : none
 301
 302 =cut
 303
 304 sub start_pos_type {
 305     my($self) = @_;
 306     return 'EXACT';
 307 }
 308
 309 =head2 min_end
 310
 311   Title   : min_end
 312   Usage   : my $minend = $location->min_end();
 313   Function: Get minimum ending location of feature endpoint
 314   Returns : integer or undef if no minimum ending point.
 315   Args    : none
 316
 317 =cut
 318
 319 sub min_end {
 320     my($self,$value) = @_;
 321
 322     if(defined($value)) {
 323         $self->{'_end'} = $value;
 324     }
 325     return $self->{'_end'};
 326 }
 327
 328 =head2 max_end
 329
 330   Title   : max_end
 331   Usage   : my $maxend = $location->max_end();
 332   Function: Get maximum ending location of feature endpoint
 333
 334             In this implementation this is exactly the same as min_end().
 335
 336   Returns : integer or undef if no maximum ending point.
 337   Args    : none
 338
 339 =cut
 340
 341 sub max_end {
 342     my($self,@args) = @_;
 343     return $self->min_end(@args);
 344 }
 345
 346 =head2 end_pos_type
 347
 348   Title   : end_pos_type
 349   Usage   : my $end_pos_type = $location->end_pos_type();
 350   Function: Get end position type (ie <,>, ^)
 351
 352             In this implementation this will always be 'EXACT'.
 353
 354   Returns : type of position coded as text
 355             ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN')
 356   Args    : none
 357
 358 =cut
 359
 360 sub end_pos_type {
 361     my($self) = @_;
 362     return 'EXACT';
 363 }
 364
 365 =head2 location_type
 366
 367   Title   : location_type
 368   Usage   : my $location_type = $location->location_type();
 369   Function: Get location type encoded as text
 370   Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN')
 371   Args    : none
 372
 373 =cut
 374
 375 sub location_type {
 376     my ($self) = @_;
 377     return 'EXACT';
 378 }
 379
 380 =head2 is_remote
 381
 382  Title   : is_remote
 383  Usage   : $is_remote_loc = $loc->is_remote()
 384  Function: Whether or not a location is a remote location.
 385
 386            A location is said to be remote if it is on a different
 387            'object' than the object which 'has' this
 388            location. Typically, features on a sequence will sometimes
 389            have a remote location, which means that the location of
 390            the feature is on a different sequence than the one that is
 391            attached to the feature. In such a case, $loc->seq_id will
 392            be different from $feat->seq_id (usually they will be the
 393            same).
 394
 395            While this may sound weird, it reflects the location of the
 396            kind of AL445212.9:83662..166657 which can be found in GenBank/EMBL
 397            feature tables.
 398
 399  Example :
 400  Returns : TRUE if the location is a remote location, and FALSE otherwise
 401  Args    : Value to set to
 402
 403 =cut
 404
 405 sub is_remote {
 406    my $self = shift;
 407    if( @_ ) {
 408        my $value = shift;
 409        $self->{'is_remote'} = $value;
 410    }
 411    return $self->{'is_remote'};
 412 }
 413
 414 =head2 each_Location
 415
 416  Title   : each_Location
 417  Usage   : @locations = $locObject->each_Location($order);
 418  Function: Conserved function call across Location:: modules - will
 419            return an array containing the component Location(s) in
 420            that object, regardless if the calling object is itself a
 421            single location or one containing sublocations.
 422  Returns : an array of Bio::LocationI implementing objects - for
 423            Simple locations, the return value is just itself.
 424  Args    :
 425
 426 =cut
 427
 428 sub each_Location {
 429    my ($self) = @_;
 430    return ($self);
 431 }
 432
 433 =head2 to_FTstring
 434
 435   Title   : to_FTstring
 436   Usage   : my $locstr = $location->to_FTstring()
 437   Function: returns the FeatureTable string of this location
 438   Returns : string
 439   Args    : none
 440
 441 =cut
 442
 443 sub to_FTstring {
 444     my($self) = @_;
 445     if( $self->start == $self->end ) {
 446         return $self->start;
 447     }
 448     my $str = $self->start . ".." . $self->end;
 449     if( $self->strand == -1 ) {
 450         $str = sprintf("complement(%s)", $str);
 451     }
 452     return $str;
 453 }
 454
 455 =head2 valid_Location
 456
 457  Title   : valid_Location
 458  Usage   : if ($location->valid_location) {...};
 459  Function: boolean method to determine whether location is considered valid
 460            (has minimum requirements for Simple implementation)
 461  Returns : Boolean value: true if location is valid, false otherwise
 462  Args    : none
 463
 464 =cut
 465
 466 sub valid_Location {
 467     my ($self) = @_;
 468     return 1 if $self->{'_start'} && $self->{'_end'};
 469     return 0;
 470 }
 471
 472 =head2 coordinate_policy
 473
 474   Title   : coordinate_policy
 475   Usage   : $policy = $location->coordinate_policy();
 476             $location->coordinate_policy($mypolicy); # set may not be possible
 477   Function: Get the coordinate computing policy employed by this object.
 478
 479             See L<Bio::Location::CoordinatePolicyI> for documentation
 480             about the policy object and its use.
 481
 482             The interface *does not* require implementing classes to
 483             accept setting of a different policy. The implementation
 484             provided here does, however, allow one to do so.
 485
 486             Implementors of this interface are expected to initialize
 487             every new instance with a
 488             L<Bio::Location::CoordinatePolicyI> object. The
 489             implementation provided here will return a default policy
 490             object if none has been set yet. To change this default
 491             policy object call this method as a class method with an
 492             appropriate argument. Note that in this case only
 493             subsequently created Location objects will be affected.
 494
 495   Returns : A L<Bio::Location::CoordinatePolicyI> implementing object.
 496   Args    : On set, a L<Bio::Location::CoordinatePolicyI> implementing object.
 497
 498 See L<Bio::Location::CoordinatePolicyI> for more information
 499
 500
 501 =cut
 502
 503 sub coordinate_policy {
 504     my ($self, $policy) = @_;
 505
 506     if(defined($policy)) {
 507         if(! $policy->isa('Bio::Location::CoordinatePolicyI')) {
 508             $self->throw("Object of class ".ref($policy)." does not implement".
 509                          " Bio::Location::CoordinatePolicyI");
 510         }
 511         if(ref($self)) {
 512             $self->{'_coordpolicy'} = $policy;
 513         } else {
 514             # called as class method
 515             $coord_policy = $policy;
 516         }
 517     }
 518     return (ref($self) && exists($self->{'_coordpolicy'}) ?
 519             $self->{'_coordpolicy'} : $coord_policy);
 520 }
 521
 522 =head2 trunc
 523
 524   Title   : trunc
 525         Usage   : $trunc_location = $location->trunc($start, $end, $relative_ori);
 526         Function: To truncate a location and keep annotations and features
 527                   within the truncated segment intact.
 528
 529                                                 This might do things differently where the truncation
 530                                                 splits the location in half.
 531         CAVEAT  : As yet, this is an untested and unannounced method. Use
 532                   with caution!
 533         Returns : A L<Bio::Location::Atomic> object.
 534         Args    : The start and end position for the trunction, and the relative
 535                   orientation.
 536
 537 =cut
 538
 539 sub trunc {
 540   my ($self,$start,$end,$relative_ori) = @_;
 541
 542   my $newstart  = $self->start - $start+1;
 543   my $newend    = $self->end   - $start+1;
 544   my $newstrand = $relative_ori * $self->strand;
 545
 546   my $out;
 547   if( $newstart < 1 || $newend > ($end-$start+1) ) {
 548     $out = Bio::Location::Atomic->new();
 549     $out->start($self->start);
 550     $out->end($self->end);
 551     $out->strand($self->strand);
 552     $out->seq_id($self->seqid);
 553     $out->is_remote(1);
 554   } else {
 555     $out = Bio::Location::Atomic->new();
 556     $out->start($newstart);
 557     $out->end($newend);
 558     $out->strand($newstrand);
 559     $out->seq_id();
 560   }
 561
 562   return $out;
 563 }
 564
 565 1;