File Coverage

Bio/DB/GFF/Segment.pm

Criterion	Covered	Total	%
statement	56	127	44.0
branch	11	58	18.9
condition	4	14	28.5
subroutine	17	40	42.5
pod	36	36	100.0
total	124	275	45.0

=head1 NAME

Bio::DB::GFF::Segment -- Simple DNA segment object

=head1 SYNOPSIS

See L.

=head1 DESCRIPTION

Bio::DB::GFF::Segment provides the basic representation of a range of
DNA contained in a GFF database.  It is the base class from which the
Bio::DB::GFF::RelSegment and Bio::DB::GFF::Feature classes are
derived.

Generally, you will not create or manipulate Bio::DB::GFF::Segment
objects directly, but use those that are returned by the Bio::DB::GFF
module.

=cut

package Bio::DB::GFF::Segment;

use strict;
use Bio::Annotation::Collection;

use base qw(Bio::Root::Root Bio::RangeI Bio::SeqI Bio::Das::SegmentI);

use overload
  '""'     => 'asString',
  eq       => 'equals',
  fallback => 1;

=head1 API

The remainder of this document describes the API for
Bio::DB::GFF::Segment.

=cut

=head2 new

 Title   : new
 Usage   : $s = Bio::DB::GFF::Segment->new(@args)
 Function: create a new segment
 Returns : a new Bio::DB::GFF::Segment object
 Args    : see below
 Status  : Public

This method creates a new Bio::DB::GFF::Segment object.  Generally
this is called automatically by the Bio::DB::GFF module and
derivatives.

There are five positional arguments:

 $factory      a Bio::DB::GFF::Adaptor to use for database access
 $sourceseq    ID of the source sequence
 $sourceclass  class of the source sequence
 $start        start of the desired segment relative to source sequence
 $stop         stop of the desired segment relative to source sequence

=cut

sub new {
  my $class = shift;
  my ($factory,$segclass,$segname,$start,$stop) = @_;
  $segclass = $segname->class if ref($segname) && $segname->can('class');
  $segclass ||= 'Sequence';

  $factory or $class->throw("->new(): provide a factory argument");
  $class = ref $class if ref $class;
  return bless { factory   => $factory,
		 sourceseq => $segname,
		 class     => $segclass,
		 start     => $start,
		 stop      => $stop,
		 strand    => 0,
	       },$class;
}

# read-only accessors

=head2 factory

 Title   : factory
 Usage   : $s->factory
 Function: get the factory object
 Returns : a Bio::DB::GFF::Adaptor
 Args    : none
 Status  : Public

This is a read-only accessor for the Bio::DB::GFF::Adaptor object used
to create the segment.

=cut

sub factory { shift->{factory} }

# start, stop, length

=head2 start

 Title   : start
 Usage   : $s->start
 Function: start of segment
 Returns : integer
 Args    : none
 Status  : Public

This is a read-only accessor for the start of the segment.

=cut

sub start  { shift->{start} }

=head2 end

 Title   : end
 Usage   : $s->end
 Function: end of segment
 Returns : integer
 Args    : none
 Status  : Public

This is a read-only accessor for the end of the segment.

=cut

sub end   { shift->{stop}  }

=head2 stop

 Title   : stop
 Usage   : $s->stop
 Function: stop of segment
 Returns : integer
 Args    : none
 Status  : Public

This is an alias for end(), provided for AcePerl compatibility.

=cut

*stop = \&end;

=head2 length

 Title   : length
 Usage   : $s->length
 Function: length of segment
 Returns : integer
 Args    : none
 Status  : Public

Returns the length of the segment.  Always a positive number.

=cut

sub length { abs($_[0]->{start} - $_[0]->{stop})+1 }


=head2 strand

 Title   : strand
 Usage   : $s->strand
 Function: strand of segment
 Returns : +1,0,-1
 Args    : none
 Status  : Public

Returns the strand on which the segment resides, either +1, 0 or -1.

