Bio/DB/GFF/Segment.pm

   1 =head1 NAME
   2
   3 Bio::DB::GFF::Segment -- Simple DNA segment object
   4
   5 =head1 SYNOPSIS
   6
   7 See L<Bio::DB::GFF>.
   8
   9 =head1 DESCRIPTION
  10
  11 Bio::DB::GFF::Segment provides the basic representation of a range of
  12 DNA contained in a GFF database.  It is the base class from which the
  13 Bio::DB::GFF::RelSegment and Bio::DB::GFF::Feature classes are
  14 derived.
  15
  16 Generally, you will not create or manipulate Bio::DB::GFF::Segment
  17 objects directly, but use those that are returned by the Bio::DB::GFF
  18 module.
  19
  20 =cut
  21
  22 package Bio::DB::GFF::Segment;
  23
  24 use strict;
  25 use Bio::Annotation::Collection;
  26
  27 use base qw(Bio::Root::Root Bio::RangeI Bio::SeqI Bio::Das::SegmentI);
  28
  29 use overload
  30   '""'     => 'asString',
  31   eq       => 'equals',
  32   fallback => 1;
  33
  34 =head1 API
  35
  36 The remainder of this document describes the API for
  37 Bio::DB::GFF::Segment.
  38
  39 =cut
  40
  41 =head2 new
  42
  43  Title   : new
  44  Usage   : $s = Bio::DB::GFF::Segment->new(@args)
  45  Function: create a new segment
  46  Returns : a new Bio::DB::GFF::Segment object
  47  Args    : see below
  48  Status  : Public
  49
  50 This method creates a new Bio::DB::GFF::Segment object.  Generally
  51 this is called automatically by the Bio::DB::GFF module and
  52 derivatives.
  53
  54 There are five positional arguments:
  55
  56  $factory      a Bio::DB::GFF::Adaptor to use for database access
  57  $sourceseq    ID of the source sequence
  58  $sourceclass  class of the source sequence
  59  $start        start of the desired segment relative to source sequence
  60  $stop         stop of the desired segment relative to source sequence
  61
  62 =cut
  63
  64 sub new {
  65   my $class = shift;
  66   my ($factory,$segclass,$segname,$start,$stop) = @_;
  67   $segclass = $segname->class if ref($segname) && $segname->can('class');
  68   $segclass ||= 'Sequence';
  69
  70   $factory or $class->throw("->new(): provide a factory argument");
  71   $class = ref $class if ref $class;
  72   return bless { factory   => $factory,
  73                  sourceseq => $segname,
  74                  class     => $segclass,
  75                  start     => $start,
  76                  stop      => $stop,
  77                  strand    => 0,
  78                },$class;
  79 }
  80
  81 # read-only accessors
  82
  83 =head2 factory
  84
  85  Title   : factory
  86  Usage   : $s->factory
  87  Function: get the factory object
  88  Returns : a Bio::DB::GFF::Adaptor
  89  Args    : none
  90  Status  : Public
  91
  92 This is a read-only accessor for the Bio::DB::GFF::Adaptor object used
  93 to create the segment.
  94
  95 =cut
  96
  97 sub factory { shift->{factory} }
  98
  99 # start, stop, length
 100
 101 =head2 start
 102
 103  Title   : start
 104  Usage   : $s->start
 105  Function: start of segment
 106  Returns : integer
 107  Args    : none
 108  Status  : Public
 109
 110 This is a read-only accessor for the start of the segment.
 111
 112 =cut
 113
 114 sub start  { shift->{start} }
 115
 116 =head2 end
 117
 118  Title   : end
 119  Usage   : $s->end
 120  Function: end of segment
 121  Returns : integer
 122  Args    : none
 123  Status  : Public
 124
 125 This is a read-only accessor for the end of the segment.
 126
 127 =cut
 128
 129 sub end   { shift->{stop}  }
 130
 131 =head2 stop
 132
 133  Title   : stop
 134  Usage   : $s->stop
 135  Function: stop of segment
 136  Returns : integer
 137  Args    : none
 138  Status  : Public
 139
 140 This is an alias for end(), provided for AcePerl compatibility.
 141
 142 =cut
 143
 144 *stop = \&end;
 145
 146 =head2 length
 147
 148  Title   : length
 149  Usage   : $s->length
 150  Function: length of segment
 151  Returns : integer
 152  Args    : none
 153  Status  : Public
 154
 155 Returns the length of the segment.  Always a positive number.
 156
 157 =cut
 158
 159 sub length { abs($_[0]->{start} - $_[0]->{stop})+1 }
 160
 161
 162 =head2 strand
 163
 164  Title   : strand
 165  Usage   : $s->strand
 166  Function: strand of segment
 167  Returns : +1,0,-1
 168  Args    : none
 169  Status  : Public
 170
 171 Returns the strand on which the segment resides, either +1, 0 or -1.
 172
 173 =cut
 174
 175 sub strand {
 176   my $self = shift;
 177   0;
 178 }
 179
 180 =head2 low
 181
 182  Title   : low
 183  Usage   : $s->low
 184  Function: return lower coordinate
 185  Returns : lower coordinate
 186  Args    : none
 187  Status  : Public
 188
 189 Returns the lower coordinate, either start or end.
 190
 191 =cut
 192
 193 sub low {
 194   my $self = shift;
 195   my ($start,$stop) = ($self->start,$self->stop);
 196   return $start < $stop ? $start : $stop;
 197 }
 198 *abs_low = \&low;
 199
 200 =head2 high
 201
 202  Title   : high
 203  Usage   : $s->high
 204  Function: return higher coordinate
 205  Returns : higher coordinate
 206  Args    : none
 207  Status  : Public
 208
 209 Returns the higher coordinate, either start or end.
 210
 211 =cut
 212
 213 sub high {
 214   my $self = shift;
 215   my ($start,$stop) = ($self->start,$self->stop);
 216   return $start > $stop ? $start : $stop;
 217 }
 218 *abs_high = \&high;
 219
 220 =head2 sourceseq
 221
 222  Title   : sourceseq
 223  Usage   : $s->sourceseq
 224  Function: get the segment source
 225  Returns : a string
 226  Args    : none
 227  Status  : Public
 228
 229 Returns the name of the source sequence for this segment.
 230
 231 =cut
 232
 233 sub sourceseq { shift->{sourceseq} }
 234
 235 =head2 class
 236
 237  Title   : class
 238  Usage   : $s->class([$newclass])
 239  Function: get the source sequence class
 240  Returns : a string
 241  Args    : new class (optional)
 242  Status  : Public
 243
 244 Gets or sets the class for the source sequence for this segment.
 245
 246 =cut
 247
 248 sub class     {
 249   my $self = shift;
 250   my $d = $self->{class};
 251   $self->{class} = shift if @_;
 252   $d;
 253 }
 254
 255 =head2 subseq
 256
 257  Title   : subseq
 258  Usage   : $s->subseq($start,$stop)
 259  Function: generate a subsequence
 260  Returns : a Bio::DB::GFF::Segment object
 261  Args    : start and end of subsequence
 262  Status  : Public
 263
 264 This method generates a new segment from the start and end positions
 265 given in the arguments.  If stop E<lt> start, then the strand is reversed.
 266
 267 =cut
 268
 269 sub subseq {
 270   my $self = shift;
 271   my ($newstart,$newstop) = @_;
 272   my ($refseq,$start,$stop,$class) = ($self->{sourceseq},
 273                                       $self->{start},$self->{stop},
 274                                       $self->class);
 275
 276   # We deliberately force subseq to return objects of type RelSegment
 277   # Otherwise, when we get a subsequence from a Feature object,
 278   # its method and source go along for the ride, which is incorrect.
 279   my $new = $self->new_from_segment($self);
 280   if ($start <= $stop) {
 281     @{$new}{qw(start stop)} = ($start + $newstart - 1, $start + $newstop  - 1);
 282   } else {
 283     @{$new}{qw(start stop)} = ($start - ($newstart - 1), $start - ($newstop  - 1)),
 284
 285   }
 286
 287   $new;
 288 }
 289
 290 =head2 seq
 291
 292  Title   : seq
 293  Usage   : $s->seq
 294  Function: get the sequence string for this segment
 295  Returns : a Bio::PrimarySeq
 296  Args    : none
 297  Status  : Public
 298
 299 Returns the sequence for this segment as a Bio::PrimarySeq.  (-)
 300 strand segments are automatically reverse complemented
 301
 302 The method is called dna() return the data as a simple sequence
 303 string.
 304
 305 =cut
 306
 307 sub seq {
 308   my $self = shift;
 309   my $dna = $self->dna;
 310   require Bio::PrimarySeq unless Bio::PrimarySeq->can('new');
 311   return Bio::PrimarySeq->new(-id => $self->display_name) unless $dna;
 312   return Bio::PrimarySeq->new(-seq => $dna,
 313                               -id  => $self->display_name);
 314 }
 315
 316 =head2 dna
 317
 318  Title   : dna
 319  Usage   : $s->dna
 320  Function: get the DNA string for this segment
 321  Returns : a string
 322  Args    : none
 323  Status  : Public
 324
 325 Returns the sequence for this segment as a simple string. (-) strand
 326 segments are automatically reverse complemented
 327
 328 The method is also called protein().
 329
 330 =cut
 331
 332 sub dna {
 333   my $self = shift;
 334   my ($ref,$class,$start,$stop,$strand)
 335     = @{$self}{qw(sourceseq class start stop strand)};
 336   return $self->factory->dna($ref,$start,$stop,$class);
 337 }
 338
 339 *protein = \&dna;
 340
 341
 342 =head2 primary_seq
 343
 344  Title   : primary_seq
 345  Usage   : $s->primary_seq
 346  Function: returns a Bio::PrimarySeqI compatible object
 347  Returns : a Bio::PrimarySeqI object
 348  Args    : none
 349  Status  : Public
 350
 351 This is for compatibility with BioPerl's separation of SeqI
 352 from PrimarySeqI.  It just returns itself.
 353
 354 =cut
 355
 356 #'
 357
 358 sub primary_seq { shift }
 359
 360 =head2 type
 361
 362  Title   : type
 363  Usage   : $s->type
 364  Function: return the string "feature"
 365  Returns : the string "feature"
 366  Args    : none
 367  Status  : Public
 368
 369 This is for future sequence ontology-compatibility and
 370 represents the default type of a feature on the genome
 371
 372 =cut
 373
 374 sub type { "feature" }
 375
 376 =head2 equals
 377
 378  Title   : equals
 379  Usage   : $s->equals($d)
 380  Function: segment equality
 381  Returns : true, if two segments are equal
 382  Args    : another segment
 383  Status  : Public
 384
 385 Returns true if the two segments have the same source sequence, start and stop.
 386
 387 =cut
 388
 389 sub equals {
 390   my $self = shift;
 391   my $peer = shift;
 392   return unless defined $peer;
 393   return $self->asString eq $peer unless ref($peer) && $peer->isa('Bio::DB::GFF::Segment');
 394   return $self->{start} eq $peer->{start}
 395          && $self->{stop}  eq $peer->{stop}
 396          && $self->{sourceseq} eq $peer->{sourceseq};
 397 }
 398
 399 =head2 asString
 400
 401  Title   : asString
 402  Usage   : $s->asString
 403  Function: human-readable string for segment
 404  Returns : a string
 405  Args    : none
 406  Status  : Public
 407
 408 Returns a human-readable string representing this sequence.  Format
 409 is:
 410
 411    sourceseq/start,stop
 412
 413 =cut
 414
 415 sub asString {
 416   my $self = shift;
 417   my $label = $self->refseq;
 418   my $start = $self->start;
 419   my $stop  = $self->stop;
 420   return "$label:$start,$stop";
 421 }
 422
 423 =head2 clone
 424
 425  Title   : clone
 426  Usage   : $copy = $s->clone
 427  Function: make a copy of this segment
 428  Returns : a Bio::DB::GFF::Segment object
 429  Args    : none
 430  Status  : Public
 431
 432 This method creates a copy of the segment and returns it.
 433
 434 =cut
 435
 436 # deep copy of the thing
 437 sub clone {
 438   my $self = shift;
 439   my %h = %$self;
 440   return bless \%h,ref($self);
 441 }
 442
 443 =head2 error
 444
 445  Title   : error
 446  Usage   : $error = $s->error([$new_error])
 447  Function: get or set the last error
 448  Returns : a string
 449  Args    : an error message (optional)
 450  Status  : Public
 451
 452 In case of a fault, this method can be used to obtain the last error
 453 message.  Internally it is called to set the error message.
 454
 455 =cut
 456
 457 sub error {
 458   my $self = shift;
 459   my $g = $self->{error};
 460   $self->{error} = shift if @_;
 461   $g;
 462 }
 463
 464 =head1 Relative Addressing Methods
 465
 466 The following methods are provided for compatibility with
 467 Bio::DB::GFF::RelSegment, which provides relative addressing
 468 functions.
 469
 470 =head2 abs_start
 471
 472  Title   : abs_start
 473  Usage   : $s->abs_start
 474  Function: the absolute start of the segment
 475  Returns : an integer
 476  Args    : none
 477  Status  : Public
 478
 479 This is an alias to start(), and provided for API compatibility with
 480 Bio::DB::GFF::RelSegment.
 481
 482 =cut
 483
 484 *abs_start  = \&start;
 485
 486 =head2 abs_end
 487
 488  Title   : abs_end
 489  Usage   : $s->abs_end
 490  Function: the absolute stop of the segment
 491  Returns : an integer
 492  Args    : none
 493  Status  : Public
 494
 495 This is an alias to stop(), and provided for API compatibility with
 496 Bio::DB::GFF::RelSegment.
 497
 498 =cut
 499
 500 *abs_stop   = \&stop;
 501 *abs_end    = \&stop;
 502
 503 =head2 abs_strand
 504
 505  Title   : abs_strand
 506  Usage   : $s->abs_strand
 507  Function: the absolute strand of the segment
 508  Returns : +1,0,-1
 509  Args    : none
 510  Status  : Public
 511
 512 This is an alias to strand(), and provided for API compatibility with
 513 Bio::DB::GFF::RelSegment.
 514
 515 =cut
 516
 517 sub abs_strand {
 518   my $self = shift;
 519   return $self->abs_end <=> $self->abs_start;
 520 }
 521
 522 =head2 abs_ref
 523
 524  Title   : abs_ref
 525  Usage   : $s->abs_ref
 526  Function: the reference sequence for this segment
 527  Returns : a string
 528  Args    : none
 529  Status  : Public
 530
 531 This is an alias to sourceseq(), and is here to provide API
 532 compatibility with Bio::DB::GFF::RelSegment.
 533
 534 =cut
 535
 536 *abs_ref    = \&sourceseq;
 537
 538 =head2 refseq
 539
 540  Title   : refseq
 541  Usage   : $s->refseq
 542  Function: get or set the reference sequence
 543  Returns : a string
 544  Args    : none
 545  Status  : Public
 546
 547 Examine or change the reference sequence. This is an alias to
 548 sourceseq(), provided here for API compatibility with
 549 Bio::DB::GFF::RelSegment.
 550
 551 =cut
 552
 553 *refseq     = \&sourceseq;
 554
 555 =head2 ref
 556
 557  Title   : ref
 558  Usage   : $s->refseq
 559  Function: get or set the reference sequence
 560  Returns : a string
 561  Args    : none
 562  Status  : Public
 563
 564 An alias for refseq()
 565
 566 =cut
 567
 568 sub ref { shift->refseq(@_) }
 569
 570 =head2 seq_id
 571
 572  Title   : seq_id
 573  Usage   : $ref = $s->seq_id
 574  Function: get the reference sequence in a LocationI-compatible way
 575  Returns : a string
 576  Args    : none
 577  Status  : Public
 578
 579 An alias for refseq() but only allows reading.
 580
 581 =cut
 582
 583 sub seq_id { shift->refseq }
 584 *seqname = \&seq_id;
 585
 586 =head2 truncated
 587
 588  Title   : truncated
 589  Usage   : $truncated = $s->truncated
 590  Function: Flag indicating that the segment was truncated during creation
 591  Returns : A boolean flag
 592  Args    : none
 593  Status  : Public
 594
 595 This indicates that the sequence was truncated during creation.  The
 596 returned flag is undef if no truncation occured.  If truncation did
 597 occur, the flag is actually an array ref in which the first element is
 598 true if truncation occurred on the left, and the second element
 599 occurred if truncation occurred on the right.
 600
 601 =cut
 602
 603 sub truncated {
 604   my $self = shift;
 605   my $hash = $self->{truncated} or return;
 606   CORE::ref($hash) eq 'HASH' or return [1,1];  # paranoia -- not that this would ever happen ;-)
 607   return [$hash->{start},$hash->{stop}];
 608 }
 609
 610 =head2 Bio::RangeI Methods
 611
 612 The following Bio::RangeI methods are supported:
 613
 614 overlaps(), contains(), equals(),intersection(),union(),overlap_extent()
 615
 616 =cut
 617
 618 sub overlaps {
 619   my $self  = shift;
 620   my($other,$so) = @_;
 621   if ($other->isa('Bio::DB::GFF::RelSegment')) {
 622     return if $self->abs_ref ne $other->abs_ref;
 623   }
 624   $self->SUPER::overlaps(@_);
 625 }
 626
 627 sub contains {
 628   my $self  = shift;
 629   my($other,$so) = @_;
 630   if ($other->isa('Bio::DB::GFF::RelSegment')) {
 631     return if $self->abs_ref ne $other->abs_ref;
 632   }
 633   $self->SUPER::contains(@_);
 634 }
 635 #sub equals {
 636 #  my $self  = shift;
 637 #  my($other,$so) = @_;
 638 #  if ($other->isa('Bio::DB::GFF::RelSegment')) {
 639 #    return if $self->abs_ref ne $other->abs_ref;
 640 #  }
 641 #  $self->SUPER::equals(@_);
 642 #}
 643 sub intersection {
 644   my $self  = shift;
 645   my($other,$so) = @_;
 646   if ($other->isa('Bio::DB::GFF::RelSegment')) {
 647     return if $self->abs_ref ne $other->abs_ref;
 648   }
 649   $self->SUPER::intersection(@_);
 650 }
 651 sub union {
 652   my $self  = shift;
 653   my($other) = @_;
 654   if ($other->isa('Bio::DB::GFF::RelSegment')) {
 655     return if $self->abs_ref ne $other->abs_ref;
 656   }
 657   $self->SUPER::union(@_);
 658 }
 659
 660 sub overlap_extent {
 661   my $self  = shift;
 662   my($other) = @_;
 663   if ($other->isa('Bio::DB::GFF::RelSegment')) {
 664     return if $self->abs_ref ne $other->abs_ref;
 665   }
 666   $self->SUPER::overlap_extent(@_);
 667 }
 668
 669
 670 =head2 Bio::SeqI implementation
 671
 672 =cut
 673
 674 =head2 primary_id
 675
 676  Title   : primary_id
 677  Usage   : $unique_implementation_key = $obj->primary_id;
 678  Function: Returns the unique id for this object in this
 679            implementation. This allows implementations to manage their
 680            own object ids in a way the implementaiton can control
 681            clients can expect one id to map to one object.
 682
 683            For sequences with no accession number, this method should
 684            return a stringified memory location.
 685
 686  Returns : A string
 687  Args    : None
 688  Status  : Virtual
 689
 690
 691 =cut
 692
 693 sub primary_id {
 694    my ($obj,$value) = @_;
 695
 696    if( defined $value) {
 697       $obj->{'primary_id'} = $value;
 698     }
 699    if( ! exists $obj->{'primary_id'} ) {
 700        return "$obj";
 701    }
 702    return $obj->{'primary_id'};
 703 }
 704
 705
 706 =head2 display_name
 707
 708  Title   : display_name
 709  Usage   : $id = $obj->display_name or $obj->display_name($newid);
 710  Function: Gets or sets the display id, also known as the common name of
 711            the Seq object.
 712
 713            The semantics of this is that it is the most likely string
 714            to be used as an identifier of the sequence, and likely to
 715            have "human" readability.  The id is equivalent to the LOCUS
 716            field of the GenBank/EMBL databanks and the ID field of the
 717            Swissprot/sptrembl database. In fasta format, the >(\S+) is
 718            presumed to be the id, though some people overload the id
 719            to embed other information. Bioperl does not use any
 720            embedded information in the ID field, and people are
 721            encouraged to use other mechanisms (accession field for
 722            example, or extending the sequence object) to solve this.
 723
 724            Notice that $seq->id() maps to this function, mainly for
 725            legacy/convenience issues.
 726  Returns : A string
 727  Args    : None or a new id
 728
 729 Note, this used to be called display_id(), and this name is preserved for
 730 backward compatibility.  The default is to return the seq_id().
 731
 732 =cut
 733
 734 sub display_name { shift->seq_id }
 735 *display_id = \&display_name;
 736
 737 =head2 accession_number
 738
 739  Title   : accession_number
 740  Usage   : $unique_biological_key = $obj->accession_number;
 741  Function: Returns the unique biological id for a sequence, commonly
 742            called the accession_number. For sequences from established
 743            databases, the implementors should try to use the correct
 744            accession number. Notice that primary_id() provides the
 745            unique id for the implemetation, allowing multiple objects
 746            to have the same accession number in a particular implementation.
 747
 748            For sequences with no accession number, this method should return
 749            "unknown".
 750  Returns : A string
 751  Args    : None
 752
 753
 754 =cut
 755
 756 sub accession_number {
 757     return 'unknown';
 758 }
 759
 760 =head2 alphabet
 761
 762  Title   : alphabet
 763  Usage   : if( $obj->alphabet eq 'dna' ) { /Do Something/ }
 764  Function: Returns the type of sequence being one of
 765            'dna', 'rna' or 'protein'. This is case sensitive.
 766
 767            This is not called <type> because this would cause
 768            upgrade problems from the 0.5 and earlier Seq objects.
 769
 770  Returns : a string either 'dna','rna','protein'. NB - the object must
 771            make a call of the type - if there is no type specified it
 772            has to guess.
 773  Args    : none
 774  Status  : Virtual
 775
 776
 777 =cut
 778
 779 sub alphabet{
 780     return 'dna'; # no way this will be anything other than dna!
 781 }
 782
 783 =head2 desc
 784
 785  Title   : desc
 786  Usage   : $seqobj->desc($string) or $seqobj->desc()
 787  Function: Sets or gets the description of the sequence
 788  Example :
 789  Returns : The description
 790  Args    : The description or none
 791
 792
 793 =cut
 794
 795 sub desc { shift->asString }
 796
 797 *description = \&desc;
 798
 799 =head2 species
 800
 801  Title   : species
 802  Usage   : $species = $seq->species() or $seq->species($species)
 803  Function: Gets or sets the species
 804  Example :
 805  Returns : Bio::Species object
 806  Args    : None or Bio::Species object
 807
 808 See L<Bio::Species> for more information
 809
 810 =cut
 811
 812 sub species {
 813     my ($self, $species) = @_;
 814     if ($species) {
 815         $self->{'species'} = $species;
 816     } else {
 817         return $self->{'species'};
 818     }
 819 }
 820
 821 =head2 annotation
 822
 823  Title   : annotation
 824  Usage   : $ann = $seq->annotation or $seq->annotation($annotation)
 825  Function: Gets or sets the annotation
 826  Example :
 827  Returns : Bio::Annotation object
 828  Args    : None or Bio::Annotation object
 829
 830 See L<Bio::Annotation> for more information
 831
 832 =cut
 833
 834 sub annotation {
 835    my ($obj,$value) = @_;
 836    if( defined $value || ! defined $obj->{'annotation'} ) {
 837        $value = Bio::Annotation::Collection->new() unless defined $value;
 838       $obj->{'annotation'} = $value;
 839     }
 840     return $obj->{'annotation'};
 841
 842 }
 843
 844 =head2 is_circular
 845
 846  Title   : is_circular
 847  Usage   : if( $obj->is_circular) { /Do Something/ }
 848  Function: Returns true if the molecule is circular
 849  Returns : Boolean value
 850  Args    : none
 851
 852 =cut
 853
 854 sub is_circular{
 855     return 0;
 856 }
 857
 858
 859 1;
 860 __END__
 861
 862 =head1 BUGS
 863
 864 Report them please.
 865
 866 =head1 SEE ALSO
 867
 868 L<bioperl>
 869
 870 =head1 AUTHOR
 871
 872 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
 873
 874 Copyright (c) 2001 Cold Spring Harbor Laboratory.
 875
 876 This library is free software; you can redistribute it and/or modify
 877 it under the same terms as Perl itself.
 878
 879 =head1 CONTRIBUTORS
 880
 881 Jason Stajich E<lt>jason@bioperl.orgE<gt>.
 882
 883 =cut
 884