File Coverage

Bio/LiveSeq/Chain.pm
Criterion Covered Total %
statement 405 624 64.9
branch 123 240 51.2
condition 40 80 50.0
subroutine 52 61 85.2
pod 14 41 34.1
total 634 1046 60.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #
3             # bioperl module for Bio::LiveSeq::Chain
4             #
5             # Please direct questions and support issues to
6             #
7             # Cared for by Joseph Insana
8             #
9             # Copyright Joseph Insana
10             #
11             # You may distribute this module under the same terms as perl itself
12             #
13             # POD documentation - main docs before the code
14             #
15              
16             =head1 NAME
17              
18             Bio::LiveSeq::Chain - DoubleChain DataStructure for Perl
19              
20             =head1 SYNOPSIS
21              
22             #documentation needed
23              
24             =head1 DESCRIPTION
25              
26             This is a general purpose module (that's why it's not in object-oriented
27             form) that introduces a novel datastructure in PERL. It implements
28             the "double linked chain". The elements of the chain can contain basically
29             everything. From chars to strings, from object references to arrays or hashes.
30             It is used in the LiveSequence project to create a dynamical DNA sequence,
31             easier to manipulate and change. It's use is mainly for sequence variation
32             analysis but it could be used - for example - in e-cell projects.
33             The Chain module in itself doesn't have any biological bias, so can be
34             used for any programming purpose.
35              
36             Each element of the chain (with the exclusion of the first and the last of the
37             chain) is connected to other two elements (the PREVious and the NEXT one).
38             There is no absolute position (like in an array), hence if positions are
39             important, they need to be computed (methods are provided).
40             Otherwise it's easy to keep track of the elements with their "LABELs".
41             There is one LABEL (think of it as a pointer) to each ELEMENT. The labels
42             won't change after insertions or deletions of the chain. So it's
43             always possible to retrieve an element even if the chain has been
44             modified by successive insertions or deletions.
45             From this the high potential profit for bioinformatics: dealing with
46             sequences in a way that doesn't have to rely on positions, without
47             the need of constantly updating them if the sequence changes, even
48             dramatically.
49              
50             =head1 AUTHOR - Joseph A.L. Insana
51              
52             Email: Insana@ebi.ac.uk, jinsana@gmx.net
53              
54             =head1 APPENDIX
55              
56             The rest of the documentation details each of the object
57             methods. Internal methods are usually preceded with a _
58              
59             =cut
60              
61             # Let the code begin...
62              
63             # DoubleChain Data Structure for PERL
64             # by Joseph A.L. Insana - Deathson - Filius Mortis - Fal Mortais
65             # insana@ebi.ac.uk, jinsana@gmx.net
66              
67             package Bio::LiveSeq::Chain;
68             # TODO_list:
69             # **** cleanup code
70             # **** performance concerns
71             # *??* create hash2dchain ???? (with hashkeys used for label)
72             # **????** how about using array of arrays instead than hash of arrays??
73             #
74             # further strict complaints:
75             # in verbose $string assignment around line 721 ???
76              
77             # TERMINOLOGY update, naming convention:
78             # "chain" the datastructure
79             # "element" the individual units that compose a chain
80             # "label" the unique name of a single element
81             # "position" the position of an element into the chain according to a
82             # particular coordinate system (e.g. counting from the start)
83             # "value" what is stored in a single element
84              
85 3     3   575 use Carp qw(croak cluck carp);
  3         3  
  3         130  
86 3     3   211 use Bio::Root::Version;
  3         3  
  3         15  
87 3     3   80 use strict;
  3         4  
  3         45  
88 3     3   8 use integer; # WARNING: this is to increase performance
  3         3  
  3         13  
