#
# bioperl module for Bio::LiveSeq::SeqI
#
# Please direct questions and support issues to <bioperl-l@bioperl.org>
#
# Cared for by Joseph Insana <insana@ebi.ac.uk> <jinsana@gmx.net>
#
# Copyright Joseph Insana
#
# You may distribute this module under the same terms as perl itself
#
# POD documentation - main docs before the code
=head1 NAME
Bio::LiveSeq::SeqI - Abstract sequence interface class for LiveSeq
=head1 SYNOPSIS
# documentation needed
=head1 DESCRIPTION
This class implements BioPerl PrimarySeqI interface for Live Seq objects.
One of the main difference in LiveSequence compared to traditional
"string" sequences is that coordinate systems are flexible. Typically
gene nucleotide numbering starts from 1 at the first character of the
initiator codon (A in ATG). This means that negative positions are
possible and common!
Secondly, the sequence manipulation methods do not return a new
sequence object but change the current object. The current status can
be written out to BioPerl sequence objects.
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to one
of the Bioperl mailing lists. Your participation is much appreciated.
bioperl-l@bioperl.org - General discussion
http://bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Support
Please direct usage questions or support issues to the mailing list:
I<bioperl-l@bioperl.org>
rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution. Bug reports can be submitted via the
web:
https://github.com/bioperl/bioperl-live/issues
=head1 AUTHOR - Joseph A.L. Insana
Email: Insana@ebi.ac.uk, jinsana@gmx.net
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _
Some note on the terminology/notation of method names:
label: a unique pointer to a single nucleotide
position: the position of a nucleotide according to a particular coordinate
system (e.g. counting downstream from a particular label taken as
number 1)
base: the one letter code for a nucleotide (i.e.: "a" "t" "c" "g")
a base is the "value" that an "element" of a "chain" can assume
(see documentation on the Chain datastructure if interested)
=cut
#'
# Let the code begin...
package Bio::LiveSeq::SeqI;
use strict;
use Bio::Tools::CodonTable; # for the translate() function
use base qw(Bio::Root::Root Bio::LiveSeq::ChainI Bio::PrimarySeqI);
=head2 seq
Title : seq
Usage : $string = $obj->seq()
Function: Returns the complete sequence of an object as a string of letters.
Suggested cases are upper case for proteins and lower case for
DNA sequence (IUPAC standard),
Returns : a string
=cut
sub seq {
my $self = shift;
my ($start,$end) = ($self->start(),$self->end());
if ($self->strand() == 1) {
return $self->{'seq'}->down_chain2string($start,undef,$end);
} else { # reverse strand
my $str = $self->{'seq'}->up_chain2string($start,undef,$end);
$str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/;
return $str;
}
}
=head2 all_labels
Title : all_labels
Usage : @labels = $obj->all_labels()
Function: all the labels of every nucleotide an object is composed of
Returns : an array of labels
Args : none
=cut
sub all_labels {
my $self = shift;
my ($start,$end) = ($self->start(),$self->end());
my $labels;
if ($self->strand() == 1) {
$labels=$self->{'seq'}->down_labels($start,$end);
} else {
$labels=$self->{'seq'}->up_labels($start,$end);
}
return (@{$labels});
}
=head2 labelsubseq
Title : labelsubseq
Usage : $dna->labelsubseq();
: $dna->labelsubseq($startlabel);
: $dna->labelsubseq($startlabel,$length);
: $dna->labelsubseq($startlabel,undef,$endlabel);
e.g. : $dna->labelsubseq(4,undef,8);
Function: prints the sequence as string. The difference between labelsubseq
and normal subseq is that it uses /labels/ as arguments, instead
than positions. This allows for faster and more efficient lookup,
skipping the (usually) lengthy conversion of positions into labels.
This is especially useful for manipulating with high power
LiveSeq objects, knowing the labels and exploiting their
usefulness.
Returns : a string
Errorcode -1
Args : without arguments it returns the entire sequence
with a startlabel it returns the sequence downstream that label
if a length is specified, it returns only that number of bases
if an endlabel is specified, it overrides the length argument
and prints instead up to that label (included)
Defaults: $startlabel defaults to the beginning of the entire sequence
$endlabel defaults to the end of the entire sequence
=cut
# NOTE: unsecuremode is to be used /ONLY/ if sure of the start and end labels, especially that they follow each other in the correct order!!!!
sub labelsubseq {
my ($self,$start,$length,$end,$unsecuremode) = @_;
if (defined $unsecuremode && $unsecuremode eq "unsecuremoderequested")
{ # to skip security checks (faster)
unless ($start) {
$start=$self->start;
}
if ($end) {
if ($end == $start) {
$length=1;
undef $end;
} else {
undef $length;
}
} else {
unless ($length) {
$end=$self->end;
}
}
} else {
if ($start) {
unless ($self->{'seq'}->valid($start)) {
$self->warn("Start label not valid"); return (-1);
}
}
if ($end) {
if ($end == $start) {
$length=1;
undef $end;
} else {
unless ($self->{'seq'}->valid($end)) {
$self->warn("End label not valid"); return (-1);
}
unless ($self->follows($start,$end) == 1) {
$self->warn("End label does not follow Start label!"); return (-1);
}
undef $length;
}
}
}
if ($self->strand() == 1) {
return $self->{'seq'}->down_chain2string($start,$length,$end);
} else { # reverse strand
my $str = $self->{'seq'}->up_chain2string($start,$length,$end);
$str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/;
return $str;
}
}
=head2 subseq
Title : subseq
Usage : $substring = $obj->subseq(10,40);
: $substring = $obj->subseq(10,undef,4);
Function: returns the subseq from start to end, where the first base
is 1 and the number is inclusive, ie 1-2 are the first two
bases of the sequence
Start cannot be larger than end but can be equal.
Allows for negative numbers $obj->subseq(-10,-1). By
definition, there is no 0!
-5 -1 1 5
gctagcgcccaac atggctcgctg
This allows one to retrieve sequences upstream from given position.
The precedence is from left to right: if END is given LENGTH is
ignored.
Examples: $obj->subseq(-10,undef,10) returns 10 elements before position 1
$obj->subseq(4,8) returns elements from the 4th to the 8th, inclusive
Returns : a string
Errorcode: -1
Args : start, integer, defaults to start of the sequence
end, integer, '' or undef, defaults to end of the sequence
length, integer, '' or undef
an optional strand (1 or -1) 4th argument
if strand argument is not given, it will default to the object
argment. This argument is useful when a call is issued from a child
of a parent object containing the subseq method
=cut
#'
# check the fact about reverse strand!
# is it feasible? Is it correct? Should we do it? How about exons? Does it
# work when you ask subseq of an exon?
# eliminated now (Mon night)
sub subseq {
##my ($self,$pos1,$pos2,$length,$strand) = @_;
my ($self,$pos1,$pos2,$length,$strand) = @_;
##unless (defined ($strand)) { # if optional [strand] argument not given
## $strand=$self->strand;
##}
$strand=$self->strand;
my ($str,$startlabel,$endlabel);
if (defined ($length)) {
if ($length < 1) {
$self->warn("No sense asking for a subseq of length < 1");
return (-1);
}
}
unless (defined ($pos1)) {
#print "\n##### DEBUG pos1 not defined\n";
$startlabel=$self->start;
} else {
if ($pos1 == 0) { # if position = 0 complain
$self->warn("Position cannot be 0!"); return (-1);
}
##if ($strand == 1) { # CHECK THIS!
if ((defined ($pos2))&&($pos1>$pos2)) {
$self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1);
}
##} else { # CHECK THIS!
## if ((defined ($pos2))&&($pos1<$pos2)) {
## $self->warn("1st position($pos1) cannot be < 2nd position($pos2) on reverse strand!)"; return (-1);
## }
##}
$startlabel=$self->label($pos1);
if ($startlabel < 1) {
$self->warn("position $pos1 not valid as start of subseq!"); return (-1);
}
}
unless (defined ($pos2)) {
#print "\n##### pos2 not defined\n";
unless (defined ($length)) {
$endlabel=$self->end;
}
} else {
if ($pos2 == 0) { # if position = 0 complain
$self->warn("Position cannot be 0!"); return (-1);
}
undef $length;
##if ($strand == 1) { # CHECK THIS!
if ((defined ($pos1))&&($pos1>$pos2)) {
$self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1);
}
##} else { # CHECK THIS!
## if ((defined ($pos1))&&($pos1<$pos2)) {
## $self->warn("1st position($pos1) cannot be < 2nd position($pos2) on reverse strand!"); return (-1);
## }
##}
$endlabel=$self->label($pos2);
if ($endlabel < 1) {
$self->warn("position $pos2 not valid as end of subseq!"); return (-1);
}
}
#print "\n ####DEBUG: start $startlabel end $endlabel length $length strand $strand\n";
if ($strand == 1) {
$str = $self->{'seq'}->down_chain2string($startlabel,$length,$endlabel);
} else { # reverse strand
$str = $self->{'seq'}->up_chain2string($startlabel,$length,$endlabel);
$str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/;
}
return $str;
}
=head2 length
Title : length
Usage : $seq->length();
Function: returns the number of nucleotides (or the number of aminoacids)
in the entire sequence
Returns : an integer
Errorcode -1
Args : none
=cut
sub length {
my $self=shift;
my ($start,$end,$strand)=($self->start(),$self->end(),$self->strand());
if ($strand == 1) {
return $self->{'seq'}->down_subchain_length($start,$end);
} else {
return $self->{'seq'}->up_subchain_length($start,$end);
}
}
=head2 display_id
Title : display_id
Usage : $id_string = $obj->display_id();
Function: returns the display id, alias the common name of the 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 ID
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.
See also: accession_number
Returns : a string
Args : none
=cut
sub display_id {
my ($self,$value) = @_;
if(defined $value) {
$self->{'display_id'} = $value;
}
return $self->{'display_id'};
}
=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.
Notice that primary_id() provides the unique id for the
implemetation, allowing multiple objects to have the same accession
number in a particular implementation.
For objects with no accession_number this method returns "unknown".
Returns : a string
Args : none
=cut
sub accession_number {
my ($self,$value) = @_;
if (defined $value) {
$self->{'accession_number'} = $value;
}
unless (exists $self->{'accession_number'}) {
return "unknown";
} else {
return $self->{'accession_number'};
}
}
=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 primary_id, this method returns
a stringified memory location.
Returns : A string
Args : None
=cut
sub primary_id {
my ($self,$value) = @_;
if(defined $value) {
$self->{'primary_id'} = $value;
}
unless (exists $self->{'primary_id'}) {
return "$self";
} else {
return $self->{'primary_id'};
}
}
=head2 change
Title : change
Usage : $substring = $obj->change('AA', 10);
Function: changes, modifies, mutates the LiveSequence
Examples:
$obj->change('', 10); delete nucleotide #10
$obj->change('', 10, 2); delete two nucleotides starting from #10
$obj->change('G', 10); change nuc #10 to 'G'
$obj->change('GA', 10, 4); replace #10 and 3 following with 'GA'
$obj->change('GA', 10, 2)); is same as $obj->change('GA', 10);
$obj->change('GA', 10, 0 ); insert 'GA' before nucleotide at #10
$obj->change('GA', 10, 1); GA inserted before #10, #10 deleted
$obj->change('GATC', 10, 2); GATC inserted before #10, #10 deleted
$obj->change('GATC', 10, 6); GATC inserted before #10, #10-#15 deleted
Returns : a string of deleted bases (if any) or 1 (everything OK)
Errorcode: -1
Args : seq, string, or '' ('' = undef = 0 = deletion)
start, integer
length, integer (optional)
=cut
sub change {
&positionchange;
}
=head2 positionchange
Title : positionchange
Function: Exactly like change. I.e. change() defaults to positionchange()
=cut
sub positionchange {
my ($self,$newseq,$position,$length)=@_;
unless ($position) {
$self->warn("Position not given or position 0");
return (-1);
}
my $label=$self->label($position);
unless ($label > 0) { # label not found or error
$self->warn("No valid label found at that position!");
return (-1);
}
return ($self->labelchange($newseq,$label,$length));
}
=head2 labelchange
Title : labelchange
Function: Exactly like change but uses a /label/ instead than a position
as second argument. This allows for multiple changes in a LiveSeq
without the burden of recomputing positions. I.e. for a multiple
change in two different points of the LiveSeq, the approach would
be the following: fetch the correct labels out of the two different
positions (method: label($position)) and then use the labelchange()
method to modify the sequence using those labels instead than
relying on the positions (that would have modified after the
first change).
=cut
sub labelchange {
my ($self,$newseq,$label,$length)=@_;
unless ($self->valid($label)) {
if ($self->{'seq'}->valid($label)) {
#$self->warn("Label \'$label\' not valid for executing a LiveSeq change for the object asked but it's ok for DNAlevel change, reverting to that");
shift @_;
return($self->{'seq'}->labelchange(@_));
} else {
$self->warn("Label \'$label\' not valid for executing a LiveSeq change");
return (-1);
}
}
unless ($newseq) { # it means this is a simple deletion
if (defined($length)) {
unless ($length >= 0) {
$self->warn("No sense having length < 0 in a deletion");
return (-1);
}
} else {
$self->warn("Length not defined for deletion!");
return (-1);
}
return $self->_delete($label,$length);
}
my $newseqlength=CORE::length($newseq);
if (defined($length)) {
unless ($length >= 0) {
$self->warn("No sense having length < 0 in a change()");
return (-1);
}
} else {
$length=$newseqlength; # defaults to pointmutation(s)
}
if ($length == 0) { # it means this is a simple insertion, length def&==0
my ($insertbegin,$insertend)=$self->_praeinsert($label,$newseq);
if ($insertbegin == -1) {
return (-1);
} else {
return (1);
}
}
if ($newseqlength == $length) { # it means this is simple pointmutation(s)
return $self->_mutate($label,$newseq,$length);
}
# if we arrived here then change is complex mixture
my $strand=$self->strand();
my $afterendlabel=$self->label($length+1,$label,$strand); # get the label at $length+1 positions after $label
unless ($afterendlabel > 0) { # label not found or error
$self->warn("No valid afterendlabel found for executing the complex mutation!");
return (-1);
}
my $deleted=$self->_delete($label,$length); # first delete length nucs
if ($deleted eq -1) { # if errors
return (-1);
} else { # then insert the newsequence
my ($insertbegin,$insertend)=$self->_praeinsert($afterendlabel,$newseq);
if ($insertbegin == -1) {
return (-1);
} else {
return (1);
}
}
}
# internal methods for change()
# arguments: label for beginning of deletion, new sequence to insert
# returns: labels of beginning and end of the inserted sequence
# errorcode: -1
sub _praeinsert {
my ($self,$label,$newseq)=@_;
my ($insertbegin,$insertend);
my $strand=$self->strand();
if ($strand == 1) {
($insertbegin,$insertend)=($self->{'seq'}->praeinsert_string($newseq,$label));
} else { # since it's reverse strand and we insert in forward direction....
$newseq=reverse($newseq);
$newseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases
($insertend,$insertbegin)=($self->{'seq'}->postinsert_string($newseq,$label));
}
if (($insertbegin==0)||($insertend==0)) {
$self->warn("Some error occurred while inserting!");
return (-1);
} else {
return ($insertbegin,$insertend);
}
}
# arguments: label for beginning of deletion, length of deletion
# returns: string of deleted bases
# errorcode: -1
sub _delete {
my ($self,$label,$length)=@_;
my $strand=$self->strand();
my $endlabel=$self->label($length,$label,$strand); # get the label at $length positions after $label
unless ($endlabel > 0) { # label not found or error
$self->warn("No valid endlabel found for executing the deletion!");
return (-1);
}
# this is important in Transcript to fix exon structure
$self->_deletecheck($label,$endlabel);
my $deletedseq;
if ($strand == 1) {
$deletedseq=$self->{'seq'}->splice_chain($label,undef,$endlabel);
} else {
$deletedseq=$self->{'seq'}->splice_chain($endlabel,undef,$label);
$deletedseq=reverse($deletedseq); # because we are on reverse strand and we cut anyway
# in forward direction
$deletedseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases
}
return ($deletedseq);
}
# empty function, overridden in Transcript, not useful here
sub _deletecheck {
}
# arguments: label for beginning of mutation, newsequence, number of mutations
# returns: 1 all OK
# errorcode: -1
sub _mutate {
my ($self,$label,$newseq,$length)=@_; # length is equal to length(newseq)
my ($i,$base,$nextlabel);
my @labels; # array of labels
my $strand=$self->strand();
if ($length == 1) { # special cases first
@labels=($label);
} else {
my $endlabel=$self->label($length,$label,$strand); # get the label at $length positions after $label
unless ($endlabel > 0) { # label not found or error
$self->warn("No valid endlabel found for executing the mutation!");
return (-1);
}
if ($length == 2) { # another special case
@labels=($label,$endlabel);
} else { # more than 3 bases changed
# this wouldn't work for Transcript
#my $labelsarrayref;
#if ($strand == 1) {
#$labelsarrayref=$self->{'seq'}->down_labels($label,$endlabel);
#} else {
#$labelsarrayref=$self->{'seq'}->up_labels($label,$endlabel);
#}
#@labels=@{$labelsarrayref};
#if ($length != scalar(@labels)) { # not enough labels returned
#$self->warn("Not enough valid labels found for executing the mutation!");
#return (-1);
#}
# this should be more general
@labels=($label); # put the first one
while ($label != $endlabel) {
$nextlabel=$self->label(2,$label,$strand); # retrieve the next label
push (@labels,$nextlabel);
$label=$nextlabel; # move on reference
}
}
}
if ($strand == -1) { # only for reverse strand
$newseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases
}
my $errorcheck; # if not equal to $length after summing for all changes, error did occurr
$i = 0;
foreach $base (split(//,$newseq)) {
$errorcheck += $self->{'seq'}->set_value_at_label($base,$labels[$i]);
$i++;
}
if ($errorcheck != $length) {
$self->warn("Some error occurred while mutating!");
return (-1);
} else {
return (1);
}
}
=head2 valid
Title : valid
Usage : $boolean = $obj->valid($label)
Function: tests if a label exists inside the object
Returns : boolean
Args : label
=cut
# argument: label
# returns: 1 YES 0 NO
sub valid {
my ($self,$label)=@_;
my $checkme;
my @labels=$self->all_labels;
foreach $checkme (@labels) {
if ($label == $checkme) {
return (1); # found
}
}
return (0); # not found
}
=head2 start
Title : start
Usage : $startlabel=$obj->start()
Function: returns the label of the first nucleotide of the object (exon, CDS)
Returns : label
Args : none
=cut
sub start {
my ($self) = @_;
return $self->{'start'}; # common for all classes BUT DNA (which redefines it) and Transcript (that takes the information from the Exons)
}
=head2 end
Title : end
Usage : $endlabel=$obj->end()
Function: returns the label of the last nucleotide of the object (exon, CDS)
Returns : label
Args : none
=cut
sub end {
my ($self) = @_;
return $self->{'end'};
}
=head2 strand
Title : strand
Usage : $strand=$obj->strand()
$obj->strand($strand)
Function: gets or sets strand information, being 1 or -1 (forward or reverse)
Returns : -1 or 1
Args : none OR -1 or 1
=cut
sub strand {
my ($self,$strand) = @_;
if ($strand) {
if (($strand != 1)&&($strand != -1)) {
$self->warn("strand information not changed because strand identifier not valid");
} else {
$self->{'strand'} = $strand;
}
}
return $self->{'strand'};
}
=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.
Returns : a string either 'dna','rna','protein'.
Args : none
=cut
sub alphabet {
my %valid_type = map {$_, 1} qw( dna rna protein );
my ($self,$value) = @_;
if (defined $value) {
$value = 'dna' if $value =~ /dna/i;
$value = 'rna' if $value =~ /rna/i;
unless ( $valid_type{$value} ) {
$self->warn("Molecular type '$value' is not a valid type");
}
$self->{'alphabet'} = $value;
}
return $self->{'alphabet'};
}
=head2 coordinate_start
Title : coordinate_start
Usage : $coordstartlabel=$obj->coordinate_start()
: $coordstartlabel=$obj->coordinate_start($label)
Function: returns and optionally sets the first label of the coordinate
system used
For some objects only labels inside the object or in frame (for
Translation objects) will be allowed to get set as coordinate start
Returns : label. It returns 0 if label not found.
Errorcode -1
Args : an optional reference $label that is position 1
=cut
sub coordinate_start {
my ($self,$label) = @_;
if ($label) {
if ($self->valid($label)) {
$self->{'coordinate_start'} = $label;
} else {
$self->warn("The label you are trying to set as coordinate_start is not valid for this object");
}
}
my $coord_start = $self->{'coordinate_start'};
if ($coord_start) {
return $coord_start;
} else {
return $self->start();
}
}
=head2 label
Title : label
Usage : $seq->label($position)
: $seq->label($position,$firstlabel)
Examples: $nextlabel=$seq->label(2,$label) -> retrieves the following label
: $prevlabel=$seq->label(-1,$label) -> retrieves the preceding label
Function: returns the label of the nucleotide at $position from current
coordinate start
Returns : a label. It returns 0 if label not found.
Errorcode -1
Args : a position,
an optional reference $firstlabel that is to be used as position 1
an optional strand (1 or -1) argument
if strand argument is not given, it will default to the object
argument. This argument is useful when a call is issued from a child
of a parent object containing the subseq method
=cut
sub label {
my ($self,$position,$firstlabel,$strand)=@_;
my $label;
unless (defined ($firstlabel)) {
$firstlabel=$self->coordinate_start;
}
unless ($position) { # if position = 0 complain ?
$self->warn("Position not given or position 0");
return (-1);
}
unless (defined ($strand)) { # if optional [strand] argument not given
$strand=$self->strand;
}
if ($strand == 1) {
if ($position > 0) {
$label=$self->{'seq'}->down_get_label_at_pos($position,$firstlabel)
} else { # if < 0
$label=$self->{'seq'}->up_get_label_at_pos(1 - $position,$firstlabel)
}
} else {
if ($position > 0) {
$label=$self->{'seq'}->up_get_label_at_pos($position,$firstlabel)
} else { # if < 0
$label=$self->{'seq'}->down_get_label_at_pos(1 - $position,$firstlabel)
}
}
return $label;
}
=head2 position
Title : position
Usage : $seq->position($label)
: $seq->position($label,$firstlabel)
Function: returns the position of nucleotide at $label
Returns : the position of the label from current coordinate start
Errorcode 0
Args : a label pointing to a certain nucleotide (e.g. start of exon)
an optional "firstlabel" as reference to count from
an optional strand (1 or -1) argument
if strand argument is not given, it will default to the object
argument. This argument is useful when a call is issued from a child
of a parent object containing the subseq method
=cut
sub position {
my ($self,$label,$firstlabel,$strand)=@_;
unless (defined ($strand)) { # if optional [strand] argument not given
$strand=$self->strand;
}
unless (defined ($firstlabel)) {
$firstlabel=$self->coordinate_start;
}
unless ($self->valid($label)) {
$self->warn("label not valid");
return (0);
}
if ($firstlabel == $label) {
return (1);
}
my ($coordpos,$position0,$position);
$position0=$self->{'seq'}->down_get_pos_of_label($label);
$coordpos=$self->{'seq'}->down_get_pos_of_label($firstlabel);
$position=$position0-$coordpos+1;
if ($position <= 0) {
$position--;
}
if ($strand == -1) {
#print "\n----------DEBUGSEQPOS label $label firstlabel $firstlabel strand $strand: position=",1-$position;
return (1-$position);
} else {
#print "\n----------DEBUGSEQPOS label $label firstlabel $firstlabel strand $strand: position=",$position;
return ($position);
}
}
=head2 follows
Title : follows
Usage : $seq->follows($firstlabel,$secondlabel)
: $seq->follows($firstlabel,$secondlabel,$strand)
Function: checks if SECONDlabel follows FIRSTlabel, undependent of the strand
i.e. it checks downstream for forward strand and
upstream for reverse strand
Returns : 1 or 0
Errorcode -1
Args : two labels
an optional strand (1 or -1) argument
if strand argument is not given, it will default to the object
argument. This argument is useful when a call is issued from a child
of a parent object containing the subseq method
=cut
#'
# wraparound to is_downstream and is_upstream that chooses the correct one
# depending on the strand
sub follows {
my ($self,$firstlabel,$secondlabel,$strand)=@_;
unless (defined ($strand)) { # if optional [strand] argument not given
$strand=$self->strand;
}
if ($strand == 1) {
return ($self->{'seq'}->is_downstream($firstlabel,$secondlabel));
} else {
return ($self->{'seq'}->is_upstream($firstlabel,$secondlabel));
}
}
#
#=head2 translate
#
# Title : translate
# Usage : $protein_seq = $obj->translate
# Function: Provides the translation of the DNA sequence
# using full IUPAC ambiguities in DNA/RNA and amino acid codes.
#
# The resulting translation is identical to EMBL/TREMBL database
# translations.
#
# Returns : a string
# Args : character for terminator (optional) defaults to '*'
# character for unknown amino acid (optional) defaults to 'X'
# frame (optional) valid values 0, 1, 3, defaults to 0
# codon table id (optional) defaults to 1
#
#=cut
#
#sub translate {
# my ($self) = shift;
# return ($self->translate_string($self->seq,@_));
#}
#
#=head2 translate_string
#
# Title : translate_string
# Usage : $protein_seq = $obj->translate_string("attcgtgttgatcgatta");
# Function: Like translate, but can be used to translate subsequences after
# having retrieved them as string.
# Args : 1st argument is a string. Optional following arguments: like in
# the translate method
#
#=cut
#
#
#sub translate_string {
# my($self) = shift;
# my($seq) = shift;
# my($stop, $unknown, $frame, $tableid) = @_;
# my($i, $len, $output) = (0,0,'');
# my($codon) = "";
# my $aa;
#
#
# ## User can pass in symbol for stop and unknown codons
# unless(defined($stop) and $stop ne '') { $stop = "*"; }
# unless(defined($unknown) and $unknown ne '') { $unknown = "X"; }
# unless(defined($frame) and $frame ne '') { $frame = 0; }
#
# ## the codon table ID
# if ($self->translation_table) {
# $tableid = $self->translation_table;
# }
# unless(defined($tableid) and $tableid ne '') { $tableid = 1; }
#
# ##Error if monomer is "Amino"
# $self->warn("Can't translate an amino acid sequence.")
# if (defined $self->alphabet && $self->alphabet eq 'protein');
#
# ##Error if frame is not 0, 1 or 2
# $self->warn("Valid values for frame are 0, 1, 2, not [$frame].")
# unless ($frame == 0 or $frame == 1 or $frame == 2);
#
# #thows a warning if ID is invalid
# my $codonTable = Bio::Tools::CodonTable->new( -id => $tableid);
#
# # deal with frame offset.
# if( $frame ) {
# $seq = substr ($seq,$frame);
# }
#
# for $codon ( grep { CORE::length == 3 } split(/(.{3})/, $seq) ) {
# my $aa = $codonTable->translate($codon);
# if ($aa eq '*') {
# $output .= $stop;
# }
# elsif ($aa eq 'X') {
# $output .= $unknown;
# }
# else {
# $output .= $aa ;
# }
# }
# #if( substr($output,-1,1) eq $stop ) {
# # chop $output;
# #}
#
# return ($output);
#}
=head2 gene
Title : gene
Usage : my $gene=$obj->gene;
Function: Gets or sets the reference to the LiveSeq::Gene object.
Objects that are features of a LiveSeq Gene will have this
attribute set automatically.
Returns : reference to an object of class Gene
Note : if Gene object is not set, this method will return 0;
Args : none or reference to object of class Bio::LiveSeq::Gene
=cut
sub gene {
my ($self,$value) = @_;
if (defined $value) {
$self->{'gene'} = $value;
}
unless (exists $self->{'gene'}) {
return (0);
} else {
return $self->{'gene'};
}
}
=head2 obj_valid
Title : obj_valid
Usage : if ($obj->obj_valid) {do something;}
Function: Checks if start and end labels are still valid for the ojbect,
i.e. tests if the LiveSeq object is still valid
Returns : boolean
Args : none
=cut
sub obj_valid {
my $self=shift;
unless (($self->{'seq'}->valid($self->start()))&&($self->{'seq'}->valid($self->end()))) {
return (0);
}
return (1);
}
=head2 name
Title : name
Usage : $name = $obj->name;
: $name = $obj->name("ABCD");
Function: Returns or sets the name of the object.
If there is no name, it will return "unknown";
Returns : A string
Args : None
=cut
sub name {
my ($self,$value) = @_;
if (defined $value) {
$self->{'name'} = $value;
}
unless (exists $self->{'name'}) {
return "unknown";
} else {
return $self->{'name'};
}
}
=head2 desc
Title : desc
Usage : $desc = $obj->desc;
: $desc = $obj->desc("ABCD");
Function: Returns or sets the description of the object.
If there is no description, it will return "unknown";
Returns : A string
Args : None
=cut
sub desc {
my ($self,$value) = @_;
if (defined $value) {
$self->{'desc'} = $value;
}
unless (exists $self->{'desc'}) {
return "unknown";
} else {
return $self->{'desc'};
}
}
=head2 source
Title : source
Usage : $name = $obj->source;
: $name = $obj->source("Homo sapiens");
Function: Returns or sets the organism that is source of the object.
If there is no source, it will return "unknown";
Returns : A string
Args : None
=cut
sub source {
my ($self,$value) = @_;
if (defined $value) {
$self->{'source'} = $value;
}
unless (exists $self->{'source'}) {
return "unknown";
} else {
return $self->{'source'};
}
}
sub delete_Obj {
my $self = shift;
my @values= values %{$self};
my @keys= keys %{$self};
foreach my $key ( @keys ) {
delete $self->{$key};
}
foreach my $value ( @values ) {
if (index(ref($value),"LiveSeq") != -1) { # object case
eval {
# delete $self->{$value};
$value->delete_Obj;
};
} elsif (index(ref($value),"ARRAY") != -1) { # array case
my @array=@{$value};
my $element;
foreach $element (@array) {
eval {
$element->delete_Obj;
};
}
} elsif (index(ref($value),"HASH") != -1) { # object case
my %hash=%{$value};
my $element;
foreach $element (%hash) {
eval {
$element->delete_Obj;
};
}
}
}
return(1);
}
1;