Raw content of Bio::LiveSeq::Chain
<![CDATA[#!/usr/bin/perl
# $Id: Chain.pm,v 1.12 2001/06/18 08:27:53 heikki Exp $
#
# bioperl module for Bio::LiveSeq::Chain
#
# 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::Chain - DoubleChain DataStructure for Perl
=head1 SYNOPSIS
#documentation needed
=head1 DESCRIPTION
This is a general purpose module (that's why it's not in object-oriented
form) that introduces a novel datastructure in PERL. It implements
the "double linked chain". The elements of the chain can contain basically
everything. From chars to strings, from object references to arrays or hashes.
It is used in the LiveSequence project to create a dynamical DNA sequence,
easier to manipulate and change. It's use is mainly for sequence variation
analysis but it could be used - for example - in e-cell projects.
The Chain module in itself doesn't have any biological bias, so can be
used for any programming purpose.
Each element of the chain (with the exclusion of the first and the last of the
chain) is connected to other two elements (the PREVious and the NEXT one).
There is no absolute position (like in an array), hence if positions are
important, they need to be computed (methods are provided).
Otherwise it's easy to keep track of the elements with their "LABELs".
There is one LABEL (think of it as a pointer) to each ELEMENT. The labels
won't change after insertions or deletions of the chain. So it's
always possible to retrieve an element even if the chain has been
modified by successive insertions or deletions.
From this the high potential profit for bioinformatics: dealing with
sequences in a way that doesn't have to rely on positions, without
the need of constantly updating them if the sequence changes, even
dramatically.
=head1 AUTHOR - Joseph A.L. Insana
Email: Insana@ebi.ac.uk, jinsana@gmx.net
Address:
EMBL Outstation, European Bioinformatics Institute
Wellcome Trust Genome Campus, Hinxton
Cambs. CB10 1SD, United Kingdom
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _
=cut
# Let the code begin...
# DoubleChain Data Structure for PERL
# by Joseph A.L. Insana - Deathson - Filius Mortis - Fal Mortais
# insana@ebi.ac.uk, jinsana@gmx.net
package Bio::LiveSeq::Chain;
# Version history:
# Fri Mar 10 16:46:51 GMT 2000 v1.0 begun working on chains in perl
# Sat Mar 11 05:47:21 GMT 2000 v.1.4 working on splice method
# Sun Mar 12 14:08:31 GMT 2000 v.1.5
# Sun Mar 12 17:21:51 GMT 2000 v.2.0 splice method working, is_updownstream made
# Sun Mar 12 18:11:22 GMT 2000 v.2.04 wrapped all in package Chain.pm
# Sun Mar 12 18:49:23 GMT 2000 v.2.08 added elements()
# Sun Mar 12 21:18:04 GMT 2000 v.2.1 done array2dchain, working on *insert*
# Sun Mar 12 23:04:40 GMT 2000 v.2.16 done *insert*, up_element, create_elems
# Sun Mar 12 23:45:32 GMT 2000 v.2.17 debugged and checked
# Mon Mar 13 00:44:51 GMT 2000 v.2.2 added mutate()
# Mon Mar 13 02:00:32 GMT 2000 v 2.21 added invert_dchain()
# Mon Mar 13 03:01:21 GMT 2000 v 2.22 created updown_chain2string
# Mon Mar 13 03:45:50 GMT 2000 v.2.24 added subchain_length()
# Mon Mar 13 17:25:04 GMT 2000 v.2.26 added element_at_pos and pos_of_element
# Wed Mar 15 23:05:06 GMT 2000 v.2.27 use strict enforced
# Thu Mar 16 19:05:34 GMT 2000 v.2.3 changed dchain->chain everywhere
# Fri Mar 17 01:48:36 GMT 2000 v.2.33 mutate_element renamed, created new
# methods: set_value, get_value...
# Fri Mar 17 05:03:15 GMT 2000 v.2.4 set_value_at_pos, get_value_at_pos
# get_label_at_pos...
# Fri Mar 17 15:51:07 GMT 2000 v.2.41 renamed pos_of_element -> get_pos_of_label
# Fri Mar 17 18:10:36 GMT 2000 v.2.44 recoded subchain_length and pos_of_label
# Fri Mar 17 20:12:27 GMT 2000 v.2.5 NAMING change: index->label everywhere
# Mon Mar 20 18:33:10 GMT 2000 v.2.52 label_exists(), start(), end()
# Mon Mar 20 23:10:28 GMT 2000 v.2.6 labels() created
# Wed Mar 22 18:35:17 GMT 2000 v.2.61 chain2string() rewritten
# Tue Dec 12 14:47:58 GMT 2000 v 2.66 optimized with /use integer/
# Tue Dec 12 16:28:45 GMT 2000 v 2.7 rewritten comments to methods in pod style
#
$VERSION=2.7;
#
# TODO_list:
# **** cleanup code
# **** performance concerns
# *??* create hash2dchain ???? (with hashkeys used for label)
# **????** how about using array of arrays instead than hash of arrays??
#
# further strict complaints:
# in verbose $string assignment around line 721 ???
# TERMINOLOGY update, naming convention:
# "chain" the datastructure
# "element" the individual units that compose a chain
# "label" the unique name of a single element
# "position" the position of an element into the chain according to a
# particular coordinate system (e.g. counting from the start)
# "value" what is stored in a single element
use Carp qw(croak cluck carp); # as of 2.3
use strict; # as of 2.27
use integer; # WARNING: this is to increase performance
# a little bit of attention has to be given if float need to
# be stored as elements of the array
# the use of this "integer" affects all operations but not
# assignments. So float CAN be assigned as elements of the chain
# BUT, if you assign $z=-1.8;, $z will be equal to -1 because
# "-" counts as a unary operation!
=head2 _updown_chain2string
Title : chain2string
Usage : $string = Bio::LiveSeq::Chain::chain2string("down",$chain,6,9)
Function: reads the contents of the chain, outputting a string
Returns : a string
Examples:
: down_chain2string($chain) -> all the chain from begin to end
: down_chain2string($chain,6) -> from 6 to the end
: down_chain2string($chain,6,4) -> from 6, going on 4 elements
: down_chain2string($chain,6,"",10) -> from 6 to 10
: up_chain2string($chain,10,"",6) -> from 10 to 6 upstream
Defaults: start=first element; if len undef, goes to last
if last undef, goes to end
if last defined, it overrides len (undefining it)
Error code: -1
Args : "up"||"down" as first argument to specify the reading direction
reference (to the chain)
[first] [len] [last] optional integer arguments to specify how
much and from (and to) where to read
=cut
# methods rewritten 2.61
sub up_chain2string {
_updown_chain2string("up",@_);
}
sub down_chain2string {
_updown_chain2string("down",@_);
}
sub _updown_chain2string {
my ($direction,$chain,$first,$len,$last)=@_;
unless($chain) { cluck "no chain input"; return (-1); }
my $begin=$chain->{'begin'}; # the label of the BEGIN element
my $end=$chain->{'end'}; # the label of the END element
my $flow;
if ($direction eq "up") {
$flow=2; # used to determine the direction of chain navigation
unless ($first) { $first=$end; } # if undef or 0, use $end
} else { # defaults to "down"
$flow=1; # used to determine the direction of chain navigation
unless ($first) { $first=$begin; } # if undef or 0, use $begin
}
unless($chain->{$first}) {
cluck "label for first not defined"; return (-1); }
if ($last) { # if last is defined, it gets priority and len is not used
unless($chain->{$last}) {
cluck "label for last not defined"; return (-1); }
if ($len) {
warn "Warning chain2string: argument LAST:$last overriding LEN:$len!";
undef $len;
}
} else {
if ($direction eq "up") {
$last=$begin; # if last not defined, go 'till begin (or upto len elements)
} else {
$last=$end; # if last not defined, go 'till end (or upto len elements)
}
}
my ($string,@array);
my $label=$first; my $i=1;
my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
unless (defined $afterlast) { $afterlast=0; } # keep strict happy
# proceed for len elements or until last, whichever comes first
# if $len undef goes till end
while (($label) && ($label != $afterlast) && ($i <= ($len || $i + 1))) {
@array=@{$chain->{$label}};
$string .= $array[0];
$label = $array[$flow];
$i++;
}
return ($string); # if chain is interrupted $string won't be complete
}
=head2 _updown_labels
Title : labels
Usage : @labels = Bio::LiveSeq::Chain::_updown_labels("down",$chain,4,16)
Function: returns all the labels in a chain or those between two
specified ones (termed "first" and "last")
Returns : a reference to an array containing the labels
Args : "up"||"down" as first argument to specify the reading direction
reference (to the chain)
[first] [last] (integer for the starting and eneding labels)
=cut
# arguments: CHAIN_REF [FIRSTLABEL] [LASTLABEL]
# returns: reference to array containing the labels
sub down_labels {
my ($chain,$first,$last)=@_;
_updown_labels("down",$chain,$first,$last);
}
sub up_labels {
my ($chain,$first,$last)=@_;
_updown_labels("up",$chain,$first,$last);
}
# arguments: "up"||"down" CHAIN_REF [FIRSTLABEL] [LASTLABEL]
# returns: reference to array containing the labels
sub _updown_labels {
my ($direction,$chain,$first,$last)=@_;
unless($chain) { cluck "no chain input"; return (0); }
my $begin=$chain->{'begin'}; # the label of the BEGIN element
my $end=$chain->{'end'}; # the label of the END element
my $flow;
if ($direction eq "up") { $flow=2;
unless ($first) { $first=$end; }
unless ($last) { $last=$begin; }
} else { $flow=1;
unless ($last) { $last=$end; }
unless ($first) { $first=$begin; }
}
unless($chain->{$first}) { warn "not existing label $first"; return (0); }
unless($chain->{$last}) { warn "not existing label $last"; return (0); }
my $label=$first; my @labels;
my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
unless (defined $afterlast) { $afterlast=0; } # keep strict happy
while (($label)&&($label != $afterlast)) {
push(@labels,$label);
$label=$chain->{$label}[$flow];
}
return (\@labels); # if chain is interrupted @labels won't be complete
}
=head2 start
Title : start
Usage : $start = Bio::LiveSeq::Chain::start()
Returns : the label marking the start of the chain
Errorcode: -1
Args : none
=cut
sub start {
my $chain=$_[0];
unless($chain) { cluck "no chain input"; return (-1); }
return ($chain->{'begin'});
}
=head2 end
Title : end
Usage : $end = Bio::LiveSeq::Chain::end()
Returns : the label marking the end of the chain
Errorcode: -1
Args : none
=cut
sub end {
my $chain=$_[0];
unless($chain) { cluck "no chain input"; return (-1); }
return ($chain->{'end'});
}
=head2 label_exists
Title : label_exists
Usage : $check = Bio::LiveSeq::Chain::label_exists($chain,$label)
Function: It checks if a label is defined, i.e. if an element is there or
is not there anymore
Returns : 1 if the label exists, 0 if it is not there, -1 error
Errorcode: -1
Args : reference to the chain, integer
=cut
sub label_exists {
my ($chain,$label)=@_;
unless($chain) { cluck "no chain input"; return (-1); }
if ($label && $chain->{$label}) { return (1); } else { return (0) };
}
=head2 down_get_pos_of_label
Title : down_get_pos_of_label
Usage : $position = Bio::LiveSeq::Chain::down_get_pos_of_label($chain,$label,$first)
Function: returns the position of $label counting from $first, i.e. taking
$first as 1 of coordinate system. If $first is not specified it will
count from the start of the chain.
Returns :
Errorcode: 0
Args : reference to the chain, integer (the label of interest)
optional: integer (a different label that will be taken as the
first one, i.e. the one to count from)
Note: It counts "downstream". To proceed backward use up_get_pos_of_label
=cut
sub down_get_pos_of_label {
#down_chain2string($_[0],$_[2],undef,$_[1],"counting");
my ($chain,$label,$first)=@_;
_updown_count("down",$chain,$first,$label);
}
sub up_get_pos_of_label {
#up_chain2string($_[0],$_[2],undef,$_[1],"counting");
my ($chain,$label,$first)=@_;
_updown_count("up",$chain,$first,$label);
}
=head2 down_subchain_length
Title : down_subchain_length
Usage : $length = Bio::LiveSeq::Chain::down_subchain_length($chain,$first,$last)
Function: returns the length of the chain between the labels "first" and "last", included
Returns : integer
Errorcode: 0
Args : reference to the chain, integer, integer
Note: It counts "downstream". To proceed backward use up_subchain_length
=cut
# arguments: chain_ref [first] [last]
# returns the length of the chain between first and last (included)
sub down_subchain_length {
#down_chain2string($_[0],$_[1],undef,$_[2],"counting");
my ($chain,$first,$last)=@_;
_updown_count("down",$chain,$first,$last);
}
sub up_subchain_length {
#up_chain2string($_[0],$_[1],undef,$_[2],"counting");
my ($chain,$first,$last)=@_;
_updown_count("up",$chain,$first,$last);
}
# arguments: DIRECTION CHAIN_REF FIRSTLABEL LASTLABEL
# errorcode 0
sub _updown_count {
my ($direction,$chain,$first,$last)=@_;
unless($chain) { cluck "no chain input"; return (0); }
my $begin=$chain->{'begin'}; # the label of the BEGIN element
my $end=$chain->{'end'}; # the label of the END element
my $flow;
if ($direction eq "up") { $flow=2;
unless ($first) { $first=$end; }
unless ($last) { $last=$begin; }
} else { $flow=1;
unless ($last) { $last=$end; }
unless ($first) { $first=$begin; }
}
unless($chain->{$first}) { warn "not existing label $first"; return (0); }
unless($chain->{$last}) { warn "not existing label $last"; return (0); }
my $label=$first; my $count;
my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
unless (defined $afterlast) { $afterlast=0; } # keep strict happy
while (($label)&&($label != $afterlast)) {
$count++;
$label=$chain->{$label}[$flow];
}
return ($count); # if chain is interrupted, $i will be up to the breaking point
}
=head2 invert_chain
Title : invert_chain
Usage : $errorcode=Bio::LiveSeq::Chain::invert_chain($chain)
Function: completely inverts the order of the chain elements; begin is swapped with end and all links updated (PREV&NEXT fields swapped)
Returns : 1 if all OK, 0 if errors
Errorcode: 0
Args : reference to the chain
=cut
sub invert_chain {
my $chain=$_[0];
unless($chain) { cluck "no chain input"; return (0); }
my $begin=$chain->{'begin'}; # the name of the first element
my $end=$chain->{'end'}; # the name of the last element
my ($label,@array);
$label=$begin; # starts from the beginning
while ($label) { # proceed with linked elements, swapping PREV and NEXT
@array=@{$chain->{$label}};
($chain->{$label}[1],$chain->{$label}[2])=($array[2],$array[1]); # swap
$label = $array[1]; # go to the next one
}
# now swap begin and end fields
($chain->{'begin'},$chain->{'end'})=($end,$begin);
return (1); # that's it
}
# warning that method has changed name
#sub mutate_element {
#croak "Warning: old method name. Please update code to 'set_value_at_label'\n";
# &set_value_at_label;
#}
=head2 down_get_value_at_pos
Title : down_get_value_at_pos
Usage : $value = Bio::LiveSeq::Chain::down_get_value_at_pos($chain,$position,$first)
Function: used to access the value of the chain at a particular position instead than directly with a label pointer. It will count the position from the start of the chain or from the label $first, if $first is specified
Returns : whatever is stored in the element of the chain
Errorcode: 0
Args : reference to the chain, integer, [integer]
Note: It works "downstream". To proceed backward use up_get_value_at_pos
=cut
#sub get_value_at_pos {
#croak "Please use instead: down_get_value_at_pos";
##&down_get_value_at_pos;
#}
sub down_get_value_at_pos {
my ($chain,$position,$first)=@_;
my $label=down_get_label_at_pos($chain,$position,$first);
# check place of change
if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
warn "not existing element $label"; return (0); }
return _get_value($chain,$label);
}
sub up_get_value_at_pos {
my ($chain,$position,$first)=@_;
my $label=up_get_label_at_pos($chain,$position,$first);
# check place of change
if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
warn "not existing element $label"; return (0); }
return _get_value($chain,$label);
}
=head2 down_set_value_at_pos
Title : down_set_value_at_pos
Usage : $errorcode = Bio::LiveSeq::Chain::down_set_value_at_pos($chain,$newvalue,$position,$first)
Function: used to store a new value inside an element of the chain at a particular position instead than directly with a label pointer. It will count the position from the start of the chain or from the label $first, if $first is specified
Returns : 1
Errorcode: 0
Args : reference to the chain, newvalue, integer, [integer]
(newvalue can be: integer, string, object reference, hash ref)
Note: It works "downstream". To proceed backward use up_set_value_at_pos
Note2: If the $newvalue is undef, it will delete the contents of the
element but it won't remove the element from the chain.
=cut
#sub set_value_at_pos {
#croak "Please use instead: down_set_value_at_pos";
##&down_set_value_at_pos;
#}
sub down_set_value_at_pos {
my ($chain,$value,$position,$first)=@_;
my $label=down_get_label_at_pos($chain,$position,$first);
# check place of change
if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
warn "not existing element $label"; return (0); }
_set_value($chain,$label,$value);
return (1);
}
sub up_set_value_at_pos {
my ($chain,$value,$position,$first)=@_;
my $label=up_get_label_at_pos($chain,$position,$first);
# check place of change
if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
warn "not existing element $label"; return (0); }
_set_value($chain,$label,$value);
return (1);
}
=head2 down_set_value_at_label
Title : down_set_value_at_label
Usage : $errorcode = Bio::LiveSeq::Chain::down_set_value_at_label($chain,$newvalue,$label)
Function: used to store a new value inside an element of the chain defined by its label.
Returns : 1
Errorcode: 0
Args : reference to the chain, newvalue, integer
(newvalue can be: integer, string, object reference, hash ref)
Note: It works "downstream". To proceed backward use up_set_value_at_label
Note2: If the $newvalue is undef, it will delete the contents of the
element but it won't remove the element from the chain.
=cut
sub set_value_at_label {
my ($chain,$value,$label)=@_;
unless($chain) { cluck "no chain input"; return (0); }
# check place of change
unless($chain->{$label}) { # complain if label doesn't exist
warn "not existing element $label"; return (0); }
_set_value($chain,$label,$value);
return (1);
}
=head2 down_get_value_at_label
Title : down_get_value_at_label
Usage : $value = Bio::LiveSeq::Chain::down_get_value_at_label($chain,$label)
Function: used to access the value of the chain from one element defined by its label.
Returns : whatever is stored in the element of the chain
Errorcode: 0
Args : reference to the chain, integer
Note: It works "downstream". To proceed backward use up_get_value_at_label
=cut
sub get_value_at_label {
my $chain=$_[0];
unless($chain) { cluck "no chain input"; return (0); }
my $label = $_[1]; # the name of the element
# check place of change
unless($chain->{$label}) { # complain if label doesn't exist
warn "not existing label $label"; return (0); }
return _get_value($chain,$label);
}
# arguments: CHAIN_REF LABEL VALUE
sub _set_value {
my ($chain,$label,$value)=@_;
$chain->{$label}[0]=$value;
}
# arguments: CHAIN_REF LABEL
sub _get_value {
my ($chain,$label)=@_;
return $chain->{$label}[0];
}
=head2 down_get_label_at_pos
Title : down_get_label_at_pos
Usage : $label = Bio::LiveSeq::Chain::down_get_label_at_pos($chain,$position,$first)
Function: used to retrieve the label of an an element of the chain at a particular position. It will count the position from the start of the chain or from the label $first, if $first is specified
Returns : integer
Errorcode: 0
Args : reference to the chain, integer, [integer]
Note: It works "downstream". To proceed backward use up_get_label_at_pos
=cut
# arguments: CHAIN_REF POSITION [FIRST]
# returns: LABEL of element found counting from FIRST
sub down_get_label_at_pos {
_updown_get_label_at_pos("down",@_);
}
sub up_get_label_at_pos {
_updown_get_label_at_pos("up",@_);
}
# arguments: [DIRECTION] CHAIN_REF POSITION [FIRST]
# Default DIRECTION="down"
# if FIRST is undefined, FIRST=START (if DIRECTION=down) or FIRST=END (up)
sub _updown_get_label_at_pos {
my ($direction,$chain,$position,$first)=@_;
unless($chain) { cluck "no chain input"; return (0); }
my $begin=$chain->{'begin'}; # the label of the BEGIN element
my $end=$chain->{'end'}; # the label of the END element
my $flow;
if ($direction eq "up") { $flow=2; unless ($first) { $first=$end; }
} else { $flow=1; unless ($first) { $first=$begin; } }
unless($chain->{$first}) { warn "not existing label $first"; return (0); }
my $label=$first;
my $i=1;
while ($i < $position) {
$label=$chain->{$label}[$flow];
$i++;
unless ($label) { return (0); } # chain ended before position reached
}
return ($label);
}
# for english_concerned, latin_unconcerned people
sub preinsert_string { &praeinsert_string }
sub preinsert_array { &praeinsert_array }
# praeinsert_string CHAIN_REF STRING [POSITION]
# the chars of STRING are passed to praeinsert_array
# the chars are inserted in CHAIN, before POSITION
# if POSITION is undef, default is to prepend the string to the beginning
# i.e. POSITION is START of CHAIN
sub praeinsert_string {
my @string=split(//,$_[1]);
praeinsert_array($_[0],\@string,$_[2]);
}
# postinsert_string CHAIN_REF STRING [POSITION]
# the chars of STRING are passed to postinsert_array
# the chars are inserted in CHAIN, after POSITION
# if POSITION is undef, default is to append the string to the end
# i.e. POSITION is END of CHAIN
sub postinsert_string {
my @string=split(//,$_[1]);
postinsert_array($_[0],\@string,$_[2]);
}
# praeinsert_array CHAIN_REF ARRAY_REF [POSITION]
# the elements of ARRAY are inserted in CHAIN, before POSITION
# if POSITION is undef, default is to prepend the elements to the beginning
# i.e. POSITION is START of CHAIN
sub praeinsert_array {
_praepostinsert_array($_[0],"prae",$_[1],$_[2]);
}
# postinsert_array CHAIN_REF ARRAY_REF [POSITION]
# the elements of ARRAY are inserted in CHAIN, after POSITION
# if POSITION is undef, default is to append the elements to the end
# i.e. POSITION is END of CHAIN
sub postinsert_array {
_praepostinsert_array($_[0],"post",$_[1],$_[2]);
}
=head2 _praepostinsert_array
Title : _praepostinsert_array
Usage : ($insbegin,$insend) = Bio::LiveSeq::Chain::_praepostinsert_array($chainref,"post",$arrayref,$position)
Function: the elements of the array specified by $arrayref are inserted (creating a new subchain) in the chain specified by $chainref, before or after (depending on the "prae"||"post" keyword passed as second argument) the specified position.
Returns : two labels: the first and the last of the inserted subchain
Defaults: if no position is specified, the new chain will be inserted after
(post) the first element of the chain
Errorcode: 0
Args : chainref, "prae"||"post", arrayref, integer (position)
=cut
# returns: 0 if errors, otherwise returns references of begin and end of
# the insertion
sub _praepostinsert_array {
my $chain=$_[0];
unless($chain) { cluck "no chain input"; return (0); }
my $praepost=$_[1] || "post"; # defaults to post
my ($prae,$post);
my $position=$_[3];
my $begin=$chain->{'begin'}; # the name of the first element of the chain
my $end=$chain->{'end'}; # the name of the the last element of the chain
# check if prae or post insertion and prepare accordingly
if ($praepost eq "prae") {
$prae=1;
unless (($position eq 0)||($position)) { $position=$begin; } # if undef, use $begin
} else {
$post=1;
unless (($position eq 0)||($position)) { $position=$end; } # if undef, use $end
}
# check place of insertion
unless($chain->{$position}) { # complain if position doesn't exist
warn ("Warning _praepostinsert_array: not existing element $position");
return (0);
}
# check if there are elements to insert
my $elements=$_[2]; # reference to the array containing the new elements
my $elements_count=scalar(@{$elements});
unless ($elements_count) {
warn ("Warning _praepostinsert_array: no elements input"); return (0); }
# create new chainelements with offset=firstfree(chain)
my ($insertbegin,$insertend)=_create_chain_elements($chain,$elements);
# DEBUGGING
#print "Executing ${praepost}insertion of $elements_count elements ('@{$elements}') at position: $position\n";
# attach the new chain to the old chain
# 4 cases: prae@begin, prae@middle, post@middle, post@end
# NOTE: in case of double joinings always join wisely so not to
# delete the PREV/NEXT attribute before it is needed
my $noerror=1;
if ($prae) {
if ($position==$begin) { # 1st case: prae@begin
$noerror=_join_chain_elements($chain,$insertend,$begin);
$chain->{'begin'}=$insertbegin;
} else { # 2nd case: prae@middle
$noerror=_join_chain_elements($chain,up_element($chain,$position),$insertbegin);
$noerror=_join_chain_elements($chain,$insertend,$position);
}
} elsif ($post) {
if ($position==$end) { # 4th case: post@end
$noerror=_join_chain_elements($chain,$end,$insertbegin);
$chain->{'end'}=$insertend;
} else { # 3rd case: post@middle # note the order of joins (important)
$noerror=_join_chain_elements($chain,$insertend,down_element($chain,$position));
$noerror=_join_chain_elements($chain,$position,$insertbegin);
}
} else { # this should never happen
die "_praepostinsert_array: Something went very wrong";
}
# check for errors and return begin,end of insertion
if ($noerror) {
return ($insertbegin,$insertend);
} else { # something went wrong with the joinings
warn "Warning _praepostinsert_array: Joining of insertion failed";
return (0);
}
}
# create new chain elements with offset=firstfree
# arguments: CHAIN_REF ARRAY_REF
# returns: pointers to BEGIN and END of new chained elements created
# returns 0 if error(s) encountered
sub _create_chain_elements {
my $chain=$_[0];
unless($chain) {
warn ("Warning _create_chain_elements: no chain input"); return (0); }
my $arrayref=$_[1];
my $array_count=scalar(@{$arrayref});
unless ($array_count) {
warn ("Warning _create_chain_elements: no elements input"); return (0); }
my $begin=$chain->{'firstfree'};
my $i=$begin-1;
my $element;
foreach $element (@{$arrayref}) {
$i++;
$chain->{$i}=[$element,$i+1,$i-1];
}
my $end=$i;
$chain->{'firstfree'}=$i+1; # what a new added element should be called
$chain->{'size'} += $end-$begin+1; # increase size of chain
# leave sticky edges (to be joined by whoever called this subroutine)
$chain->{$begin}[2]=undef;
$chain->{$end}[1]=undef;
return ($begin,$end); # return pointers to first and last of the newelements
}
# argument: CHAIN_REF ELEMENT
# returns: name of DOWN/NEXT element (the downstream one)
# returns -1 if error encountered (e.g. chain or elements undefined)
# returns 0 if there's no DOWN element
sub down_element {
_updown_element("down",@_);
}
# argument: CHAIN_REF ELEMENT
# returns: name of UP/PREV element (the upstream one)
# returns -1 if error encountered (e.g. chain or elements undefined)
# returns 0 if there's no UP element
sub up_element {
_updown_element("up",@_);
}
# used by both is_up_element and down_element
sub _updown_element {
my $direction=$_[0] || "down"; # defaults to downstream
my $flow;
if ($direction eq "up") {
$flow=2; # used to determine the direction of chain navigation
} else {
$flow=1; # used to determine the direction of chain navigation
}
my $chain=$_[1];
unless($chain) {
warn ("Warning ${direction}_element: no chain input"); return (-1); }
my $me = $_[2]; # the name of the element
my $it = $chain->{$me}[$flow]; # the prev||next one, upstream||downstream
if ($it) {
return ($it); # return the name of prev||next element
} else {
return (0); # there is no prev||next element ($it is undef)
}
}
# used by both is_downstream and is_upstream
sub _is_updownstream {
my $direction=$_[0] || "down"; # defaults to downstream
my $flow;
if ($direction eq "up") {
$flow=2; # used to determine the direction of chain navigation
} else {
$flow=1; # used to determine the direction of chain navigation
}
my $chain=$_[1];
unless($chain) {
warn ("Warning is_${direction}stream: no chain input"); return (-1); }
my $first=$_[2]; # the name of the first element
my $second=$_[3]; # the name of the first element
if ($first==$second) {
warn ("Warning is_${direction}stream: first==second!!"); return (0); }
unless($chain->{$first}) {
warn ("Warning is_${direction}stream: first element not defined"); return (-1); }
unless($chain->{$second}) {
warn ("Warning is_${direction}stream: second element not defined"); return (-1); }
my ($label,@array);
$label=$first;
my $found=0;
while (($label)&&(!($found))) { # searches till the end or till found
if ($label==$second) {
$found=1;
}
@array=@{$chain->{$label}};
$label = $array[$flow]; # go to the prev||next one, upstream||downstream
}
return $found;
}
=head2 is_downstream
Title : is_downstream
Usage : Bio::LiveSeq::Chain::is_downstream($chainref,$firstlabel,$secondlabel)
Function: checks if SECONDlabel follows FIRSTlabel
It runs downstream the elements of the chain from FIRST searching
for SECOND.
Returns : 1 if SECOND is found /after/ FIRST; 0 otherwise (i.e. if it
reaches the end of the chain without having found it)
Errorcode -1
Args : two labels (integer)
=cut
sub is_downstream {
_is_updownstream("down",@_);
}
=head2 is_upstream
Title : is_upstream
Usage : Bio::LiveSeq::Chain::is_upstream($chainref,$firstlabel,$secondlabel)
Function: checks if SECONDlabel follows FIRSTlabel
It runs upstream the elements of the chain from FIRST searching
for SECOND.
Returns : 1 if SECOND is found /after/ FIRST; 0 otherwise (i.e. if it
reaches the end of the chain without having found it)
Errorcode -1
Args : two labels (integer)
=cut
sub is_upstream {
_is_updownstream("up",@_);
}
=head2 check_chain
Title : check_chain
Usage : @errorcodes = Bio::LiveSeq::Chain::check_chain()
Function: a wraparound to a series of check for consistency of the chain
It will check for boundaries, size, backlinking and forwardlinking
Returns : array of 4 warn codes, each can be 1 (all ok) or 0 (something wrong)
Errorcode: 0
Args : none
Note : this is slow and through. It is not really needed. It is mostly
a code-developer tool.
=cut
sub check_chain {
my $chain=$_[0];
unless($chain) {
warn ("Warning check_chain: no chain input"); return (-1); }
my ($warnbound,$warnsize,$warnbacklink,$warnforlink);
$warnbound=&_boundcheck; # passes on the arguments of the subroutine
$warnsize=&_sizecheck;
$warnbacklink=&_downlinkcheck;
$warnforlink=&_uplinkcheck;
return ($warnbound,$warnsize,$warnbacklink,$warnforlink);
}
# consistency check for forwardlinks walking upstream
# argument: a chain reference
# returns: 1 all OK 0 problems
sub _uplinkcheck {
_updownlinkcheck("up",@_);
}
# consistency check for backlinks walking downstream
# argument: a chain reference
# returns: 1 all OK 0 problems
sub _downlinkcheck {
_updownlinkcheck("down",@_);
}
# consistency check for links, common to _uplinkcheck and _downlinkcheck
# argument: "up"||"down", check_ref
# returns: 1 all OK 0 problems
sub _updownlinkcheck {
my $direction=$_[0] || "down"; # defaults to downstream
my ($flow,$wolf);
my $chain=$_[1];
unless($chain) {
warn ("Warning _${direction}linkcheck: no chain input"); return (0); }
my $begin=$chain->{'begin'}; # the name of the first element
my $end=$chain->{'end'}; # the name of the last element
my ($label,@array,$me,$it,$itpoints);
if ($direction eq "up") {
$flow=2; # used to determine the direction of chain navigation
$wolf=1;
$label=$end; # start from end
} else {
$flow=1; # used to determine the direction of chain navigation
$wolf=2;
$label=$begin; # start from beginning
}
my $warncode=1;
while ($label) { # proceed with linked elements, checking neighbours
$me=$label;
@array=@{$chain->{$label}};
$label = $array[$flow]; # go to the next one
$it=$label;
if ($it) { # no sense in checking if next one not defined (END element)
@array=@{$chain->{$label}};
$itpoints=$array[$wolf];
unless ($me==$itpoints) {
warn "Warning: ${direction}LinkCheck: LINK wrong in $it, that doesn't point back to me ($me). It points to $itpoints\n";
$warncode=0;
}
}
}
return $warncode;
}
# consistency check for size of chain
# argument: a chain reference
# returns: 1 all OK 0 wrong size
sub _sizecheck {
my $chain=$_[0];
unless($chain) {
warn ("Warning _sizecheck: no chain input"); return (0); }
my $begin=$chain->{'begin'}; # the name of the first element
my $warncode=1;
my ($label,@array);
my $size=$chain->{'size'};
my $count=0;
$label=$begin;
while ($label) { # proceed with linked elements, counting
@array=@{$chain->{$label}};
$label = $array[1]; # go to the next one
$count++;
}
if ($size != $count) {
warn "Size check reports error: assumed size: $size, real size: $count ";
$warncode=0;
}
return $warncode;
}
# consistency check for begin and end (boundaries)
# argument: a chain reference
# returns: 1 all OK 0 problems
sub _boundcheck {
my $chain=$_[0];
unless($chain) {
warn ("Warning _boundcheck: no chain input"); return (0); }
my $begin=$chain->{'begin'}; # the name of the first element
my $end=$chain->{'end'}; # the name of the (supposedly) last element
my $warncode=1;
# check SYNC of beginning
if (($begin)&&($chain->{$begin})) { # if the BEGIN points to existing element
if ($chain->{$begin}[2]) { # if BEGIN element has PREV not undef
warn "Warning: BEGIN element has PREV field defined \n";
warn "\tWDEBUG begin: $begin\t";
warn "\tWDEBUG begin's PREV: $chain->{$begin}[2] \n";
$warncode=0;
}
} else {
warn "Warning: BEGIN key of chain does not point to existing element!\n";
warn "\tWDEBUG begin: $begin\n";
$warncode=0;
}
# check SYNC of end
if (($end)&&($chain->{$end})) { # if the END points to an existing element
if ($chain->{$end}[1]) { # if END element has NEXT not undef
warn "Warning: END element has NEXT field defined \n";
warn "\tWDEBUG end: $end\t";
warn "\tWDEBUG end's NEXT: $chain->{$end}[1] \n";
$warncode=0;
}
} else {
warn "Warning: END key of chain does not point to existing element!\n";
warn "\tWDEBUG end: $end\n";
$warncode=0;
}
return $warncode;
}
# arguments: chain_ref
# returns: the size of the chain (the number of elements)
# return code -1: unexistant chain, errors...
sub chain_length {
my $chain=$_[0];
unless($chain) {
warn ("Warning chain_length: no chain input"); return (-1); }
my $size=$chain->{'size'};
if ($size) {
return ($size);
} else {
return (-1);
}
}
# arguments: chain ref, first element name, second element name
# returns: 1 or 0 (1 ok, 0 errors)
sub _join_chain_elements {
my $chain=$_[0];
unless($chain) {
warn ("Warning _join_chain_elements: no chain input"); return (0); }
my $leftelem=$_[1];
my $rightelem=$_[2];
unless(($leftelem)&&($rightelem)) {
warn ("Warning _join_chain_elements: element arguments??"); return (0); }
if (($chain->{$leftelem})&&($chain->{$rightelem})) { # if the elements exist
$chain->{$leftelem}[1]=$rightelem;
$chain->{$rightelem}[2]=$leftelem;
return 1;
} else {
warn ("Warning _join_chain_elements: elements not defined");
return 0;
}
}
=head2 splice_chain
Title : splice_chain
Usage : @errorcodes = Bio::LiveSeq::Chain::splice_chain($chainref,$first,$length,$last)
Function: removes the elements designated by FIRST and LENGTH from a chain.
The chain shrinks accordingly. If LENGTH is omitted, removes
everything from FIRST onward.
If END is specified, LENGTH is ignored and instead the removal
occurs from FIRST to LAST.
Returns : the elements removed as a string
Errorcode: -1
Args : chainref, integer, integer, integer
=cut
sub splice_chain {
my $chain=$_[0];
unless($chain) {
warn ("Warning splice_chain: no chain input"); return (-1); }
my $begin=$chain->{'begin'}; # the name of the first element
my $end=$chain->{'end'}; # the name of the (supposedly) last element
my $first=$_[1];
unless (($first eq 0)||($first)) { $first=$begin; } # if undef, use $begin
my $len=$_[2];
my $last=$_[3];
my (@array, $string);
my ($beforecut,$aftercut);
unless($chain->{$first}) {
warn ("Warning splice_chain: first element not defined"); return (-1); }
if ($last) { # if last is defined, it gets priority and len is not used
unless($chain->{$last}) {
warn ("Warning splice_chain: last element not defined"); return (-1); }
if ($len) {
warn ("Warning splice_chain: argument LAST:$last overriding LEN:$len!");
undef $len;
}
} else {
$last=$end; # if last not defined, go 'till end (or to len, whichever 1st)
}
$beforecut=$chain->{$first}[2]; # what's the element before 1st deleted?
# if it is undef then it means we are splicing since the beginning
my $i=1;
my $label=$first;
my $afterlast=$chain->{$last}[1]; # if $last=$end $afterlast should be undef
unless (defined $afterlast) { $afterlast=0; } # keep strict happy
# proceed for len elements or until the end, whichever comes first
# if len undef goes till last
while (($label)&&($label != $afterlast) && ($i <= ($len || $i + 1))) {
@array=@{$chain->{$label}};
$string .= $array[0];
$aftercut = $array[1]; # what's the element next last deleted?
# also used as savevar to change label posdeletion
delete $chain->{$label}; # this can be deleted now
$label=$aftercut; # label is updated using the savevar
$i++;
}
# Now fix the chain (sticky edges, fields)
# 4 cases: cut in the middle, cut from beginning, cut till end, cut all
#print "\n\tstickyDEBUG beforecut: $beforecut "; # DEBUG
#print "\taftercut: $aftercut \n"; # DEBUG
if ($beforecut) {
if ($aftercut) { # 1st case, middle cut
_join_chain_elements($chain,$beforecut,$aftercut);
} else { # 3rd case, end cut
$chain->{'end'}=$beforecut; # update the END field
$chain->{$beforecut}[1]=undef; # since we cut till the end
}
} else {
if ($aftercut) { # 2nd case, begin cut
$chain->{'begin'}=$aftercut; # update the BEGIN field
$chain->{$aftercut}[2]=undef; # since we cut from beginning
} else { # 4th case, all has been cut
$chain->{'begin'}=undef;
$chain->{'end'}=undef;
}
}
$chain->{'size'}=($chain->{'size'}) - $i + 1; # update the SIZE field
return $string;
}
# arguments: CHAIN_REF POSITION [FIRST]
# returns: element counting POSITION from FIRST or from START if FIRST undef
# i.e. returns the element at POSITION counting from FIRST
#sub element_at_pos {
#croak "Warning: old method name. Please update code to 'down_get_label_at_position'\n";
##&down_element_at_pos;
#}
#sub up_element_at_pos {
## old wraparound
##my @array=up_chain2string($_[0],$_[2],$_[1],undef,"elements");
##return $array[-1];
#croak "old method name. Update code to: up_get_label_at_position";
##&up_get_label_at_pos;
#}
#sub down_element_at_pos {
## old wraparound
##my @array=down_chain2string($_[0],$_[2],$_[1],undef,"elements");
##return $array[-1];
#croak "old method name. Update code to: down_get_label_at_position";
##&down_get_label_at_pos;
#}
# arguments: CHAIN_REF ELEMENT [FIRST]
# returns: the position of ELEMENT counting from FIRST or from START
#i if FIRST is undef
# i.e. returns the Number of elements between FIRST and ELEMENT
# i.e. returns the position of element taking FIRST as 1 of coordinate system
#sub pos_of_element {
#croak ("Warning: old and ambiguous method name. Please update code to 'down_get_pos_of_label'\n");
##&down_pos_of_element;
#}
#sub up_pos_of_element {
#croak ("Warning: old method name. Please update code to 'up_get_pos_of_label'\n");
##up_chain2string($_[0],$_[2],undef,$_[1],"counting");
#}
#sub down_pos_of_element {
#croak ("Warning: old method name. Please update code to 'down_get_pos_of_label'\n");
##down_chain2string($_[0],$_[2],undef,$_[1],"counting");
#}
# wraparounds to calculate length of subchain from first to last
# arguments: chain_ref [first] [last]
#sub subchain_length {
#croak "Warning: old method name. Please update code to 'down_subchain_length'\n";
##&down_subchain_length;
#}
# wraparounds to have elements output
# same arguments as chain2string
# returns label|name of every element
#sub elements {
#croak ("Warning: method no more supported. Please update code to 'down_labels' (NB: now it returns ref to array and doesn't allow length argument!)\n");
##&down_elements;
#}
#sub up_elements {
#croak ("Warning: method no more supported. Please update code to 'up_labels' (NB: now it returns ref to array and doesn't allow length argument!)\n");
##up_chain2string($_[0],$_[1],$_[2],$_[3],"elements");
#}
#sub down_elements {
#croak ("Warning: method no more supported. Please update code to 'down_labels' (NB: now it returns ref to array and doesn't allow length argument!)\n");
##down_chain2string($_[0],$_[1],$_[2],$_[3],"elements");
#}
# wraparounds to have verbose output
# same arguments as chain2string
# returns the chain in a very verbose way
sub chain2string_verbose {
carp "Warning: method no more supported.\n";
&old_down_chain2string_verbose;
}
sub up_chain2string_verbose {
carp "Warning: method no more supported.\n";
old_up_chain2string($_[0],$_[1],$_[2],$_[3],"verbose");
}
sub down_chain2string_verbose {
carp "Warning: method no more supported.\n";
old_down_chain2string($_[0],$_[1],$_[2],$_[3],"verbose");
}
#sub chain2string {
#croak ("Warning: old method name. Please update code to 'down_chain2string'\n");
##&down_chain2string;
#}
sub old_up_chain2string {
old_updown_chain2string("up",@_);
}
sub old_down_chain2string {
old_updown_chain2string("down",@_);
}
# common to up_chain2string and down_chain2string
# arguments: "up"||"down" chain_ref [first] [len] [last] [option]
# [option] can be any of "verbose", "counting", "elements"
# error: return -1
# defaults: start = first element; if len undef, goes to last
# if last undef, goes to end
# if last def it overrides len (that gets undef)
# returns: a string
# example usage: down_chain2string($chain) -> all the chain from begin to end
# example usage: down_chain2string($chain,6) -> from 6 to the end
# example usage: down_chain2string($chain,6,4) -> from 6, going on 4 elements
# example usage: down_chain2string($chain,6,"",10) -> from 6 to 10
# example usage: up_chain2string($chain,10,"",6) -> from 10 to 6 upstream
sub old_updown_chain2string {
my ($direction,$chain,$first,$len,$last,$option)=@_;
unless($chain) {
warn ("Warning chain2string: no chain input"); return (-1); }
my $begin=$chain->{'begin'}; # the name of the BEGIN element
my $end=$chain->{'end'}; # the name of the END element
my $flow;
if ($direction eq "up") {
$flow=2; # used to determine the direction of chain navigation
unless ($first) { $first=$end; } # if undef or 0, use $end
} else { # defaults to "down"
$flow=1; # used to determine the direction of chain navigation
unless ($first) { $first=$begin; } # if undef or 0, use $begin
}
unless($chain->{$first}) {
warn ("Warning chain2string: first element not defined"); return (-1); }
if ($last) { # if last is defined, it gets priority and len is not used
unless($chain->{$last}) {
warn ("Warning chain2string: last element not defined"); return (-1); }
if ($len) {
warn ("Warning chain2string: argument LAST:$last overriding LEN:$len!");
undef $len;
}
} else {
if ($direction eq "up") {
$last=$begin; # if last not defined, go 'till begin (or upto len elements)
} else {
$last=$end; # if last not defined, go 'till end (or upto len elements)
}
}
my (@array, $string, $count);
# call for verbosity (by way of chain2string_verbose);
my $verbose=0; my $elements=0; my @elements; my $counting=0;
if ($option) { # keep strict happy
if ($option eq "verbose") { $verbose=1; }
if ($option eq "elements") { $elements=1; }
if ($option eq "counting") { $counting=1; }
}
if ($verbose) {
print "BEGIN=$begin"; print " END=$end"; print " SIZE=$chain->{'size'}";
print " FIRSTFREE=$chain->{'firstfree'} \n";
}
my $i=1;
my $label=$first;
my $afterlast=$chain->{$last}[$flow]; # if $last=$end $afterlast should be undef
unless (defined $afterlast) { $afterlast=0; } # keep strict happy
# proceed for len elements or until last, whichever comes first
# if $len undef goes till end
while (($label)&&($label != $afterlast) && ($i <= ($len || $i + 1))) {
@array=@{$chain->{$label}};
if ($verbose) {
$string .= "$array[2]_${label}_$array[1]=$array[0] ";
$count++;
} elsif ($elements) {
push (@elements,$label); # returning element names/references/identifiers
} elsif ($counting) {
$count++;
} else {
$string .= $array[0]; # returning element content
}
$label = $array[$flow]; # go to next||prev i.e. downstream||upstream
$i++;
}
#DEBUG#print "len: $len, first: $first, last: $last, afterlast=$afterlast \n";
if ($verbose) { print "TOTALprinted: $count\n"; }
if ($counting) {
return $count;
} elsif ($elements) {
return @elements;
} else {
return $string;
}
}
# sub string2schain
# --------> deleted, no more supported <--------
# creation of a single linked list/chain from a string
# basically could be recreated by taking the *2chain methods and
# omitting to set the 3rd field (label 2) containing the back links
# creation of a double linked list/chain from a string
# returns reference to a hash containing the chain
# arguments: STRING [OFFSET]
# defaults: OFFSET defaults to 1 if undef
# the chain will contain as elements the single characters in the string
sub string2chain {
my @string=split(//,$_[0]);
array2chain(\@string,$_[1]);
}
=head2 array2chain
Title : array2chain
Usage : $chainref = Bio::LiveSeq::Chain::array2chain($arrayref,$offset)
Function: creation of a double linked chain from an array
Returns : reference to a hash containing the chain
Defaults: OFFSET defaults to 1 if undef
Error code: 0
Args : a reference to an array containing the elements to be chainlinked
an optional integer > 0 (this will be the starting count for
the chain labels instead than having them begin from "1")
=cut
sub array2chain {
my $arrayref=$_[0];
my $array_count=scalar(@{$arrayref});
unless ($array_count) {
warn ("Warning array2chain: no elements input"); return (0); }
my $begin=$_[1];
if (defined $begin) {
if ($begin < 1) {
warn "Warning array2chain: Zero or Negative offsets not allowed"; return (0); }
} else {
$begin=1;
}
my ($element,%hash);
$hash{'begin'}=$begin;
my $i=$begin-1;
foreach $element (@{$arrayref}) {
$i++;
# hash with keys begin..end pointing to the arrays
$hash{$i}=[$element,$i+1,$i-1];
}
my $end=$i;
$hash{'end'}=$end;
$hash{firstfree}=$i+1; # what a new added element should be called
$hash{size}=$end-$begin+1; # how many elements in the chain
# eliminate pointers to unexisting elements
$hash{$begin}[2]=undef;
$hash{$end}[1]=undef;
return (\%hash);
}
1; # returns 1
]]>