89             # a little bit of attention has to be given if float need to
90             # be stored as elements of the array
91             # the use of this "integer" affects all operations but not
92             # assignments. So float CAN be assigned as elements of the chain
93             # BUT, if you assign $z=-1.8;, $z will be equal to -1 because
94             # "-" counts as a unary operation!
95              
96             =head2 _updown_chain2string
97              
98             Title : chain2string
99             Usage : $string = Bio::LiveSeq::Chain::chain2string("down",$chain,6,9)
100             Function: reads the contents of the chain, outputting a string
101             Returns : a string
102             Examples:
103             : down_chain2string($chain) -> all the chain from begin to end
104             : down_chain2string($chain,6) -> from 6 to the end
105             : down_chain2string($chain,6,4) -> from 6, going on 4 elements
106             : down_chain2string($chain,6,"",10) -> from 6 to 10
107             : up_chain2string($chain,10,"",6) -> from 10 to 6 upstream
108             Defaults: start=first element; if len undef, goes to last
109             if last undef, goes to end
110             if last defined, it overrides len (undefining it)
111             Error code: -1
112             Args : "up"||"down" as first argument to specify the reading direction
113             reference (to the chain)
114             [first] [len] [last] optional integer arguments to specify how
115             much and from (and to) where to read
116              
117             =cut
118              
119             # methods rewritten 2.61
120             sub up_chain2string {
121 1     1 0 788 _updown_chain2string("up",@_);
122             }
123             sub down_chain2string {
124 604     604 0 1525 _updown_chain2string("down",@_);
125             }
126              
127             sub _updown_chain2string {
128 605     605   719 my ($direction,$chain,$first,$len,$last)=@_;
129 605 50       976 unless($chain) { cluck "no chain input"; return (-1); }
  0         0  
  0         0  
130 605         691 my $begin=$chain->{'begin'}; # the label of the BEGIN element
131 605         758 my $end=$chain->{'end'}; # the label of the END element
132 605         402 my $flow;
133              
134 605 100       987 if ($direction eq "up") {
135 1         2 $flow=2; # used to determine the direction of chain navigation
136 1 50       3 unless ($first) { $first=$end; } # if undef or 0, use $end
  1         1  
137             } else { # defaults to "down"
138 604         460 $flow=1; # used to determine the direction of chain navigation
139 604 100       990 unless ($first) { $first=$begin; } # if undef or 0, use $begin
  2         2  
140             }
141              
142 605 50       1313 unless($chain->{$first}) {
143 0         0 cluck "label for first not defined"; return (-1); }
  0         0  
144 605 100       729 if ($last) { # if last is defined, it gets priority and len is not used
145 593 50       1112 unless($chain->{$last}) {
146 0         0 cluck "label for last not defined"; return (-1); }
  0         0  
147 593 100       939 if ($len) {
148 1         14 warn "Warning chain2string: argument LAST:$last overriding LEN:$len!";
149 1         5 undef $len;
150             }
151             } else {
152 12 100       31 if ($direction eq "up") {
153 1         2 $last=$begin; # if last not defined, go 'till begin (or upto len elements)
154             } else {
155 11         20 $last=$end; # if last not defined, go 'till end (or upto len elements)
156             }
157             }
158              
159 605         508 my ($string,@array);
160 605         497 my $label=$first; my $i=1;
  605         517  
161 605         669 my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
162 605 100       818 unless (defined $afterlast) { $afterlast=0; } # keep strict happy
  26         34  
163              
164             # proceed for len elements or until last, whichever comes first
165             # if $len undef goes till end
166 605   100     3848 while (($label) && ($label != $afterlast) && ($i <= ($len || $i + 1))) {
      66        
      100        
167 269939         146692 @array=@{$chain->{$label}};
  269939         475343  
168 269939         188471 $string .= $array[0];
169 269939         163242 $label = $array[$flow];
170 269939         1243355 $i++;
171             }
172 605         3820 return ($string); # if chain is interrupted $string won't be complete
173             }
174              
175             =head2 _updown_labels
176              
177             Title : labels
178             Usage : @labels = Bio::LiveSeq::Chain::_updown_labels("down",$chain,4,16)
179             Function: returns all the labels in a chain or those between two
180             specified ones (termed "first" and "last")
181             Returns : a reference to an array containing the labels
182             Args : "up"||"down" as first argument to specify the reading direction
183             reference (to the chain)
184             [first] [last] (integer for the starting and eneding labels)
185              
186             =cut
187              
188              
189             # arguments: CHAIN_REF [FIRSTLABEL] [LASTLABEL]
190             # returns: reference to array containing the labels
191             sub down_labels {
192 823     823 0 1181 my ($chain,$first,$last)=@_;
193 823         957 _updown_labels("down",$chain,$first,$last);
194             }
195             sub up_labels {
196 2     2 0 808 my ($chain,$first,$last)=@_;
197 2         4 _updown_labels("up",$chain,$first,$last);
198             }
199             # arguments: "up"||"down" CHAIN_REF [FIRSTLABEL] [LASTLABEL]
200             # returns: reference to array containing the labels
201             sub _updown_labels {
202 825     825   873 my ($direction,$chain,$first,$last)=@_;
203 825 50       1176 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
204 825         814 my $begin=$chain->{'begin'}; # the label of the BEGIN element
205 825         720 my $end=$chain->{'end'}; # the label of the END element
206 825         594 my $flow;
207 825 100       1041 if ($direction eq "up") { $flow=2;
  2         2  
208 2 100       5 unless ($first) { $first=$end; }
  1         2  
209 2 100       3 unless ($last) { $last=$begin; }
  1         2  
210 823         645 } else { $flow=1;
211 823 50       1143 unless ($last) { $last=$end; }
  0         0  
212 823 50       1141 unless ($first) { $first=$begin; }
  0         0  
213             }
214 825 50       1315 unless($chain->{$first}) { warn "not existing label $first"; return (0); }
  0         0  
  0         0  
215 825 50       1179 unless($chain->{$last}) { warn "not existing label $last"; return (0); }
  0         0  
  0         0  
216              
217 825         617 my $label=$first; my @labels;
  825         642  
218 825         878 my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
219 825 100       1149 unless (defined $afterlast) { $afterlast=0; } # keep strict happy
  2         22  
220              
221 825   100     2669 while (($label)&&($label != $afterlast)) {
222 339139         205505 push(@labels,$label);
223 339139         821738 $label=$chain->{$label}[$flow];
224             }
225 825         2301 return (\@labels); # if chain is interrupted @labels won't be complete
226             }
227              
228              
229             =head2 start
230              
231             Title : start
232             Usage : $start = Bio::LiveSeq::Chain::start()
233             Returns : the label marking the start of the chain
234             Errorcode: -1
235             Args : none
236              
237             =cut
238              
239             sub start {
240 1     1 1 393 my $chain=$_[0];
241 1 50       3 unless($chain) { cluck "no chain input"; return (-1); }
  0         0  
  0         0  
242 1         3 return ($chain->{'begin'});
243             }
244              
245             =head2 end
246              
247             Title : end
248             Usage : $end = Bio::LiveSeq::Chain::end()
249             Returns : the label marking the end of the chain
250             Errorcode: -1
251             Args : none
252              
253             =cut
254              
255             sub end {
256 1     1 1 2 my $chain=$_[0];
257 1 50       4 unless($chain) { cluck "no chain input"; return (-1); }
  0         0  
  0         0  
258 1         3 return ($chain->{'end'});
259             }
260              
261             =head2 label_exists
262              
263             Title : label_exists
264             Usage : $check = Bio::LiveSeq::Chain::label_exists($chain,$label)
265             Function: It checks if a label is defined, i.e. if an element is there or
266             is not there anymore
267             Returns : 1 if the label exists, 0 if it is not there, -1 error
268             Errorcode: -1
269             Args : reference to the chain, integer
270              
271             =cut
272              
273             sub label_exists {
274 3596     3596 1 2589 my ($chain,$label)=@_;
275 3596 50       4787 unless($chain) { cluck "no chain input"; return (-1); }
  0         0  
  0         0  
276 3596 100 33     7545 if ($label && $chain->{$label}) { return (1); } else { return (0) };
  3595         9069  
  1         3  
277             }
278              
279              
280             =head2 down_get_pos_of_label
281              
282             Title : down_get_pos_of_label
283             Usage : $position = Bio::LiveSeq::Chain::down_get_pos_of_label($chain,$label,$first)
284             Function: returns the position of $label counting from $first, i.e. taking
285             $first as 1 of coordinate system. If $first is not specified it will
286             count from the start of the chain.
287             Returns :
288             Errorcode: 0
289             Args : reference to the chain, integer (the label of interest)
290             optional: integer (a different label that will be taken as the
291             first one, i.e. the one to count from)
292             Note: It counts "downstream". To proceed backward use up_get_pos_of_label
293              
294             =cut
295              
296             sub down_get_pos_of_label {
297             #down_chain2string($_[0],$_[2],undef,$_[1],"counting");
298 12     12 1 25 my ($chain,$label,$first)=@_;
299 12         29 _updown_count("down",$chain,$first,$label);
300             }
301             sub up_get_pos_of_label {
302             #up_chain2string($_[0],$_[2],undef,$_[1],"counting");
303 1     1 0 2 my ($chain,$label,$first)=@_;
304 1         2 _updown_count("up",$chain,$first,$label);
305             }
306              
307             =head2 down_subchain_length
308              
309             Title : down_subchain_length
310             Usage : $length = Bio::LiveSeq::Chain::down_subchain_length($chain,$first,$last)
311             Function: returns the length of the chain between the labels "first" and "last", included
312             Returns : integer
313             Errorcode: 0
314             Args : reference to the chain, integer, integer
315             Note: It counts "downstream". To proceed backward use up_subchain_length
316              
317             =cut
318              
319             # arguments: chain_ref [first] [last]
320             # returns the length of the chain between first and last (included)
321             sub down_subchain_length {
322             #down_chain2string($_[0],$_[1],undef,$_[2],"counting");
323 217     217 1 284 my ($chain,$first,$last)=@_;
324 217         359 _updown_count("down",$chain,$first,$last);
325             }
326             sub up_subchain_length {
327             #up_chain2string($_[0],$_[1],undef,$_[2],"counting");
328 1     1 0 2 my ($chain,$first,$last)=@_;
329 1         3 _updown_count("up",$chain,$first,$last);
330             }
331              
332             # arguments: DIRECTION CHAIN_REF FIRSTLABEL LASTLABEL
333             # errorcode 0
334             sub _updown_count {
335 231     231   301 my ($direction,$chain,$first,$last)=@_;
336 231 50       417 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
337 231         261 my $begin=$chain->{'begin'}; # the label of the BEGIN element
338 231         226 my $end=$chain->{'end'}; # the label of the END element
339 231         196 my $flow;
340 231 100       349 if ($direction eq "up") { $flow=2;
  2         3  
341 2 50       3 unless ($first) { $first=$end; }
  0         0  
342 2 50       5 unless ($last) { $last=$begin; }
  0         0  
343 229         197 } else { $flow=1;
344 229 50       344 unless ($last) { $last=$end; }
  0         0  
345 229 100       369 unless ($first) { $first=$begin; }
  11         14  
346             }
347 231 50       399 unless($chain->{$first}) { warn "not existing label $first"; return (0); }
  0         0  
  0         0  
348 231 50       413 unless($chain->{$last}) { warn "not existing label $last"; return (0); }
  0         0  
  0         0  
349              
350 231         241 my $label=$first; my $count;
  231         162  
351 231         253 my $afterlast=$chain->{$last}[$flow]; # if last=end, afterlast is undef
352 231 100       374 unless (defined $afterlast) { $afterlast=0; } # keep strict happy
  1         1  
353              
354 231   100     824 while (($label)&&($label != $afterlast)) {
355 100316         51236 $count++;
356 100316         242266 $label=$chain->{$label}[$flow];
357             }
358 231         804 return ($count); # if chain is interrupted, $i will be up to the breaking point
359             }
360              
361             =head2 invert_chain
362              
363             Title : invert_chain
364             Usage : $errorcode=Bio::LiveSeq::Chain::invert_chain($chain)
365             Function: completely inverts the order of the chain elements; begin is swapped with end and all links updated (PREV&NEXT fields swapped)
366             Returns : 1 if all OK, 0 if errors
367             Errorcode: 0
368             Args : reference to the chain
369              
370             =cut
371              
372             sub invert_chain {
373 2     2 1 3 my $chain=$_[0];
374 2 50       4 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
375 2         2 my $begin=$chain->{'begin'}; # the name of the first element
376 2         3 my $end=$chain->{'end'}; # the name of the last element
377 2         2 my ($label,@array);
378 2         2 $label=$begin; # starts from the beginning
379 2         3 while ($label) { # proceed with linked elements, swapping PREV and NEXT
380 52         27 @array=@{$chain->{$label}};
  52         65  
381 52         50 ($chain->{$label}[1],$chain->{$label}[2])=($array[2],$array[1]); # swap
382 52         57 $label = $array[1]; # go to the next one
383             }
384             # now swap begin and end fields
385 2         4 ($chain->{'begin'},$chain->{'end'})=($end,$begin);
386 2         10 return (1); # that's it
387             }
388              
389             # warning that method has changed name
390             #sub mutate_element {
391             #croak "Warning: old method name. Please update code to 'set_value_at_label'\n";
392             # &set_value_at_label;
393             #}
394              
395             =head2 down_get_value_at_pos
396              
397             Title : down_get_value_at_pos
398             Usage : $value = Bio::LiveSeq::Chain::down_get_value_at_pos($chain,$position,$first)
399             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
400             Returns : whatever is stored in the element of the chain
401             Errorcode: 0
402             Args : reference to the chain, integer, [integer]
403             Note: It works "downstream". To proceed backward use up_get_value_at_pos
404              
405             =cut
406              
407             #sub get_value_at_pos {
408             #croak "Please use instead: down_get_value_at_pos";
409             ##&down_get_value_at_pos;
410             #}
411             sub down_get_value_at_pos {
412 3     3 1 5 my ($chain,$position,$first)=@_;
413 3         4 my $label=down_get_label_at_pos($chain,$position,$first);
414             # check place of change
415 3 50 33     13 if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
416 0         0 warn "not existing element $label"; return (0); }
  0         0  