=cut

sub strand {
  my $self = shift;
  0;
}

=head2 low

 Title   : low
 Usage   : $s->low
 Function: return lower coordinate
 Returns : lower coordinate
 Args    : none
 Status  : Public

Returns the lower coordinate, either start or end.

=cut

sub low {
  my $self = shift;
  my ($start,$stop) = ($self->start,$self->stop);
  return $start < $stop ? $start : $stop;
}
*abs_low = \&low;

=head2 high

 Title   : high
 Usage   : $s->high
 Function: return higher coordinate
 Returns : higher coordinate
 Args    : none
 Status  : Public

Returns the higher coordinate, either start or end.

=cut

sub high {
  my $self = shift;
  my ($start,$stop) = ($self->start,$self->stop);
  return $start > $stop ? $start : $stop;
}
*abs_high = \&high;

=head2 sourceseq

 Title   : sourceseq
 Usage   : $s->sourceseq
 Function: get the segment source
 Returns : a string
 Args    : none
 Status  : Public

Returns the name of the source sequence for this segment.

=cut

sub sourceseq { shift->{sourceseq} }

=head2 class

 Title   : class
 Usage   : $s->class([$newclass])
 Function: get the source sequence class
 Returns : a string
 Args    : new class (optional)
 Status  : Public

Gets or sets the class for the source sequence for this segment.

=cut

sub class     {
  my $self = shift;
  my $d = $self->{class};
  $self->{class} = shift if @_;
  $d;
}

=head2 subseq

 Title   : subseq
 Usage   : $s->subseq($start,$stop)
 Function: generate a subsequence
 Returns : a Bio::DB::GFF::Segment object
 Args    : start and end of subsequence
 Status  : Public

This method generates a new segment from the start and end positions
given in the arguments.  If stop E start, then the strand is reversed.

=cut

sub subseq {
  my $self = shift;
  my ($newstart,$newstop) = @_;
  my ($refseq,$start,$stop,$class) = ($self->{sourceseq},
				      $self->{start},$self->{stop},
				      $self->class);

  # We deliberately force subseq to return objects of type RelSegment
  # Otherwise, when we get a subsequence from a Feature object,
  # its method and source go along for the ride, which is incorrect.
  my $new = $self->new_from_segment($self);
  if ($start <= $stop) {
    @{$new}{qw(start stop)} = ($start + $newstart - 1, $start + $newstop  - 1);
  } else {
    @{$new}{qw(start stop)} = ($start - ($newstart - 1), $start - ($newstop  - 1)),

  }

  $new;
}

=head2 seq

 Title   : seq
 Usage   : $s->seq
 Function: get the sequence string for this segment
 Returns : a Bio::PrimarySeq
 Args    : none
 Status  : Public

Returns the sequence for this segment as a Bio::PrimarySeq.  (-)
strand segments are automatically reverse complemented

The method is called dna() return the data as a simple sequence
string.

=cut

sub seq {
  my $self = shift;
  my $dna = $self->dna;
  require Bio::PrimarySeq unless Bio::PrimarySeq->can('new');
  return Bio::PrimarySeq->new(-id => $self->display_name) unless $dna;
  return Bio::PrimarySeq->new(-seq => $dna,
			      -id  => $self->display_name);
}

=head2 dna

 Title   : dna
 Usage   : $s->dna
 Function: get the DNA string for this segment
 Returns : a string
 Args    : none
 Status  : Public

Returns the sequence for this segment as a simple string. (-) strand
segments are automatically reverse complemented

The method is also called protein().

=cut

sub dna {
  my $self = shift;
  my ($ref,$class,$start,$stop,$strand)
    = @{$self}{qw(sourceseq class start stop strand)};
  return $self->factory->dna($ref,$start,$stop,$class);
}

*protein = \&dna;


