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 use strict;
  78
  79 use Bio::Location::WidestCoordPolicy;
  80
  81 use base qw(Bio::Root::Root Bio::LocationI);
  82
  83 our $coord_policy = 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     # explicitly 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    : optionally 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    : optionally 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    : optionally 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 one 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;