417 3         5 return _get_value($chain,$label);
418             }
419             sub up_get_value_at_pos {
420 2     2 0 4 my ($chain,$position,$first)=@_;
421 2         3 my $label=up_get_label_at_pos($chain,$position,$first);
422             # check place of change
423 2 50 33     9 if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
424 0         0 warn "not existing element $label"; return (0); }
  0         0  
425 2         4 return _get_value($chain,$label);
426             }
427              
428             =head2 down_set_value_at_pos
429              
430             Title : down_set_value_at_pos
431             Usage : $errorcode = Bio::LiveSeq::Chain::down_set_value_at_pos($chain,$newvalue,$position,$first)
432             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
433             Returns : 1
434             Errorcode: 0
435             Args : reference to the chain, newvalue, integer, [integer]
436             (newvalue can be: integer, string, object reference, hash ref)
437             Note: It works "downstream". To proceed backward use up_set_value_at_pos
438             Note2: If the $newvalue is undef, it will delete the contents of the
439             element but it won't remove the element from the chain.
440              
441             =cut
442              
443             #sub set_value_at_pos {
444             #croak "Please use instead: down_set_value_at_pos";
445             ##&down_set_value_at_pos;
446             #}
447             sub down_set_value_at_pos {
448 1     1 1 2 my ($chain,$value,$position,$first)=@_;
449 1         3 my $label=down_get_label_at_pos($chain,$position,$first);
450             # check place of change
451 1 50 33     7 if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
452 0         0 warn "not existing element $label"; return (0); }
  0         0  
