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


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Bio::DB::GFF::Segment -- Simple DNA segment object
4              
5             =head1 SYNOPSIS
6              
7             See L.
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 3     3   18 use strict;
  3         3  
  3         66  
25 3     3   717 use Bio::Annotation::Collection;
  3         6  
  3         69  
26              
27 3     3   15 use base qw(Bio::Root::Root Bio::RangeI Bio::SeqI Bio::Das::SegmentI);
  3         3  
  3         837  
28              
29             use overload
30 3         15 '""' => 'asString',
31             eq => 'equals',
32 3     3   15 fallback => 1;
  3         6  
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 160     160 1 179 my $class = shift;
66 160         230 my ($factory,$segclass,$segname,$start,$stop) = @_;
67 160 50 33     287 $segclass = $segname->class if ref($segname) && $segname->can('class');
68 160   50     185 $segclass ||= 'Sequence';
69              
70 160 50       227 $factory or $class->throw("->new(): provide a factory argument");
71 160 50       659 $class = ref $class if ref $class;
72 160         1104 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 265     265 1 765 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 120     120 1 371 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 140     140 1 336 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 0     0 1 0 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 0     0 1 0 my $self = shift;
177 0         0 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 0     0 1 0 my $self = shift;
195 0         0 my ($start,$stop) = ($self->start,$self->stop);
196 0 0       0 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 0     0 1 0 my $self = shift;
215 0         0 my ($start,$stop) = ($self->start,$self->stop);
216 0 0       0 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 765     765 1 2846 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 225     225 1 250 my $self = shift;
250 225         254 my $d = $self->{class};
251 225 50       391 $self->{class} = shift if @_;
252 225         385 $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 start, then the strand is reversed.
266              
267             =cut
268              
269             sub subseq {
270 35     35 1 34 my $self = shift;
271 35         53 my ($newstart,$newstop) = @_;
272             my ($refseq,$start,$stop,$class) = ($self->{sourceseq},
273             $self->{start},$self->{stop},
274 35         72 $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 35         77 my $new = $self->new_from_segment($self);
280 35 100       51 if ($start <= $stop) {
281 20         39 @{$new}{qw(start stop)} = ($start + $newstart - 1, $start + $newstop - 1);
  20         33  
282             } else {
283 15         33 @{$new}{qw(start stop)} = ($start - ($newstart - 1), $start - ($newstop - 1)),
  15         22  
284              
285             }
286              
287 35         58 $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 0     0 1 0 my $self = shift;
309 0         0 my $dna = $self->dna;
310 0 0       0 require Bio::PrimarySeq unless Bio::PrimarySeq->can('new');
311 0 0       0 return Bio::PrimarySeq->new(-id => $self->display_name) unless $dna;
312 0         0 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 115     115 1 6943 my $self = shift;
334             my ($ref,$class,$start,$stop,$strand)
335 115         141 = @{$self}{qw(sourceseq class start stop strand)};
  115         241  
336 115         190 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 0     0 1 0 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 0     0 1 0 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 15     15 1 5648 my $self = shift;
391 15         23 my $peer = shift;
392 15 50       43 return unless defined $peer;
393 15 50 33     117 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 15   33     286 && $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 0     0 1 0 my $self = shift;
417 0         0 my $label = $self->refseq;
418 0         0 my $start = $self->start;
419 0         0 my $stop = $self->stop;
420 0         0 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 107     107 1 116 my $self = shift;
439 107         1054 my %h = %$self;
440 107         371 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 0     0 1 0 my $self = shift;
459 0         0 my $g = $self->{error};
460 0 0       0 $self->{error} = shift if @_;
461 0         0 $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 35     35 1 40 my $self = shift;
519 35         59 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 93     93 1 329 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 0     0 1 0 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 occurred. 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 15     15 1 89 my $self = shift;
605 15 100       50 my $hash = $self->{truncated} or return;
606 5 50       16 CORE::ref($hash) eq 'HASH' or return [1,1]; # paranoia -- not that this would ever happen ;-)
607 5         23 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 0     0 1   my $self = shift;
620 0           my($other,$so) = @_;
621 0 0         if ($other->isa('Bio::DB::GFF::RelSegment')) {
622 0 0         return if $self->abs_ref ne $other->abs_ref;
623             }
624 0           $self->SUPER::overlaps(@_);
625             }
626              
627             sub contains {
628 0     0 1   my $self = shift;
629 0           my($other,$so) = @_;
630 0 0         if ($other->isa('Bio::DB::GFF::RelSegment')) {
631 0 0         return if $self->abs_ref ne $other->abs_ref;
632             }
633 0           $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 0     0 1   my $self = shift;
645 0           my($other,$so) = @_;
646 0 0         if ($other->isa('Bio::DB::GFF::RelSegment')) {
647 0 0         return if $self->abs_ref ne $other->abs_ref;
648             }
649 0           $self->SUPER::intersection(@_);
650             }
651             sub union {
652 0     0 1   my $self = shift;
653 0           my($other) = @_;
654 0 0         if ($other->isa('Bio::DB::GFF::RelSegment')) {
655 0 0         return if $self->abs_ref ne $other->abs_ref;
656             }
657 0           $self->SUPER::union(@_);
658             }
659              
660             sub overlap_extent {
661 0     0 1   my $self = shift;
662 0           my($other) = @_;
663 0 0         if ($other->isa('Bio::DB::GFF::RelSegment')) {
664 0 0         return if $self->abs_ref ne $other->abs_ref;
665             }
666 0           $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 implementation 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 0     0 1   my ($obj,$value) = @_;
695              
696 0 0         if( defined $value) {
697 0           $obj->{'primary_id'} = $value;
698             }
699 0 0         if( ! exists $obj->{'primary_id'} ) {
700 0           return "$obj";
701             }
702 0           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 0     0 1   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 implementation, 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 0     0 1   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 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 0     0 1   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 0     0 1   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 for more information
809              
810             =cut
811              
812             sub species {
813 0     0 1   my ($self, $species) = @_;
814 0 0         if ($species) {
815 0           $self->{'species'} = $species;
816             } else {
817 0           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 for more information
831              
832             =cut
833              
834             sub annotation {
835 0     0 1   my ($obj,$value) = @_;
836 0 0 0       if( defined $value || ! defined $obj->{'annotation'} ) {
837 0 0         $value = Bio::Annotation::Collection->new() unless defined $value;
838 0           $obj->{'annotation'} = $value;
839             }
840 0           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 0     0 1   return 0;
856             }
857              
858              
859             1;
860             __END__