=head2 primary_seq

 Title   : primary_seq
 Usage   : $s->primary_seq
 Function: returns a Bio::PrimarySeqI compatible object
 Returns : a Bio::PrimarySeqI object
 Args    : none
 Status  : Public

This is for compatibility with BioPerl's separation of SeqI
from PrimarySeqI.  It just returns itself.

=cut

#'

sub primary_seq { shift }

=head2 type

 Title   : type
 Usage   : $s->type
 Function: return the string "feature"
 Returns : the string "feature"
 Args    : none
 Status  : Public

This is for future sequence ontology-compatibility and
represents the default type of a feature on the genome

=cut

sub type { "feature" }

=head2 equals

 Title   : equals
 Usage   : $s->equals($d)
 Function: segment equality
 Returns : true, if two segments are equal
 Args    : another segment
 Status  : Public

Returns true if the two segments have the same source sequence, start and stop.

=cut

sub equals {
  my $self = shift;
  my $peer = shift;
  return unless defined $peer;
  return $self->asString eq $peer unless ref($peer) && $peer->isa('Bio::DB::GFF::Segment');
  return $self->{start} eq $peer->{start}
         && $self->{stop}  eq $peer->{stop}
         && $self->{sourceseq} eq $peer->{sourceseq};
}

=head2 asString

 Title   : asString
 Usage   : $s->asString
 Function: human-readable string for segment
 Returns : a string
 Args    : none
 Status  : Public

Returns a human-readable string representing this sequence.  Format
is:

   sourceseq/start,stop

=cut

sub asString {
  my $self = shift;
  my $label = $self->refseq;
  my $start = $self->start;
  my $stop  = $self->stop;
  return "$label:$start,$stop";
}

=head2 clone

 Title   : clone
 Usage   : $copy = $s->clone
 Function: make a copy of this segment
 Returns : a Bio::DB::GFF::Segment object
 Args    : none
 Status  : Public

This method creates a copy of the segment and returns it.

=cut

# deep copy of the thing
sub clone {
  my $self = shift;
  my %h = %$self;
  return bless \%h,ref($self);
}

=head2 error

 Title   : error
 Usage   : $error = $s->error([$new_error])
 Function: get or set the last error
 Returns : a string
 Args    : an error message (optional)
 Status  : Public

In case of a fault, this method can be used to obtain the last error
message.  Internally it is called to set the error message.

=cut

sub error {
  my $self = shift;
  my $g = $self->{error};
  $self->{error} = shift if @_;
  $g;
}

=head1 Relative Addressing Methods

The following methods are provided for compatibility with
Bio::DB::GFF::RelSegment, which provides relative addressing
functions.

=head2 abs_start

 Title   : abs_start
 Usage   : $s->abs_start
 Function: the absolute start of the segment
 Returns : an integer
 Args    : none
 Status  : Public

This is an alias to start(), and provided for API compatibility with
Bio::DB::GFF::RelSegment.

=cut

*abs_start  = \&start;

=head2 abs_end

 Title   : abs_end
 Usage   : $s->abs_end
 Function: the absolute stop of the segment
 Returns : an integer
 Args    : none
 Status  : Public

This is an alias to stop(), and provided for API compatibility with
Bio::DB::GFF::RelSegment.

=cut

*abs_stop   = \&stop;
*abs_end    = \&stop;

=head2 abs_strand

 Title   : abs_strand
 Usage   : $s->abs_strand
 Function: the absolute strand of the segment
 Returns : +1,0,-1
 Args    : none
 Status  : Public

This is an alias to strand(), and provided for API compatibility with
Bio::DB::GFF::RelSegment.

=cut

sub abs_strand {
  my $self = shift;
  return $self->abs_end <=> $self->abs_start;
}

=head2 abs_ref

 Title   : abs_ref
 Usage   : $s->abs_ref
 Function: the reference sequence for this segment
 Returns : a string
 Args    : none
 Status  : Public

This is an alias to sourceseq(), and is here to provide API
compatibility with Bio::DB::GFF::RelSegment.