453 1         3 _set_value($chain,$label,$value);
454 1         2 return (1);
455             }
456             sub up_set_value_at_pos {
457 1     1 0 3 my ($chain,$value,$position,$first)=@_;
458 1         2 my $label=up_get_label_at_pos($chain,$position,$first);
459             # check place of change
460 1 50 33     7 if (($label eq -1)||($label eq 0)) { # complain if label doesn't exist
461 0         0 warn "not existing element $label"; return (0); }
  0         0  
462 1         4 _set_value($chain,$label,$value);
463 1         2 return (1);
464             }
465              
466              
467             =head2 down_set_value_at_label
468              
469             Title : down_set_value_at_label
470             Usage : $errorcode = Bio::LiveSeq::Chain::down_set_value_at_label($chain,$newvalue,$label)
471             Function: used to store a new value inside an element of the chain defined by its label.
472             Returns : 1
473             Errorcode: 0
474             Args : reference to the chain, newvalue, integer
475             (newvalue can be: integer, string, object reference, hash ref)
476             Note: It works "downstream". To proceed backward use up_set_value_at_label
477             Note2: If the $newvalue is undef, it will delete the contents of the
478             element but it won't remove the element from the chain.
479              
480             =cut
481              
482             sub set_value_at_label {
483 6     6 0 12 my ($chain,$value,$label)=@_;
484 6 50       20 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
485              
486             # check place of change
487 6 50       20 unless($chain->{$label}) { # complain if label doesn't exist
488 0         0 warn "not existing element $label"; return (0); }
  0         0  
489 6         23 _set_value($chain,$label,$value);
490 6         11 return (1);
491             }
492              
493             =head2 down_get_value_at_label
494              
495             Title : down_get_value_at_label
496             Usage : $value = Bio::LiveSeq::Chain::down_get_value_at_label($chain,$label)
497             Function: used to access the value of the chain from one element defined by its label.
498             Returns : whatever is stored in the element of the chain
499             Errorcode: 0
500             Args : reference to the chain, integer
501             Note: It works "downstream". To proceed backward use up_get_value_at_label
502              
503             =cut
504              
505             sub get_value_at_label {
506 1     1 0 2 my $chain=$_[0];
507 1 50       3 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
508 1         1 my $label = $_[1]; # the name of the element
509              
510             # check place of change
511 1 50       4 unless($chain->{$label}) { # complain if label doesn't exist
512 0         0 warn "not existing label $label"; return (0); }
  0         0  
513 1         1 return _get_value($chain,$label);
514             }
515              
516             # arguments: CHAIN_REF LABEL VALUE
517             sub _set_value {
518 8     8   16 my ($chain,$label,$value)=@_;
519 8         16 $chain->{$label}[0]=$value;
520             }
521             # arguments: CHAIN_REF LABEL
522             sub _get_value {
523 6     6   5 my ($chain,$label)=@_;
524 6         18 return $chain->{$label}[0];
525             }
526              
527             =head2 down_get_label_at_pos
528              
529             Title : down_get_label_at_pos
530             Usage : $label = Bio::LiveSeq::Chain::down_get_label_at_pos($chain,$position,$first)
531             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
532             Returns : integer
533             Errorcode: 0
534             Args : reference to the chain, integer, [integer]
535             Note: It works "downstream". To proceed backward use up_get_label_at_pos
536              
537             =cut
538              
539             # arguments: CHAIN_REF POSITION [FIRST]
540             # returns: LABEL of element found counting from FIRST
541             sub down_get_label_at_pos {
542 14     14 1 36 _updown_get_label_at_pos("down",@_);
543             }
544             sub up_get_label_at_pos {
545 14     14 0 33 _updown_get_label_at_pos("up",@_);
546             }
547              
548             # arguments: [DIRECTION] CHAIN_REF POSITION [FIRST]
549             # Default DIRECTION="down"
550             # if FIRST is undefined, FIRST=START (if DIRECTION=down) or FIRST=END (up)
551              
552             sub _updown_get_label_at_pos {
553 28     28   37 my ($direction,$chain,$position,$first)=@_;
554 28 50       57 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
555 28         39 my $begin=$chain->{'begin'}; # the label of the BEGIN element
556 28         26 my $end=$chain->{'end'}; # the label of the END element
557 28         29 my $flow;
558 28 100       48 if ($direction eq "up") { $flow=2; unless ($first) { $first=$end; }
  14 100       21  
  14         26  
  4         4  
559 14 100       21 } else { $flow=1; unless ($first) { $first=$begin; } }
  14         33  
  3         2  
560 28 50       60 unless($chain->{$first}) { warn "not existing label $first"; return (0); }
  0         0  
  0         0  
561              
562 28         26 my $label=$first;
563 28         27 my $i=1;
564 28         53 while ($i < $position) {
565 11845         11268 $label=$chain->{$label}[$flow];
566 11845         6048 $i++;
567 11845 50       16886 unless ($label) { return (0); } # chain ended before position reached
  0         0  
568             }
569 28         72 return ($label);
570             }
571              
572             # for english_concerned, latin_unconcerned people
573 0     0 0 0 sub preinsert_string { &praeinsert_string }
574 0     0 0 0 sub preinsert_array { &praeinsert_array }
575              
576             # praeinsert_string CHAIN_REF STRING [POSITION]
577             # the chars of STRING are passed to praeinsert_array
578             # the chars are inserted in CHAIN, before POSITION
579             # if POSITION is undef, default is to prepend the string to the beginning
580             # i.e. POSITION is START of CHAIN
581             sub praeinsert_string {
582 1     1 0 4 my @string=split(//,$_[1]);
583 1         3 praeinsert_array($_[0],\@string,$_[2]);
584             }
585              
586             # postinsert_string CHAIN_REF STRING [POSITION]
587             # the chars of STRING are passed to postinsert_array
588             # the chars are inserted in CHAIN, after POSITION
589             # if POSITION is undef, default is to append the string to the end
590             # i.e. POSITION is END of CHAIN
591             sub postinsert_string {
592 1     1 0 786 my @string=split(//,$_[1]);
593 1         4 postinsert_array($_[0],\@string,$_[2]);
594             }
595              
596             # praeinsert_array CHAIN_REF ARRAY_REF [POSITION]
597             # the elements of ARRAY are inserted in CHAIN, before POSITION
598             # if POSITION is undef, default is to prepend the elements to the beginning
599             # i.e. POSITION is START of CHAIN
600             sub praeinsert_array {
601 1     1 0 3 _praepostinsert_array($_[0],"prae",$_[1],$_[2]);
602             }
603              
604             # postinsert_array CHAIN_REF ARRAY_REF [POSITION]
605             # the elements of ARRAY are inserted in CHAIN, after POSITION
606             # if POSITION is undef, default is to append the elements to the end
607             # i.e. POSITION is END of CHAIN
608             sub postinsert_array {
609 1     1 0 2 _praepostinsert_array($_[0],"post",$_[1],$_[2]);
610             }
611              
612              
613             =head2 _praepostinsert_array
614              
615             Title : _praepostinsert_array
616             Usage : ($insbegin,$insend) = Bio::LiveSeq::Chain::_praepostinsert_array($chainref,"post",$arrayref,$position)
617             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.
618             Returns : two labels: the first and the last of the inserted subchain
619             Defaults: if no position is specified, the new chain will be inserted after
620             (post) the first element of the chain
621             Errorcode: 0
622             Args : chainref, "prae"||"post", arrayref, integer (position)
623              
624             =cut
625              
626             # returns: 0 if errors, otherwise returns references of begin and end of
627             # the insertion
628             sub _praepostinsert_array {
629 2     2   3 my $chain=$_[0];
630 2 50       4 unless($chain) { cluck "no chain input"; return (0); }
  0         0  
  0         0  
631 2   50     5 my $praepost=$_[1] || "post"; # defaults to post
632 2         1 my ($prae,$post);
633 2         2 my $position=$_[3];
634 2         3 my $begin=$chain->{'begin'}; # the name of the first element of the chain
635 2         2 my $end=$chain->{'end'}; # the name of the the last element of the chain
636             # check if prae or post insertion and prepare accordingly
637 2 100       5 if ($praepost eq "prae") {
638 1         2 $prae=1;
639 1 50 33     6 unless (($position eq 0)||($position)) { $position=$begin; } # if undef, use $begin
  0         0  
640             } else {
641 1         2 $post=1;
642 1 50 33     6 unless (($position eq 0)||($position)) { $position=$end; } # if undef, use $end
  0         0  
643             }
644             # check place of insertion
645 2 50       23 unless($chain->{$position}) { # complain if position doesn't exist
646 0         0 warn ("Warning _praepostinsert_array: not existing element $position");
647 0         0 return (0);
648             }
649              
650             # check if there are elements to insert
651 2         4 my $elements=$_[2]; # reference to the array containing the new elements
652 2         1 my $elements_count=scalar(@{$elements});
  2         3  
653 2 50       6 unless ($elements_count) {
654 0         0 warn ("Warning _praepostinsert_array: no elements input"); return (0); }
  0         0  
655              
656             # create new chainelements with offset=firstfree(chain)
657 2         3 my ($insertbegin,$insertend)=_create_chain_elements($chain,$elements);
658              
659             # DEBUGGING
660             #print "Executing ${praepost}insertion of $elements_count elements ('@{$elements}') at position: $position\n";
661              
662             # attach the new chain to the old chain
663             # 4 cases: prae@begin, prae@middle, post@middle, post@end
664             # NOTE: in case of double joinings always join wisely so not to
665             # delete the PREV/NEXT attribute before it is needed
666 2         3 my $noerror=1;
667 2 100       4 if ($prae) {
    50          
668 1 50       3 if ($position==$begin) { # 1st case: prae@begin
669 0         0 $noerror=_join_chain_elements($chain,$insertend,$begin);
670 0         0 $chain->{'begin'}=$insertbegin;
671             } else { # 2nd case: prae@middle
672 1         3 $noerror=_join_chain_elements($chain,up_element($chain,$position),$insertbegin);
673 1         2 $noerror=_join_chain_elements($chain,$insertend,$position);
674             }
675             } elsif ($post) {
676 1 50       3 if ($position==$end) { # 4th case: post@end
677 0         0 $noerror=_join_chain_elements($chain,$end,$insertbegin);
678 0         0 $chain->{'end'}=$insertend;
679             } else { # 3rd case: post@middle # note the order of joins (important)
680 1         4 $noerror=_join_chain_elements($chain,$insertend,down_element($chain,$position));
681 1         3 $noerror=_join_chain_elements($chain,$position,$insertbegin);
682             }
683             } else { # this should never happen
684 0         0 die "_praepostinsert_array: Something went very wrong";
685             }
686              
687             # check for errors and return begin,end of insertion
688 2 50       3 if ($noerror) {
689 2         8 return ($insertbegin,$insertend);
690             } else { # something went wrong with the joinings
691 0         0 warn "Warning _praepostinsert_array: Joining of insertion failed";
692 0         0 return (0);
693             }
694             }
695              
696             # create new chain elements with offset=firstfree
697             # arguments: CHAIN_REF ARRAY_REF
698             # returns: pointers to BEGIN and END of new chained elements created
699             # returns 0 if error(s) encountered
700             sub _create_chain_elements {
701 2     2   3 my $chain=$_[0];
702 2 50       3 unless($chain) {
703 0         0 warn ("Warning _create_chain_elements: no chain input"); return (0); }
  0         0  
704 2         3 my $arrayref=$_[1];
705 2         1 my $array_count=scalar(@{$arrayref});
  2         3  
706 2 50       3 unless ($array_count) {
707 0         0 warn ("Warning _create_chain_elements: no elements input"); return (0); }
  0         0  
708 2         3 my $begin=$chain->{'firstfree'};
709 2         3 my $i=$begin-1;
710 2         2 my $element;
711 2         1 foreach $element (@{$arrayref}) {
  2         3  
712 5         3 $i++;
713 5         12 $chain->{$i}=[$element,$i+1,$i-1];
714             }
715 2         2 my $end=$i;
716 2         3 $chain->{'firstfree'}=$i+1; # what a new added element should be called
717 2         3 $chain->{'size'} += $end-$begin+1; # increase size of chain
718             # leave sticky edges (to be joined by whoever called this subroutine)
719 2         2 $chain->{$begin}[2]=undef;
720 2         3 $chain->{$end}[1]=undef;
721 2         4 return ($begin,$end); # return pointers to first and last of the newelements
722             }
723              
724             # argument: CHAIN_REF ELEMENT
725             # returns: name of DOWN/NEXT element (the downstream one)
726             # returns -1 if error encountered (e.g. chain or elements undefined)
727             # returns 0 if there's no DOWN element
728             sub down_element {
729 1     1 0 2 _updown_element("down",@_);
730             }
731             # argument: CHAIN_REF ELEMENT
732             # returns: name of UP/PREV element (the upstream one)
733             # returns -1 if error encountered (e.g. chain or elements undefined)
734             # returns 0 if there's no UP element
735             sub up_element {
736 1     1 0 2 _updown_element("up",@_);
737             }
738              
739             # used by both is_up_element and down_element
740             sub _updown_element {
741 2   50 2   4 my $direction=$_[0] || "down"; # defaults to downstream
742 2         3 my $flow;
743 2 100       3 if ($direction eq "up") {
744 1         2 $flow=2; # used to determine the direction of chain navigation
745             } else {
746 1         2 $flow=1; # used to determine the direction of chain navigation
747             }
748 2         2 my $chain=$_[1];
749 2 50       3 unless($chain) {
750 0         0 warn ("Warning ${direction}_element: no chain input"); return (-1); }
  0         0  
751 2         35 my $me = $_[2]; # the name of the element
752 2         3 my $it = $chain->{$me}[$flow]; # the prev||next one, upstream||downstream
753 2 50       3 if ($it) {
754 2         12 return ($it); # return the name of prev||next element
755             } else {
756 0         0 return (0); # there is no prev||next element ($it is undef)
757             }
758             }
759              
760             # used by both is_downstream and is_upstream
761             sub _is_updownstream {
762 133   50 133   247 my $direction=$_[0] || "down"; # defaults to downstream
763 133         118 my $flow;
764 133 100       200 if ($direction eq "up") {
765 2         3 $flow=2; # used to determine the direction of chain navigation
766             } else {
767 131         172 $flow=1; # used to determine the direction of chain navigation
768             }
769 133         119 my $chain=$_[1];
770 133 50       219 unless($chain) {
771 0         0 warn ("Warning is_${direction}stream: no chain input"); return (-1); }
  0         0  
772 133         176 my $first=$_[2]; # the name of the first element
773 133         106 my $second=$_[3]; # the name of the first element
774 133 50       261 if ($first==$second) {
775 0         0 warn ("Warning is_${direction}stream: first==second!!"); return (0); }
  0         0  
776 133 50       240 unless($chain->{$first}) {
777 0         0 warn ("Warning is_${direction}stream: first element not defined"); return (-1); }
  0         0  
778 133 50       234 unless($chain->{$second}) {
779 0         0 warn ("Warning is_${direction}stream: second element not defined"); return (-1); }
  0         0  
780 133         128 my ($label,@array);
781 133         105 $label=$first;
782 133         107 my $found=0;
783 133   100     435 while (($label)&&(!($found))) { # searches till the end or till found
784 123891 100       122678 if ($label==$second) {
785 131         112 $found=1;
786             }
787 123891         66831 @array=@{$chain->{$label}};
  123891         177680  
788 123891         284413 $label = $array[$flow]; # go to the prev||next one, upstream||downstream
789             }
790 133         590 return $found;
791             }
792              
793             =head2 is_downstream
794              
795             Title : is_downstream
796             Usage : Bio::LiveSeq::Chain::is_downstream($chainref,$firstlabel,$secondlabel)
797             Function: checks if SECONDlabel follows FIRSTlabel
798             It runs downstream the elements of the chain from FIRST searching
799             for SECOND.
800             Returns : 1 if SECOND is found /after/ FIRST; 0 otherwise (i.e. if it
801             reaches the end of the chain without having found it)
802             Errorcode -1
803             Args : two labels (integer)
804              
805             =cut
806              
807             sub is_downstream {
808 131     131 1 219 _is_updownstream("down",@_);
809             }
810              
811             =head2 is_upstream
812              
813             Title : is_upstream
814             Usage : Bio::LiveSeq::Chain::is_upstream($chainref,$firstlabel,$secondlabel)
815             Function: checks if SECONDlabel follows FIRSTlabel
816             It runs upstream the elements of the chain from FIRST searching
817             for SECOND.
818             Returns : 1 if SECOND is found /after/ FIRST; 0 otherwise (i.e. if it
819             reaches the end of the chain without having found it)
820             Errorcode -1
821             Args : two labels (integer)
822              
823             =cut
824              
825             sub is_upstream {
826 2     2 1 3 _is_updownstream("up",@_);
827             }
828              
829             =head2 check_chain
830              
831             Title : check_chain
832             Usage : @errorcodes = Bio::LiveSeq::Chain::check_chain()
833             Function: a wraparound to a series of check for consistency of the chain
834             It will check for boundaries, size, backlinking and forwardlinking
835             Returns : array of 4 warn codes, each can be 1 (all ok) or 0 (something wrong)
836             Errorcode: 0
837             Args : none
838             Note : this is slow and through. It is not really needed. It is mostly
839             a code-developer tool.
840              
841             =cut
842              
843             sub check_chain {
844 1     1 1 1 my $chain=$_[0];
845 1 50       4 unless($chain) {
846 0         0 warn ("Warning check_chain: no chain input"); return (-1); }
  0         0  
847 1         1 my ($warnbound,$warnsize,$warnbacklink,$warnforlink);
848 1         3 $warnbound=&_boundcheck; # passes on the arguments of the subroutine
849 1         2 $warnsize=&_sizecheck;
850 1         2 $warnbacklink=&_downlinkcheck;
851 1         2 $warnforlink=&_uplinkcheck;
852 1         3 return ($warnbound,$warnsize,$warnbacklink,$warnforlink);
853             }
854              
855             # consistency check for forwardlinks walking upstream
856             # argument: a chain reference
857             # returns: 1 all OK 0 problems
858             sub _uplinkcheck {
859 1     1   2 _updownlinkcheck("up",@_);
860             }
861              
862             # consistency check for backlinks walking downstream
863             # argument: a chain reference
864             # returns: 1 all OK 0 problems
865             sub _downlinkcheck {
866 1     1   3 _updownlinkcheck("down",@_);
867             }
868              
869             # consistency check for links, common to _uplinkcheck and _downlinkcheck
870             # argument: "up"||"down", check_ref
871             # returns: 1 all OK 0 problems
872             sub _updownlinkcheck {
873 2   50 2   5 my $direction=$_[0] || "down"; # defaults to downstream
874 2         1 my ($flow,$wolf);
875 2         2 my $chain=$_[1];
876 2 50       4 unless($chain) {
877 0         0 warn ("Warning _${direction}linkcheck: no chain input"); return (0); }
  0         0  
878 2         3 my $begin=$chain->{'begin'}; # the name of the first element
879 2         2 my $end=$chain->{'end'}; # the name of the last element
880 2         1 my ($label,@array,$me,$it,$itpoints);
881 2 100       5 if ($direction eq "up") {
882 1         1 $flow=2; # used to determine the direction of chain navigation
883 1         1 $wolf=1;
884 1         1 $label=$end; # start from end
885             } else {
886 1         1 $flow=1; # used to determine the direction of chain navigation
887 1         1 $wolf=2;
888 1         2 $label=$begin; # start from beginning
889             }
890 2         1 my $warncode=1;
891              
892 2         5 while ($label) { # proceed with linked elements, checking neighbours
893 52         30 $me=$label;
894 52         28 @array=@{$chain->{$label}};
  52         60  
895 52         39 $label = $array[$flow]; # go to the next one
896 52         26 $it=$label;
897 52 100       57 if ($it) { # no sense in checking if next one not defined (END element)
898 50         27 @array=@{$chain->{$label}};
  50         60  
899 50         34 $itpoints=$array[$wolf];
900 50 50       87 unless ($me==$itpoints) {
901 0         0 warn "Warning: ${direction}LinkCheck: LINK wrong in $it, that doesn't point back to me ($me). It points to $itpoints\n";
902 0         0 $warncode=0;
903             }
904             }
905             }
906 2         3 return $warncode;
907             }
908              
909             # consistency check for size of chain
910             # argument: a chain reference
911             # returns: 1 all OK 0 wrong size
912             sub _sizecheck {
913 1     1   1 my $chain=$_[0];
914 1 50       3 unless($chain) {
915 0         0 warn ("Warning _sizecheck: no chain input"); return (0); }
  0         0  
916 1         2 my $begin=$chain->{'begin'}; # the name of the first element
917 1         2 my $warncode=1;
918 1         0 my ($label,@array);
919 1         2 my $size=$chain->{'size'};
920 1         1 my $count=0;
921 1         1 $label=$begin;
922 1         3 while ($label) { # proceed with linked elements, counting
923 26         13 @array=@{$chain->{$label}};
  26         34  
924 26         17 $label = $array[1]; # go to the next one
925 26         30 $count++;
926             }
927 1 50       4 if ($size != $count) {
928 0         0 warn "Size check reports error: assumed size: $size, real size: $count ";
929 0         0 $warncode=0;
930             }
931 1         2 return $warncode;
932             }
933              
934              
935             # consistency check for begin and end (boundaries)
936             # argument: a chain reference
937             # returns: 1 all OK 0 problems
938             sub _boundcheck {
939 1     1   2 my $chain=$_[0];
940 1 50       2 unless($chain) {
941 0         0 warn ("Warning _boundcheck: no chain input"); return (0); }
  0         0  
942 1         2 my $begin=$chain->{'begin'}; # the name of the first element
943 1         2 my $end=$chain->{'end'}; # the name of the (supposedly) last element
944 1         1 my $warncode=1;
945              
946             # check SYNC of beginning
947 1 50 33     5 if (($begin)&&($chain->{$begin})) { # if the BEGIN points to existing element
948 1 50       8 if ($chain->{$begin}[2]) { # if BEGIN element has PREV not undef
949 0         0 warn "Warning: BEGIN element has PREV field defined \n";
950 0         0 warn "\tWDEBUG begin: $begin\t";
951 0         0 warn "\tWDEBUG begin's PREV: $chain->{$begin}[2] \n";
952 0         0 $warncode=0;
953             }
954             } else {
955 0         0 warn "Warning: BEGIN key of chain does not point to existing element!\n";
956 0         0 warn "\tWDEBUG begin: $begin\n";
957 0         0 $warncode=0;
958             }
959             # check SYNC of end
960 1 50 33     4 if (($end)&&($chain->{$end})) { # if the END points to an existing element
961 1 50       3 if ($chain->{$end}[1]) { # if END element has NEXT not undef
962 0         0 warn "Warning: END element has NEXT field defined \n";
963 0         0 warn "\tWDEBUG end: $end\t";
964 0         0 warn "\tWDEBUG end's NEXT: $chain->{$end}[1] \n";
965 0         0 $warncode=0;
966             }
967             } else {
968 0         0 warn "Warning: END key of chain does not point to existing element!\n";
969 0         0 warn "\tWDEBUG end: $end\n";
970 0         0 $warncode=0;
971             }
972 1         2 return $warncode;
973             }
974              
975             # arguments: chain_ref
976             # returns: the size of the chain (the number of elements)
977             # return code -1: unexistant chain, errors...
978             sub chain_length {
979 0     0 0 0 my $chain=$_[0];
980 0 0       0 unless($chain) {
981 0         0 warn ("Warning chain_length: no chain input"); return (-1); }
  0         0  
982 0         0 my $size=$chain->{'size'};
983 0 0       0 if ($size) {
984 0         0 return ($size);
985             } else {
986 0         0 return (-1);
987             }
988             }
989              
990             # arguments: chain ref, first element name, second element name
991             # returns: 1 or 0 (1 ok, 0 errors)
992             sub _join_chain_elements {
993 6     6   4 my $chain=$_[0];
994 6 50       12 unless($chain) {
995 0         0 warn ("Warning _join_chain_elements: no chain input"); return (0); }
  0         0  
996 6         2 my $leftelem=$_[1];
997 6         6 my $rightelem=$_[2];
998 6 50 33     21 unless(($leftelem)&&($rightelem)) {
999 0         0 warn ("Warning _join_chain_elements: element arguments??"); return (0); }
  0         0  
1000 6 50 33     16 if (($chain->{$leftelem})&&($chain->{$rightelem})) { # if the elements exist
1001 6         4 $chain->{$leftelem}[1]=$rightelem;
1002 6         6 $chain->{$rightelem}[2]=$leftelem;
1003 6         10 return 1;
1004             } else {
1005 0         0 warn ("Warning _join_chain_elements: elements not defined");
1006 0         0 return 0;
1007             }
1008             }
1009              
1010             =head2 splice_chain
1011              
1012             Title : splice_chain
1013             Usage : @errorcodes = Bio::LiveSeq::Chain::splice_chain($chainref,$first,$length,$last)
1014             Function: removes the elements designated by FIRST and LENGTH from a chain.
1015             The chain shrinks accordingly. If LENGTH is omitted, removes
1016             everything from FIRST onward.
1017             If END is specified, LENGTH is ignored and instead the removal
1018             occurs from FIRST to LAST.
1019             Returns : the elements removed as a string
1020             Errorcode: -1
1021             Args : chainref, integer, integer, integer
1022              
1023             =cut
1024              
1025             sub splice_chain {
1026 2     2 1 4 my $chain=$_[0];
1027 2 50       4 unless($chain) {
1028 0         0 warn ("Warning splice_chain: no chain input"); return (-1); }
  0         0  
1029 2         2 my $begin=$chain->{'begin'}; # the name of the first element
1030 2         3 my $end=$chain->{'end'}; # the name of the (supposedly) last element
1031 2         2 my $first=$_[1];
1032 2 50 33     12 unless (($first eq 0)||($first)) { $first=$begin; } # if undef, use $begin
  0         0  
1033 2         2 my $len=$_[2];
1034 2         1 my $last=$_[3];
1035 2         2 my (@array, $string);
1036 0         0 my ($beforecut,$aftercut);
1037              
1038 2 50       5 unless($chain->{$first}) {
1039 0         0 warn ("Warning splice_chain: first element not defined"); return (-1); }
  0         0  
1040 2 100       3 if ($last) { # if last is defined, it gets priority and len is not used
1041 1 50       4 unless($chain->{$last}) {
1042 0         0 warn ("Warning splice_chain: last element not defined"); return (-1); }
  0         0  
1043 1 50       3 if ($len) {
1044 0         0 warn ("Warning splice_chain: argument LAST:$last overriding LEN:$len!");
1045 0         0 undef $len;
1046             }
1047             } else {
1048 1         2 $last=$end; # if last not defined, go 'till end (or to len, whichever 1st)
1049             }
1050              
1051 2         2 $beforecut=$chain->{$first}[2]; # what's the element before 1st deleted?
1052             # if it is undef then it means we are splicing since the beginning
1053              
1054 2         2 my $i=1;
1055 2         2 my $label=$first;
1056 2         3 my $afterlast=$chain->{$last}[1]; # if $last=$end $afterlast should be undef
1057 2 100       4 unless (defined $afterlast) { $afterlast=0; } # keep strict happy
  1         1  
1058              
1059             # proceed for len elements or until the end, whichever comes first
1060             # if len undef goes till last
1061 2   66     17 while (($label)&&($label != $afterlast) && ($i <= ($len || $i + 1))) {
      66        
      100        
1062 5         4 @array=@{$chain->{$label}};
  5         9  
1063 5         4 $string .= $array[0];
1064 5         5 $aftercut = $array[1]; # what's the element next last deleted?
1065             # also used as savevar to change label posdeletion
1066 5         5 delete $chain->{$label}; # this can be deleted now
1067 5         3 $label=$aftercut; # label is updated using the savevar
1068 5         24 $i++;
1069             }
1070            
1071             # Now fix the chain (sticky edges, fields)
1072             # 4 cases: cut in the middle, cut from beginning, cut till end, cut all
1073             #print "\n\tstickyDEBUG beforecut: $beforecut "; # DEBUG
1074             #print "\taftercut: $aftercut \n"; # DEBUG
1075 2 50       3 if ($beforecut) {
1076 2 50       5 if ($aftercut) { # 1st case, middle cut
1077 2         5 _join_chain_elements($chain,$beforecut,$aftercut);
1078             } else { # 3rd case, end cut
1079 0         0 $chain->{'end'}=$beforecut; # update the END field
1080 0         0 $chain->{$beforecut}[1]=undef; # since we cut till the end
1081             }
1082             } else {
1083 0 0       0 if ($aftercut) { # 2nd case, begin cut
1084 0         0 $chain->{'begin'}=$aftercut; # update the BEGIN field
1085 0         0 $chain->{$aftercut}[2]=undef; # since we cut from beginning
1086             } else { # 4th case, all has been cut
1087 0         0 $chain->{'begin'}=undef;
1088 0         0 $chain->{'end'}=undef;
1089             }
1090             }
1091 2         4 $chain->{'size'}=($chain->{'size'}) - $i + 1; # update the SIZE field
1092              
1093 2         6 return $string;
1094             }
1095              
1096              
1097             # arguments: CHAIN_REF POSITION [FIRST]
1098             # returns: element counting POSITION from FIRST or from START if FIRST undef
1099             # i.e. returns the element at POSITION counting from FIRST
1100             #sub element_at_pos {
1101             #croak "Warning: old method name. Please update code to 'down_get_label_at_position'\n";
1102             ##&down_element_at_pos;
1103             #}
1104             #sub up_element_at_pos {
1105             ## old wraparound
1106             ##my @array=up_chain2string($_[0],$_[2],$_[1],undef,"elements");
1107             ##return $array[-1];
1108             #croak "old method name. Update code to: up_get_label_at_position";
1109             ##&up_get_label_at_pos;
1110             #}
1111             #sub down_element_at_pos {
1112             ## old wraparound
1113             ##my @array=down_chain2string($_[0],$_[2],$_[1],undef,"elements");
1114             ##return $array[-1];
1115             #croak "old method name. Update code to: down_get_label_at_position";
1116             ##&down_get_label_at_pos;
1117             #}
1118              
1119             # arguments: CHAIN_REF ELEMENT [FIRST]
1120             # returns: the position of ELEMENT counting from FIRST or from START
1121             #i if FIRST is undef
1122             # i.e. returns the Number of elements between FIRST and ELEMENT
1123             # i.e. returns the position of element taking FIRST as 1 of coordinate system
1124             #sub pos_of_element {
1125             #croak ("Warning: old and ambiguous method name. Please update code to 'down_get_pos_of_label'\n");
1126             ##&down_pos_of_element;
1127             #}
1128             #sub up_pos_of_element {
1129             #croak ("Warning: old method name. Please update code to 'up_get_pos_of_label'\n");
1130             ##up_chain2string($_[0],$_[2],undef,$_[1],"counting");
1131             #}
1132             #sub down_pos_of_element {
1133             #croak ("Warning: old method name. Please update code to 'down_get_pos_of_label'\n");
1134             ##down_chain2string($_[0],$_[2],undef,$_[1],"counting");
1135             #}
1136              
1137             # wraparounds to calculate length of subchain from first to last
1138             # arguments: chain_ref [first] [last]
1139             #sub subchain_length {
1140             #croak "Warning: old method name. Please update code to 'down_subchain_length'\n";
1141             ##&down_subchain_length;
1142             #}
1143              
1144             # wraparounds to have elements output
1145             # same arguments as chain2string
1146             # returns label|name of every element
1147             #sub elements {
1148             #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");
1149             ##&down_elements;
1150             #}
1151             #sub up_elements {
1152             #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");
1153             ##up_chain2string($_[0],$_[1],$_[2],$_[3],"elements");
1154             #}
1155             #sub down_elements {
1156             #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");
1157             ##down_chain2string($_[0],$_[1],$_[2],$_[3],"elements");
1158             #}
1159              
1160             # wraparounds to have verbose output
1161             # same arguments as chain2string
1162             # returns the chain in a very verbose way
1163             sub chain2string_verbose {
1164 0     0 0 0 carp "Warning: method no more supported.\n";
1165 0         0 &old_down_chain2string_verbose;
1166             }
1167             sub up_chain2string_verbose {
1168 0     0 0 0 carp "Warning: method no more supported.\n";
1169 0         0 old_up_chain2string($_[0],$_[1],$_[2],$_[3],"verbose");
1170             }
1171             sub down_chain2string_verbose {
1172 0     0 0 0 carp "Warning: method no more supported.\n";
1173 0         0 old_down_chain2string($_[0],$_[1],$_[2],$_[3],"verbose");
1174             }
1175              
1176             #sub chain2string {
1177             #croak ("Warning: old method name. Please update code to 'down_chain2string'\n");
1178             ##&down_chain2string;
1179             #}
1180             sub old_up_chain2string {
1181 0     0 0 0 old_updown_chain2string("up",@_);
1182             }
1183             sub old_down_chain2string {
1184 0     0 0 0 old_updown_chain2string("down",@_);
1185             }
1186              
1187             # common to up_chain2string and down_chain2string
1188             # arguments: "up"||"down" chain_ref [first] [len] [last] [option]
1189             # [option] can be any of "verbose", "counting", "elements"
1190             # error: return -1
1191             # defaults: start = first element; if len undef, goes to last
1192             # if last undef, goes to end
1193             # if last def it overrides len (that gets undef)
1194             # returns: a string
1195             # example usage: down_chain2string($chain) -> all the chain from begin to end
1196             # example usage: down_chain2string($chain,6) -> from 6 to the end
1197             # example usage: down_chain2string($chain,6,4) -> from 6, going on 4 elements
1198             # example usage: down_chain2string($chain,6,"",10) -> from 6 to 10
1199             # example usage: up_chain2string($chain,10,"",6) -> from 10 to 6 upstream
1200             sub old_updown_chain2string {
1201 0     0 0 0 my ($direction,$chain,$first,$len,$last,$option)=@_;
1202 0 0       0 unless($chain) {
1203 0         0 warn ("Warning chain2string: no chain input"); return (-1); }
  0         0  
1204 0         0 my $begin=$chain->{'begin'}; # the name of the BEGIN element
1205 0         0 my $end=$chain->{'end'}; # the name of the END element
1206 0         0 my $flow;
1207 0 0       0 if ($direction eq "up") {
1208 0         0 $flow=2; # used to determine the direction of chain navigation
1209 0 0       0 unless ($first) { $first=$end; } # if undef or 0, use $end
  0         0  
1210             } else { # defaults to "down"
1211 0         0 $flow=1; # used to determine the direction of chain navigation
1212 0 0       0 unless ($first) { $first=$begin; } # if undef or 0, use $begin
  0         0  
1213             }
1214              
1215 0 0       0 unless($chain->{$first}) {
1216 0         0 warn ("Warning chain2string: first element not defined"); return (-1); }
  0         0  
1217 0 0       0 if ($last) { # if last is defined, it gets priority and len is not used
1218 0 0       0 unless($chain->{$last}) {
1219 0         0 warn ("Warning chain2string: last element not defined"); return (-1); }
  0         0  
1220 0 0       0 if ($len) {
1221 0         0 warn ("Warning chain2string: argument LAST:$last overriding LEN:$len!");
1222 0         0 undef $len;
1223             }
1224             } else {
1225 0 0       0 if ($direction eq "up") {
1226 0         0 $last=$begin; # if last not defined, go 'till begin (or upto len elements)
1227             } else {
1228 0         0 $last=$end; # if last not defined, go 'till end (or upto len elements)
1229             }
1230             }
1231 0         0 my (@array, $string, $count);
1232             # call for verbosity (by way of chain2string_verbose);
1233 0         0 my $verbose=0; my $elements=0; my @elements; my $counting=0;
  0         0  
  0         0  
  0         0  
1234 0 0       0 if ($option) { # keep strict happy
1235 0 0       0 if ($option eq "verbose") { $verbose=1; }
  0         0  
1236 0 0       0 if ($option eq "elements") { $elements=1; }
  0         0  
1237 0 0       0 if ($option eq "counting") { $counting=1; }
  0         0  
1238             }
1239              
1240 0 0       0 if ($verbose) {
1241 0         0 print "BEGIN=$begin"; print " END=$end"; print " SIZE=$chain->{'size'}";
  0         0  
  0         0  
1242 0         0 print " FIRSTFREE=$chain->{'firstfree'} \n";
1243             }
1244              
1245 0         0 my $i=1;
1246 0         0 my $label=$first;
1247 0         0 my $afterlast=$chain->{$last}[$flow]; # if $last=$end $afterlast should be undef
1248 0 0       0 unless (defined $afterlast) { $afterlast=0; } # keep strict happy
  0         0  
1249              
1250             # proceed for len elements or until last, whichever comes first
1251             # if $len undef goes till end
1252 0   0     0 while (($label)&&($label != $afterlast) && ($i <= ($len || $i + 1))) {
      0        
      0        
1253 0         0 @array=@{$chain->{$label}};
  0         0  
1254 0 0       0 if ($verbose) {
    0          
    0          
1255 0         0 $string .= "$array[2]_${label}_$array[1]=$array[0] ";
1256 0         0 $count++;
1257             } elsif ($elements) {
1258 0         0 push (@elements,$label); # returning element names/references/identifiers
1259             } elsif ($counting) {
1260 0         0 $count++;
1261             } else {
1262 0         0 $string .= $array[0]; # returning element content
1263             }
1264 0         0 $label = $array[$flow]; # go to next||prev i.e. downstream||upstream
1265 0         0 $i++;
1266             }
1267             #DEBUG#print "len: $len, first: $first, last: $last, afterlast=$afterlast \n";
1268 0 0       0 if ($verbose) { print "TOTALprinted: $count\n"; }
  0         0  
1269 0 0       0 if ($counting) {
    0          
1270 0         0 return $count;
1271             } elsif ($elements) {
1272 0         0 return @elements;
1273             } else {
1274 0         0 return $string;
1275             }
1276             }
1277              
1278             # sub string2schain
1279             # --------> deleted, no more supported <--------
1280             # creation of a single linked list/chain from a string
1281             # basically could be recreated by taking the *2chain methods and
1282             # omitting to set the 3rd field (label 2) containing the back links
1283              
1284              
1285             # creation of a double linked list/chain from a string
1286             # returns reference to a hash containing the chain
1287             # arguments: STRING [OFFSET]
1288             # defaults: OFFSET defaults to 1 if undef
1289             # the chain will contain as elements the single characters in the string
1290             sub string2chain {
1291 7     7 0 4964 my @string=split(//,$_[0]);
1292 7         31 array2chain(\@string,$_[1]);
1293             }
1294              
1295             =head2 array2chain
1296              
1297             Title : array2chain
1298             Usage : $chainref = Bio::LiveSeq::Chain::array2chain($arrayref,$offset)
1299             Function: creation of a double linked chain from an array
1300             Returns : reference to a hash containing the chain
1301             Defaults: OFFSET defaults to 1 if undef
1302             Error code: 0
1303             Args : a reference to an array containing the elements to be chainlinked
1304             an optional integer > 0 (this will be the starting count for
1305             the chain labels instead than having them begin from "1")
1306              
1307             =cut
1308              
1309             sub array2chain {
1310 7     7 1 13 my $arrayref=$_[0];
1311 7         7 my $array_count=scalar(@{$arrayref});
  7         10  
1312 7 50       23 unless ($array_count) {
1313 0         0 warn ("Warning array2chain: no elements input"); return (0); }
  0         0  
1314 7         10 my $begin=$_[1];
1315 7 100       13 if (defined $begin) {
1316 6 50       19 if ($begin < 1) {
1317 0         0 warn "Warning array2chain: Zero or Negative offsets not allowed"; return (0); }
  0         0  
1318             } else {
1319 1         1 $begin=1;
1320             }
1321 7         9 my ($element,%hash);
1322 7         20 $hash{'begin'}=$begin;
1323 7         12 my $i=$begin-1;
1324 7         7 foreach $element (@{$arrayref}) {
  7         16  
1325 31217         17099 $i++;
1326             # hash with keys begin..end pointing to the arrays
1327 31217         51533 $hash{$i}=[$element,$i+1,$i-1];
1328             }
1329 7         13 my $end=$i;
1330 7         12 $hash{'end'}=$end;
1331 7         15 $hash{firstfree}=$i+1; # what a new added element should be called
1332 7         15 $hash{size}=$end-$begin+1; # how many elements in the chain
1333              
1334             # eliminate pointers to unexisting elements
1335 7         16 $hash{$begin}[2]=undef;
1336 7         8 $hash{$end}[1]=undef;
1337              
1338 7         37 return (\%hash);
1339             }
1340              
1341             1; # returns 1