=cut

*abs_ref    = \&sourceseq;

=head2 refseq

 Title   : refseq
 Usage   : $s->refseq
 Function: get or set the reference sequence
 Returns : a string
 Args    : none
 Status  : Public

Examine or change the reference sequence. This is an alias to
sourceseq(), provided here for API compatibility with
Bio::DB::GFF::RelSegment.

=cut

*refseq     = \&sourceseq;

=head2 ref

 Title   : ref
 Usage   : $s->refseq
 Function: get or set the reference sequence
 Returns : a string
 Args    : none
 Status  : Public

An alias for refseq()

=cut

sub ref { shift->refseq(@_) }

=head2 seq_id

 Title   : seq_id
 Usage   : $ref = $s->seq_id
 Function: get the reference sequence in a LocationI-compatible way
 Returns : a string
 Args    : none
 Status  : Public

An alias for refseq() but only allows reading.

=cut

sub seq_id { shift->refseq }
*seqname = \&seq_id;

=head2 truncated

 Title   : truncated
 Usage   : $truncated = $s->truncated
 Function: Flag indicating that the segment was truncated during creation
 Returns : A boolean flag
 Args    : none
 Status  : Public

This indicates that the sequence was truncated during creation.  The
returned flag is undef if no truncation occurred.  If truncation did
occur, the flag is actually an array ref in which the first element is
true if truncation occurred on the left, and the second element
occurred if truncation occurred on the right.

=cut

sub truncated {
  my $self = shift;
  my $hash = $self->{truncated} or return;
  CORE::ref($hash) eq 'HASH' or return [1,1];  # paranoia -- not that this would ever happen ;-)
  return [$hash->{start},$hash->{stop}];
}

=head2 Bio::RangeI Methods

The following Bio::RangeI methods are supported:

overlaps(), contains(), equals(),intersection(),union(),overlap_extent()

=cut

sub overlaps {
  my $self  = shift;
  my($other,$so) = @_;
  if ($other->isa('Bio::DB::GFF::RelSegment')) {
    return if $self->abs_ref ne $other->abs_ref;
  }
  $self->SUPER::overlaps(@_);
}

sub contains {
  my $self  = shift;
  my($other,$so) = @_;
  if ($other->isa('Bio::DB::GFF::RelSegment')) {
    return if $self->abs_ref ne $other->abs_ref;
  }
  $self->SUPER::contains(@_);
}
#sub equals {
#  my $self  = shift;
#  my($other,$so) = @_;
#  if ($other->isa('Bio::DB::GFF::RelSegment')) {
#    return if $self->abs_ref ne $other->abs_ref;
#  }
#  $self->SUPER::equals(@_);
#}
sub intersection {
  my $self  = shift;
  my($other,$so) = @_;
  if ($other->isa('Bio::DB::GFF::RelSegment')) {
    return if $self->abs_ref ne $other->abs_ref;
  }
  $self->SUPER::intersection(@_);
}
sub union {
  my $self  = shift;
  my($other) = @_;
  if ($other->isa('Bio::DB::GFF::RelSegment')) {
    return if $self->abs_ref ne $other->abs_ref;
  }
  $self->SUPER::union(@_);
}

sub overlap_extent {
  my $self  = shift;
  my($other) = @_;
  if ($other->isa('Bio::DB::GFF::RelSegment')) {
    return if $self->abs_ref ne $other->abs_ref;
  }
  $self->SUPER::overlap_extent(@_);
}


=head2 Bio::SeqI implementation

=cut

=head2 primary_id

 Title   : primary_id
 Usage   : $unique_implementation_key = $obj->primary_id;
 Function: Returns the unique id for this object in this
           implementation. This allows implementations to manage their
           own object ids in a way the implementation can control
           clients can expect one id to map to one object.

           For sequences with no accession number, this method should
           return a stringified memory location.

 Returns : A string
 Args    : None
 Status  : Virtual


=cut

sub primary_id {
   my ($obj,$value) = @_;

   if( defined $value) {
      $obj->{'primary_id'} = $value;
    }
   if( ! exists $obj->{'primary_id'} ) {
       return "$obj";
   }
   return $obj->{'primary_id'};
}


=head2 display_name

 Title   : display_name
 Usage   : $id = $obj->display_name or $obj->display_name($newid);
 Function: Gets or sets the display id, also known as the common name of
           the Seq object.

           The semantics of this is that it is the most likely string
           to be used as an identifier of the sequence, and likely to
           have "human" readability.  The id is equivalent to the LOCUS
           field of the GenBank/EMBL databanks and the ID field of the
           Swissprot/sptrembl database. In fasta format, the >(\S+) is
           presumed to be the id, though some people overload the id
           to embed other information. Bioperl does not use any
           embedded information in the ID field, and people are
           encouraged to use other mechanisms (accession field for
           example, or extending the sequence object) to solve this.

           Notice that $seq->id() maps to this function, mainly for
           legacy/convenience issues.
 Returns : A string
 Args    : None or a new id

Note, this used to be called display_id(), and this name is preserved for
backward compatibility.  The default is to return the seq_id().

=cut

sub display_name { shift->seq_id }
*display_id = \&display_name;

=head2 accession_number

 Title   : accession_number
 Usage   : $unique_biological_key = $obj->accession_number;
 Function: Returns the unique biological id for a sequence, commonly
           called the accession_number. For sequences from established
           databases, the implementors should try to use the correct
           accession number. Notice that primary_id() provides the
           unique id for the implementation, allowing multiple objects
           to have the same accession number in a particular implementation.

           For sequences with no accession number, this method should return
           "unknown".
 Returns : A string
 Args    : None


=cut

sub accession_number {
    return 'unknown';
}

=head2 alphabet

 Title   : alphabet
 Usage   : if( $obj->alphabet eq 'dna' ) { /Do Something/ }
 Function: Returns the type of sequence being one of
           'dna', 'rna' or 'protein'. This is case sensitive.

           This is not called  because this would cause
           upgrade problems from the 0.5 and earlier Seq objects.

 Returns : a string either 'dna','rna','protein'. NB - the object must
           make a call of the type - if there is no type specified it
           has to guess.
 Args    : none
 Status  : Virtual


=cut

sub alphabet{
    return 'dna'; # no way this will be anything other than dna!
}

=head2 desc

 Title   : desc
 Usage   : $seqobj->desc($string) or $seqobj->desc()
 Function: Sets or gets the description of the sequence
 Example :
 Returns : The description
 Args    : The description or none


=cut

sub desc { shift->asString }

*description = \&desc;

=head2 species

 Title   : species
 Usage   : $species = $seq->species() or $seq->species($species)
 Function: Gets or sets the species
 Example :
 Returns : Bio::Species object
 Args    : None or Bio::Species object

See L for more information

=cut

sub species {
    my ($self, $species) = @_;
    if ($species) {
        $self->{'species'} = $species;
    } else {
        return $self->{'species'};
    }
}

=head2 annotation

 Title   : annotation
 Usage   : $ann = $seq->annotation or $seq->annotation($annotation)
 Function: Gets or sets the annotation
 Example :
 Returns : Bio::Annotation object
 Args    : None or Bio::Annotation object

See L for more information

=cut

sub annotation {
   my ($obj,$value) = @_;
   if( defined $value || ! defined $obj->{'annotation'} ) {
       $value = Bio::Annotation::Collection->new() unless defined $value;
      $obj->{'annotation'} = $value;
    }
    return $obj->{'annotation'};

}

=head2 is_circular

 Title   : is_circular
 Usage   : if( $obj->is_circular) { /Do Something/ }
 Function: Returns true if the molecule is circular
 Returns : Boolean value
 Args    : none

=cut

sub is_circular{
    return 0;
}


1;
__END__