[Bio] / FigKernelPackages / FIGtree.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/FIGtree.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (view) (download) (as text)

1 : olson 1.3 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 : golsen 1.1 package FIGtree;
19 :    
20 :     # use Carp;
21 :     # use strict;
22 :    
23 :     require Exporter;
24 :     our @ISA = qw(Exporter);
25 :     our @EXPORT = qw(
26 :     FIGtree_to_newick
27 :     FIGtree_to_overbeek
28 :     newick_to_FIGtree
29 :     overbeek_to_FIGtree
30 : golsen 1.2
31 : golsen 1.1 FIG_build_tree_from_subtrees
32 :     FIG_chop_tree
33 :     FIG_closest_common_ancestor
34 :     FIG_collapse_node_node
35 :     FIG_collapse_node_tip
36 :     FIG_copy_tree
37 :     FIG_dist_node_to_node
38 :     FIG_dist_tip_to_tip
39 :     FIG_dist_to_first_tip
40 :     FIG_dist_to_node
41 :     FIG_dist_to_root
42 :     FIG_dist_to_tip
43 :     FIG_duplicate_tips
44 :     FIG_duplicate_nodes
45 :     FIG_first_tip
46 :     FIG_max_label
47 :     FIG_min_label
48 :     FIG_nodes_of_tree
49 :     FIG_nodes_within_dist
50 :     FIG_num_nodes
51 :     FIG_num_tips
52 : golsen 1.2 FIG_num_bunches
53 :     FIG_path_length
54 : golsen 1.1 FIG_path_to_first_tip
55 :     FIG_path_to_node
56 :     FIG_path_to_node_ref
57 :     FIG_path_to_root
58 :     FIG_path_to_tip
59 :     FIG_prefix_of
60 :     FIG_print_node
61 :     FIG_print_tree
62 :     FIG_prune_node
63 :     FIG_prune_tip
64 :     FIG_random_order_tree
65 : golsen 1.2 FIG_region_size
66 : golsen 1.1 FIG_representative_tree
67 :     FIG_reverse_tree
68 :     FIG_shared_tips
69 : golsen 1.2 FIG_split_tree
70 : golsen 1.1 FIG_steps_to_node
71 :     FIG_steps_to_root
72 :     FIG_steps_to_fist_tip
73 :     FIG_steps_to_tip
74 :     FIG_tips_of_tree
75 :     FIG_tips_within_dist
76 :     FIG_tips_within_steps
77 : golsen 1.2 FIG_tree_diameter
78 : golsen 1.1 FIG_tree_length
79 : golsen 1.2 FIG_tree_depth
80 :     FIG_tree_size
81 : golsen 1.1 add_FIG_branch_attrib
82 :     add_FIG_desc
83 :     add_FIG_node_attrib
84 :     build_tip_count_hash
85 :     collapse_FIG_tree
86 :     collect_all_tips
87 :     collect_all_nodes
88 : golsen 1.2 collect_tips_and_dist
89 : golsen 1.1 delete_elm
90 :     delete_FIG_branch_attrib
91 :     delete_FIG_descRef
92 :     delete_FIG_ith_desc
93 :     delete_FIG_node_attrib
94 :     delete_FIG_node
95 :     delete_FIG_tip
96 :     distance_along_path
97 :     distance_along_path_2
98 :     fill_FIGtree_parents
99 :     fill_overbeek_parents
100 :     first_tip_ref
101 :     get_FIG_X
102 :     get_FIG_branch_attrib
103 :     get_FIG_context
104 :     get_FIG_descList
105 :     get_FIG_descRef
106 :     get_FIG_ith_desc
107 :     get_FIG_ith_branch_attribute
108 :     get_FIG_ith_node_attribute
109 :     get_FIG_label
110 :     get_FIG_max_desc
111 :     get_FIG_max_desc_ref
112 :     get_FIG_max_label
113 :     get_FIG_min_desc
114 :     get_FIG_min_desc_ref
115 :     get_FIG_min_label
116 :     get_FIG_node_attrib
117 :     get_FIG_num_branch_attrib
118 :     get_FIG_num_node_attrib
119 :     get_FIG_numDesc
120 :     get_FIG_parent
121 :     get_FIG_root
122 :     get_FIG_tipref
123 :     get_path_to_first_tip
124 :     get_path_to_root
125 :     has_cycles
126 :     is_FIG_bifurcating
127 :     is_FIG_node
128 :     is_FIG_root
129 :     is_FIG_rooted
130 :     is_FIG_tip
131 :     is_FIG_tip_rooted
132 :     is_FIG_unrooted
133 :     is_desc_of_FIGnode
134 :     is_tip_in_FIG
135 :     layout_FIG_tree
136 :     maxref_of_subtree
137 :     minref_of_subtree
138 :     most_distant_tip_path
139 :     most_distant_tip_name
140 :     most_distant_tip_ref
141 : golsen 1.2 normalize_FIG_tree
142 : golsen 1.1 nodes_down_within_dist
143 :     nodes_up_within_dist
144 :     print_attrib_hash
145 :     read_FIG_from_str
146 :     rearrange_FIG_largest_out
147 :     rearrange_FIG_smallest_out
148 :     reorder_FIG_against_tip_count
149 :     reorder_FIG_by_tip_count
150 :     reroot_FIG_by_path
151 :     reroot_FIG_next_to_tip
152 :     reroot_FIG_to_node
153 :     reroot_FIG_to_node_ref
154 :     reroot_FIG_to_tip
155 :    
156 :     set_FIG_label
157 :     set_FIG_X
158 :     set_FIG_parent
159 :     set_FIG_descRef
160 :     set_FIG_node_attrib
161 :     set_FIG_branch_attrib
162 :     set_FIG_ith_desc
163 :     set_FIG_descList
164 :     set_FIG_ith_node_attrib
165 :     set_FIG_ith_branch_attrib
166 :     set_FIG_undef_branch
167 : golsen 1.2 sort_list_of_pairs
168 : golsen 1.1 std_unrooted_FIG
169 :     tips_down_within_steps
170 :     tips_up_within_steps
171 :     tot_nodes_within_dist
172 :     tot_tips_within_steps
173 :     uproot_FIG
174 :     uproot_tip_to_node
175 :     write_FIG_to_Newick
176 :     );
177 :    
178 :     our @EXPORT_OK = qw(
179 :     get_FIG_label
180 :     get_FIG_X
181 :     get_FIG_parent
182 :     get_FIG_node_attributes
183 :     get_FIG_branch_attributes
184 :     get_FIG_descList
185 :     get_FIG_ith_desc
186 :     get_FIG_ith_node_attribute
187 :     set_FIG_label
188 :     set_FIG_X
189 :     set_FIG_parent
190 :     set_FIG_descRef
191 :     set_FIG_node_attrib
192 :     set_FIG_branch_attrib
193 :     set_FIG_ith_desc
194 :     set_FIG_ith_node_attrib
195 :     set_FIG_ith_branch_attrib
196 :     add_FIG_desc
197 :     add_FIG_node_attrib
198 :     add_FIG_branch_attrib
199 :     delete_FIG_ith_desc
200 :     delete_FIG_ith_node_attrib
201 :     delete_FIG_ith_branch_attrib
202 :     delete_FIG_descRef
203 :     );
204 :    
205 :     use gjolists qw(
206 :     common_prefix
207 :     common_and_unique
208 :     unique_suffixes
209 :     unique_set
210 :     duplicates
211 :     random_order
212 :     union
213 :     intersection
214 :     set_difference
215 :     );
216 :    
217 :     use gjonewicklib qw(
218 :     writeNewickTree
219 :     fwriteNewickTree
220 :     strNewickTree
221 :     formatNewickTree
222 :    
223 :     parse_newick_tree_str
224 :    
225 :     layout_tree
226 :     );
227 :    
228 :     #=============================================================================
229 :     # FIG tree
230 :     #
231 :     # Tree is:
232 :     #
233 :     # [ Label,
234 :     # X, # distance to parent
235 :     # ParentPointer,
236 :     # [ ChildPointer1, ... ],
237 :     # %NodeAttributes,
238 :     # %BranchAttributes
239 :     # ]
240 :     #
241 :     # Overbeek tree:
242 :     #
243 :     # [ Label,
244 :     # DistanceToParent,
245 :     # [ ParentPointer, ChildPointer1, ... ],
246 :     # [ Name1\tVal1, Name2\Val2, ... ]
247 :     # ]
248 :     #
249 :     # Olsen "newick" representation in perl:
250 :     #
251 :     # $tree = \@rootnode;
252 :     #
253 :     # @node = ( \@desc, # reference to list of descendants
254 :     # $label, # node label
255 :     # $x, # branch length
256 :     # \@c1, # reference to comment list 1
257 :     # \@c2, # reference to comment list 2
258 :     # \@c3, # reference to comment list 3
259 :     # \@c4, # reference to comment list 4
260 :     # \@c5 # reference to comment list 5
261 :     # )
262 :     #
263 :     #
264 :     #-------------------------------------------------------------------------
265 :     # Internally used definitions
266 :     #-------------------------------------------------------------------------
267 :    
268 :     sub array_ref { ref( $_[0] ) eq "ARRAY" }
269 :     sub hash_ref { ref( $_[0] ) eq "HASH" }
270 :     sub by_distance { return ($a->[1] <=> $b->[1]); }
271 :     sub by_name { return ($a->[0] <=> $b->[0]); }
272 :    
273 :     sub delete_elm {
274 :     # deletes $elm from @$list";
275 :     my ($list, $elm) = @_;
276 :     array_ref( $list ) && defined($elm) || undef;
277 :     if (scalar @$list == 1 ) { $list->[0] eq $elm ? () : undef; }
278 :     for (my $i = 0 ; $i < scalar @$list; $i++) {
279 :     if ($list->[$i] eq $elm) { splice (@$list, $i, 1) }
280 :     }
281 :     $list;
282 :     }
283 :    
284 :     #=============================================================================
285 :     # FIGtree's get operations
286 :     #=========================================================================
287 :     #
288 :     # Note: there is a distinction between fig-node and fig-tip
289 :     # a fig-node is a node with descendants and no label
290 :     # a fig-tip is a node without descendants and label.
291 :     # when necessary, you will find separate functions for each
292 :     #=========================================================================
293 :     sub get_FIG_label { $_[0]->[0] }
294 :     sub get_FIG_X { $_[0]->[1] }
295 :     sub get_FIG_parent { $_[0]->[2] }
296 :     sub get_FIG_descRef { $_[0]->[3] }
297 :     sub get_FIG_node_attrib { $_[0]->[4] }
298 :     sub get_FIG_branch_attrib { $_[0]->[5] }
299 :    
300 :     sub get_FIG_numDesc {
301 :     # $numDesc = get_FIG_numDesc($node)
302 :     my ($FIG_node) = @_;
303 :     my $i = $FIG_node->[3];
304 :     ! array_ref( $FIG_node)? undef :
305 :     ! array_ref( $i ) ? undef :
306 :     (scalar @$i) <= 0 ? 0 :
307 :     scalar @$i ;
308 :     }
309 :    
310 :     sub get_FIG_descList {
311 :     my $node = $_[0];
312 :     ! array_ref( $node ) ? undef :
313 :     array_ref( $node->[3] ) ? @{ $node->[3] } :
314 :     () ;
315 :     }
316 :    
317 :     sub get_FIG_ith_desc {
318 :     my ( $FIG_node, $i ) = @_;
319 :     ! array_ref( $FIG_node ) ? undef :
320 :     array_ref( $FIG_node->[3] ) ?
321 :     $FIG_node->[3]->[$i-1] :
322 :     undef ;
323 :     }
324 :    
325 :     sub get_FIG_num_node_attrib {
326 :     my ($FIG_node) = @_;
327 :     my $i = $FIG_node->[4];
328 :     ! array_ref( $FIG_node) ? undef :
329 :     ! hash_ref( $i ) ? undef :
330 :     (scalar keys %$i) <= 0 ? 0 :
331 :     scalar keys %$i ;
332 :     }
333 :    
334 :     sub get_FIG_num_branch_attrib {
335 :     my ($FIG_node) = @_;
336 :     my $i = $FIG_node->[5];
337 :     ! array_ref( $FIG_node) ? undef :
338 :     ! hash_ref( $i ) ? undef :
339 :     (scalar keys %$i) <= 0 ? 0 :
340 :     scalar keys %$i ;
341 :     }
342 :    
343 :     sub get_FIG_ith_node_attribute {
344 :     my ( $FIG_node, $i ) = @_;
345 :     ! array_ref( $FIG_node ) ? undef :
346 :     array_ref( $FIG_node->[4] ) ?
347 :     $FIG_node->[4]->[$i-1] :
348 :     undef ;
349 :     }
350 :    
351 :     sub get_FIG_ith_branch_attribute {
352 :     my ( $FIG_node, $i ) = @_;
353 :     ! array_ref( $FIG_node ) ? undef :
354 :     array_ref( $FIG_node->[5] ) ?
355 :     $FIG_node->[5]->[$i-1] :
356 :     undef ;
357 :     }
358 :    
359 :     sub get_FIG_tipref {
360 :     my ($tree, $tipname) = @_;
361 :     array_ref($tree) && defined($tipname) || undef;
362 :     my @path = FIG_path_to_tip($tree, $tipname);
363 :     scalar @path > 0 ? pop @path : undef;
364 :     }
365 :    
366 :     sub get_FIG_root {
367 :     my ($node) = @_;
368 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
369 :     ! $node->[2] ? return $node :
370 :     return &get_FIG_root($node->[2]);
371 :     }
372 :    
373 :     #------------------------------------------------------------------
374 :     # boolean functions
375 :     #------------------------------------------------------------------
376 :     sub is_FIG_node {
377 :     # A node with nonempty descend list
378 :     my $FIG_node = $_[0];
379 :     ! array_ref( $FIG_node ) ? undef :
380 :     ( array_ref( $FIG_node->[3] ) &&
381 :     ( @{ $FIG_node->[3] } > 0 ) ) ?
382 :     1 : undef
383 :     ;
384 :     }
385 :    
386 :     sub is_FIG_root {
387 :     # A node with no parent ref
388 :     my $FIG_node = $_[0];
389 :     ! array_ref( $FIG_node ) ? undef :
390 :     ( array_ref( $FIG_node->[2] ) &&
391 :     ( @{ $FIG_node->[2] } == 0 ) ) ?
392 :     1 : undef
393 :     ;
394 :     }
395 :    
396 :     sub is_desc_of_FIGnode {
397 :     # tests if $descref is descendant of $noderef
398 :     my ($noderef, $descref) = @_;
399 :     array_ref( $noderef ) && array_ref( $descref ) || undef;
400 :     my @children = get_FIG_descList($noderef);
401 :     my $found = "n";
402 :     my $child;
403 :     foreach $child (@children) { $found = "y" if ($child eq $descref); }
404 :     $found eq "y" ? 1 : 0 ;
405 :     }
406 :    
407 :     sub is_FIG_tip {
408 :     # input is a noderef
409 :     my $FIG_node = $_[0];
410 :     ! array_ref( $FIG_node ) ? undef :
411 :     ( @{ $FIG_node->[3] } == 0 ) ?
412 :     1 : undef
413 :     ;
414 :     }
415 :    
416 :     sub is_tip_in_FIG {
417 :     # input: treeref and tip label. tests if tip label is in tree
418 :     my ($tree , $tipname) = @_;
419 :     my $tipref = get_FIG_tipref($tree , $tipname);
420 :     $tipref ? 1 : undef
421 :     ;
422 :     }
423 :    
424 :     sub is_FIG_rooted {
425 :     # tests if root node has two children
426 :     my ($root) = @_;
427 :     ! array_ref( $root ) ? undef :
428 :     array_ref( $root->[3] ) ? @{ $root->[3] } == 2 :
429 :     0 ;
430 :     }
431 :    
432 :     sub is_FIG_unrooted {
433 :     # tests if root node has three children
434 :     my ($root) = @_;
435 :     ! array_ref( $root ) ? undef :
436 :     array_ref( $root->[3] ) ? @{ $root->[3] } == 3 :
437 :     0 ;
438 :     }
439 :    
440 :     sub is_FIG_tip_rooted {
441 :     my $node = $_[0];
442 :     ! array_ref( $node ) ? undef : # Not a node ref
443 :     array_ref( $node->[3] ) ? @{ $node->[3] } == 1 : # 1 branch
444 :     0 ; # No descend list
445 :     }
446 :    
447 :     sub is_FIG_bifurcating {
448 :     my ($node, $notroot) = @_;
449 :     if ( ! array_ref( $node ) ) { return undef } # Bad arg
450 :    
451 :     my $n = get_FIG_numDesc($node);
452 :    
453 :     $n == 0 && ! $notroot ? 0 :
454 :     $n == 1 && $notroot ? 0 :
455 :     $n == 3 && $notroot ? 0 :
456 :     $n > 3 ? 0 :
457 :     $n > 2 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,3,1)) ? 0 :
458 :     $n > 1 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,2,1)) ? 0 :
459 :     $n > 0 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,1,1)) ? 0 : $n
460 :     }
461 :    
462 :     sub has_cycles {
463 :     # assumes path was acyclic when last insertion was made
464 :     # we only have to check if last insertion created a cycle
465 :     # note: path is a list of node refs
466 :     my ($path) = @_;
467 :     my $size = scalar @$path;
468 :     my $last = $path->[$size-1];
469 :     my $i=0,$found="no";
470 :     while (($i<= ($size-2)) && ( $found == "no"))
471 :     { if ($path->[$i] eq $last) {$found="yes";}
472 :     $i++; }
473 :     $found eq "yes" ? 1 : undef;
474 :     }
475 :    
476 :     #-------------------------------------------------------------------------
477 :     # update (i.e. set,add,delete) functions
478 :     #-------------------------------------------------------------------------
479 :    
480 :     sub set_FIG_label { $_[0]->[0] = $_[1] }
481 :     sub set_FIG_X { $_[0]->[1] = $_[1] }
482 :     sub set_FIG_parent{ $_[0]->[2] = $_[1] }
483 :     sub set_FIG_descRef { $_[0]->[3] = $_[1] }
484 :     sub set_FIG_node_attrib { $_[0]->[4] = $_[1] }
485 :     sub set_FIG_branch_attrib {$_[0]->[5] = $_[1] }
486 :    
487 :     sub set_FIG_descList {
488 :     # input: node, newList. Sets node's descList to newList
489 :     my $node = shift;
490 :     array_ref( $node ) || return;
491 :     if ( array_ref( $node->[3] ) ) { @{ $node->[3] } = @_ }
492 :     else { $node->[3] = [ @_ ] }
493 :     }
494 :    
495 :     sub set_FIG_ith_desc {
496 :     # sets node1's ith-desc to arrayref of node2
497 :     my ($node1, $i, $node2) = @_;
498 :     array_ref( $node1 ) && array_ref( $node2 ) || return;
499 :     if ( array_ref( $node1->[3] ) ) { $node1->[3]->[$i-1] = $node2 }
500 :     else { $node1->[3] = [ $node2 ] }
501 :     }
502 :    
503 :     sub set_FIG_undef_branch {
504 :     # searches in entire subtree rooted at $node for nodes w/undefined X
505 :     # and changes them to $x; returns number of nodes whose vals were reset
506 :     my ($node, $x, $tot) = @_;
507 :     array_ref($node) && defined($x) || return 0;
508 :    
509 :     if ( ! defined( get_FIG_X( $node ) ) ){
510 :     set_FIG_X( $node, $x );
511 :     $tot++;
512 :     }
513 :     if (is_FIG_tip($node)) {return $tot;}
514 :    
515 :     my $n = $tot;
516 :     foreach $child (@{$node->[3]}) {
517 :     $n += set_FIG_undef_branch( $child, $x, 0 );
518 :     }
519 :     $tot+= $n;
520 :     return $tot;
521 :     }
522 :    
523 :     sub add_FIG_desc {
524 :     # adds a descendant [$child] to node's descList
525 :     my ($node, $child) = @_;
526 :     my $numDesc = $node->[3];
527 :     array_ref( $node ) && array_ref( $child ) || return;
528 :     if ( array_ref( $node->[3] ) )
529 :     { $node->[3]->[ scalar @$numDesc ] = $child }
530 :     else
531 :     { $node->[3] = [ $child ] }
532 :     }
533 :    
534 :     sub add_FIG_node_attrib {
535 :     # adds a node attribute to node
536 :     my ($node, $attrib) = @_;
537 :     my ($key, $val);
538 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
539 :     while (($key, $val) = each %$attrib) {
540 :     push( @{ $node->[4]{ $key } }, $val);
541 :     #print "$key, $val";
542 :     }
543 :     }
544 :     }
545 :    
546 :     sub add_FIG_branch_attrib {
547 :     # adds a branch attribute to node
548 :     my ($node, $attrib) = @_;
549 :     my ($key, $val);
550 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
551 :     while (($key, $val) = each %$attrib) {
552 :     push( @{ $node->[5]{ $key } }, $val);
553 :     # print "$key, $val";
554 :     }
555 :     }
556 :     }
557 :     sub delete_FIG_ith_desc {
558 :     # deletes node's ith descendant
559 :     my ( $node, $i ) = @_;
560 :     if ((! array_ref( $node )) && (! array_ref( $node->[3])) )
561 :     { return undef }
562 :     elsif ($i == 1) { pop(@{$node->[3]}) }
563 :     else { splice(@{$node->[3]},$ith-1,1) }
564 :     }
565 :    
566 :     sub delete_FIG_descRef{
567 :     #deletes $noderef from node's desclist
568 :     my ($node, $noderef) = @_;
569 :     array_ref( $node ) && defined($noderef) || undef;
570 :     my $numdesc = scalar @{$node->[3]};
571 :     $numdesc || undef;
572 :    
573 :     if ($numdesc == 1 ) { shift(@{$node->[3]}) }
574 :     elsif ($node->[3]->[$numdesc-1] eq $noderef ) { pop(@{$node->[3]}) }
575 :     else
576 :     { for ( my $i = 0; $i < $numdesc; $i++ ) {
577 :     if ($node->[3]->[$i] eq $noderef)
578 :     { splice(@{$node->[3]},$i,1) }
579 :     }
580 :     }
581 :     $node->[3];
582 :     }
583 :    
584 :     sub delete_FIG_node_attrib {
585 :     # deletes node attribute from node's list
586 :     my ($node, $attrib) = @_;
587 :     my ($key, $val);
588 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
589 :     while ( ($key,$val) = each %$attrib) {
590 :     my $val1 = $node->[4]{$key};
591 :     if (!array_ref($val1) )
592 :     { delete $node->[4]{ $key } ; return ; }
593 :     else
594 :     {
595 :     for (my $i=0;$i < scalar @$val1; $i++) {
596 :     if ($val1->[$i] eq $val) { splice @$val1,i,1 }
597 :     }
598 :     if (scalar @$val1 == 0) {
599 :     delete $node->[4]{ $key }; return ; }
600 :     }
601 :     }
602 :     }
603 :     else { undef }
604 :     }
605 :    
606 :     sub delete_FIG_branch_attrib {
607 :     # deletes branch attribute from node's list
608 :     my ($node, $attrib) = @_;
609 :     my ($key, $val);
610 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
611 :     while ( ($key,$val) = each %$attrib) {
612 :     my $val1 = $node->[5]{$key};
613 :     if (!array_ref($val1) )
614 :     { delete $node->[5]{ $key } ; return ; }
615 :     else
616 :     {
617 :     for (my $i=0;$i < scalar @$val1; $i++) {
618 :     if ($val1->[$i] eq $val) { splice @$val1,i,1 }
619 :     }
620 :     if (scalar @$val1 == 0) {
621 :     delete $node->[5]{ $key }; return ; }
622 :     }
623 :     }
624 :     }
625 :     else { undef }
626 :     }
627 :    
628 :     sub delete_FIG_tip {
629 :     # tip node is deleted. resulting tree is NOT normalized
630 :     my ($tree, $tip1) = @_;
631 :     array_ref($tree) && defined($tip1) || undef;
632 :     if (! array_ref($tip1) )
633 :     { # arg 2 is a tipname; we need a tipref
634 :     $tip1 = get_FIG_tipref($tree,$tip1);
635 :     }
636 :     is_FIG_tip($tip1) || undef;
637 :     my $parent = $tip1->[2];
638 :     array_ref($parent) || undef;
639 :     delete_FIG_descRef($parent,$tip1);
640 :     $parent;
641 :     }
642 :    
643 :     sub delete_FIG_node {
644 :     # node1 is deleted from $tree; its descedants are added to
645 :     # the parent's descList. Resulting $tree is NOT normalized
646 :     my ($tree, $node1) = @_;
647 :     is_FIG_node($node1) || undef;
648 :     if (is_FIG_root($node1)) { return uproot_FIG($node1) }
649 :     my $parent = $node1->[2];
650 :     my $children = $node1->[3];
651 :     if (@$children == 0) {
652 :     delete_FIG_descRef($parent,$node1);
653 :     return $parent;
654 :     }
655 :     delete_FIG_descRef($parent,$node1);
656 :     my $child;
657 :     foreach $child (@$children) {
658 :     add_FIG_desc($parent, $child);
659 :     }
660 :     $parent;
661 :     }
662 :    
663 :     #------------------------------------------------------------------
664 :     # statistics functions -- tree operations without side effects
665 :     #------------------------------------------------------------------
666 :     sub FIG_tree_length {
667 : golsen 1.2 # adds up the distances of all nodes of tree
668 : golsen 1.1 my ($node, $notroot) = @_;
669 :     array_ref( $node) || return;
670 :     my $x = $notroot ? get_FIG_X( $node ) : 0;
671 :     defined( $x ) || ( $x = 1 );
672 : golsen 1.2 #print "\nat node = $node with value of x = $x";
673 : golsen 1.1 my $imax = get_FIG_numDesc($node);
674 :     for ( my $i = 1; $i <= $imax; $i++ ) {
675 :     $x += FIG_tree_length( get_FIG_ith_desc($node, $i), 1 );
676 :     }
677 :     $x;
678 :     }
679 :    
680 : golsen 1.2 sub FIG_tree_diameter {
681 :     # locates the two most distant tips in tree and
682 :     # calculates distance of its path
683 :     my ($fig) = @_;
684 :     my @tpairs = sort_list_of_pairs( collect_tips_and_dist($fig) );
685 :     my $t1 = shift @tpairs;
686 :     my $x1 = shift @tpairs;
687 :     my $x2 = pop @tpairs;
688 :     my $t2 = pop @tpairs;
689 :     &FIG_dist_tip_to_tip($fig,$t1->[0],$t2->[0]);
690 :     }
691 :    
692 :     sub FIG_path_length {
693 :     # given a path, it calculates the distance/length of it
694 :     # check distance_along_path to get path length given
695 :     # two points rather than a path like it is here
696 :     my $length=0;
697 :     map { $length += get_FIG_X($_) } @_;
698 :     return $length;
699 :     }
700 :     sub FIG_tree_depth {
701 :     # given a tree -its root node- it calculates depth of it;
702 :     # or in other words, the number of internal nodes between
703 :     # the root and its most distant tip
704 :     my ($node) = @_;
705 :     my $path = &most_distant_tip_path($node,1);
706 :     return $path;
707 :     }
708 :    
709 :     sub FIG_tree_size {
710 :     # number of internal and external nodes of the tree
711 :     # this way: takes n^2
712 :     # return (FIG_num_nodes(@_) + FIG_num_tips(@_));
713 :     #this other way takes n
714 :     my @nodes = collect_all_noderef(@_);
715 :     return scalar @nodes;
716 :     }
717 :    
718 :     sub FIG_num_bunches {
719 :     # a bunch is a subregion or split of the tree
720 :     # the right number of subregions is a heuristic
721 :     # in our case, we choose it based on the size of the tree
722 :     my ($fig) = @_;
723 :     my $lowN = int (log FIG_num_tips($fig));
724 :     my $hiN = &FIG_tree_depth($fig);
725 :     my $midN = 3;
726 :     my @array = ($lowN, $hiN, $midN);
727 :     sort { $a <=> $b } @array;
728 :     my $numBunches = pop @array;
729 :     while ($numBunches <= 0) { $numBunches = pop @array; }
730 :     return $numBunches;
731 :     }
732 :    
733 :     sub FIG_region_size {
734 :     # roughly speaking, we divide the tips evenly among the regions
735 :     # note, other heuristics can be implemented here
736 :     my ($fig, $numBunches) = @_;
737 :     if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
738 :     if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
739 :     if ($numBunches == 1) {print "\nnumbunch is one";return $fig; }
740 :    
741 :     my @tips = collect_all_tips($fig);
742 :     my $numtips = scalar @tips;
743 :     my $regionSize = int ($numtips / $numBunches);
744 :     if ($regionSize <= 0) { print "\nerror calculating size"; return undef; }
745 :     else { return $regionSize; }
746 :     }
747 :    
748 : golsen 1.1 sub FIG_nodes_of_tree {
749 :     # returns list of non-tip node references
750 :     &collect_all_nodes( @_ );
751 :     }
752 :    
753 :     sub FIG_tips_of_tree {
754 :     # returns list of tip labels of tree rooted at tree
755 :     map { get_FIG_label($_) } collect_all_tips( @_ );
756 :     }
757 :    
758 :     sub get_FIG_max_label {
759 :     # finds max of tree rooted at $tree
760 :     my ($tree) = @_;
761 :     my @tips = collect_all_tips($tree);
762 :     my ($maxref, $max );
763 :     $max = @tips->[0]->[1];
764 :     $maxref = @tips->[0];
765 :     for ($i=1; $i < @tips; $i++) {
766 :     if ( @tips->[$i]->[1] > $max) {
767 :     $max = @tips->[$i]->[1];
768 :     $maxref = @tips->[$i] ;
769 :     }
770 :     }
771 :     ($maxref, $max );
772 :     }
773 :    
774 :     sub get_FIG_min_label {
775 :     # finds min of tree rooted at $tree
776 :     my ($tree) = @_;
777 :     my @tips = collect_all_tips($tree);
778 :     my ($minref, $min);
779 :     $min = @tips->[0]->[1];
780 :     $minref = @tips->[0];
781 :     for ($i=1; $i < @tips; $i++) {
782 :     if ( @tips->[$i]->[1] < $min) {
783 :     $min = @tips->[$i]->[1] ;
784 :     $minref = @tips->[$i] ;
785 :     }
786 :     }
787 :     ($minref, $min);
788 :     }
789 :    
790 :    
791 :     sub get_FIG_min_desc {
792 :     # ($minref,$min) = get_FIG_min_desc($node)
793 :     my ( $FIG_node ) = @_;
794 :     if ((! array_ref( $FIG_node)) && (! array_ref( $FIG_node->[3] ) ) )
795 :     { return undef }
796 :     my ($minref,$min);
797 :     $min = $FIG_node->[3]->[0][1];
798 :     $minref = $FIG_node->[3]->[0];
799 :     my $i=1;
800 :     while ($i < @{$FIG_node->[3]}) {
801 :     if ( $FIG_node->[3]->[$i][1] < $min)
802 :     { $min = $FIG_node->[3]->[$i][1] ;
803 :     $minref = $FIG_node->[3]->[$i] ; }
804 :     $i++;
805 :     }
806 :     ($minref,$min);
807 :     }
808 :    
809 :     sub get_FIG_max_desc {
810 :     # ($maxref,$max) = get_FIG_max_desc($node)
811 :     my ( $FIG_node ) = @_;
812 :     if ((! array_ref( $FIG_node)) && (! array_ref( $FIG_node->[3] ) ) )
813 :     { return undef }
814 :     my ($maxref,$max);
815 :     $max = $FIG_node->[3]->[0][1];
816 :     $maxref = $FIG_node->[3]->[0];
817 :     my $i;
818 :     foreach $i (1 ..@{$FIG_node->[3]}) {
819 :     if ( $FIG_node->[3]->[$i][1] > $max)
820 :     { $max = $FIG_node->[3]->[$i][1] ;
821 :     $maxref = $FIG_node->[3]->[$i] ; }
822 :     }
823 :     ($maxref,$max);
824 :     }
825 :    
826 :     sub FIG_tips_within_dist {
827 :     # collecting all tips in neighborhood of $tree
828 :     # dist is defined by val of node->X
829 :     my ($tree, $dis, $ttips) = @_;
830 :     array_ref($tree) && defined($dis) || undef;
831 :     my $l1 = tips_down_within_dist($tree, $dis, $ttips);
832 :     my $l2 = tips_up_within_dist($tree, $dis, $ttips);
833 :     push(@$ttips,@$l1);
834 :     push(@$ttips,@$l2);
835 :     return $ttips;
836 :     }
837 :    
838 :     sub FIG_nodes_within_dist {
839 :     # collecting all non-tip nodes in neighborhood of tree
840 :     my ($tree, $dis, $tnodes) = @_;
841 :     array_ref($tree) && defined($dis) || undef;
842 :     my $l1 = nodes_down_within_dist($tree, $dis, $tnodes);
843 :     my $l2 = nodes_up_within_dist($tree, $dis, $tnodes);
844 :     shift @$l1;
845 :     push(@$tnodes,@$l1);
846 :     push(@$tnodes,@$l2);
847 :     return $tnodes;
848 :     }
849 :    
850 :     sub FIG_tips_within_steps {
851 :     # collecting all tips in neighborhood of tree
852 :     # one step = one jump from a node to next node in same branch
853 :     my ($tree, $step, $ttips) = @_;
854 :     array_ref($tree) && defined($step) || undef;
855 :     my $l1 = tips_down_within_steps($tree, $step, $ttips);
856 :     my $l2 = tips_up_within_steps($tree, $step, $ttips);
857 :     push(@$ttips,@$l1);
858 :     push(@$ttips,@$l2);
859 :     return $ttips;
860 :     }
861 :    
862 :     sub FIG_duplicate_tips {
863 :     # collects duplicate tips of subtree rooted at $fig
864 :     my ($fig) = @_;
865 :     my @listTips = collect_all_tips( $fig );
866 :     duplicates(@listTips);
867 :     }
868 :    
869 :     sub FIG_duplicate_nodes {
870 :     # collects duplicate non-tip nodes of subtree rooted at $fig
871 :     my ($fig) = @_;
872 :     my @listNodes = collect_all_nodes($fig);
873 :     duplicates(@listNodes);
874 :     }
875 :    
876 :     sub FIG_shared_tips {
877 :     # duplicate tips of two trees
878 :     my ($Tree1, $Tree2) = @_;
879 :     my ( @Tips1 ) = FIG_tips_of_tree( $Tree1 );
880 :     my ( @Tips2 ) = FIG_tips_of_tree( $Tree2 );
881 :     intersection( \@Tips1, \@Tips2 );
882 :     }
883 :    
884 :     sub FIG_num_tips {
885 : golsen 1.2 # tot tips/leaves of tree rooted at $fig
886 : golsen 1.1 ($fig)= @_;
887 : golsen 1.2 my @tips = &collect_all_tips($fig);
888 :     return scalar @tips;
889 : golsen 1.1 }
890 :    
891 :     sub FIG_num_nodes {
892 :     # tot non-tip nodes of tree rooted at $fig
893 :     ($fig) = @_;
894 : golsen 1.2 my @nodes = collect_all_nodes($fig);
895 :     return scalar @nodes;
896 : golsen 1.1 }
897 :    
898 : golsen 1.2
899 :    
900 : golsen 1.1 sub FIG_first_tip {
901 :     #first tip along path of $node
902 :     my ($node) = @_;
903 :     my $tipref = first_tip_ref($node);
904 :     get_FIG_label($tipref);
905 :     }
906 :    
907 :     sub first_tip_ref {
908 :     my ($node) = @_;
909 :     my $child;
910 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
911 :     if (&is_FIG_tip( $node ) ) { return $node; }
912 :     else {
913 :     foreach $child (@{$node->[3]}) {
914 :     &is_FIG_tip( $child ) ? return $child :
915 :     return &first_tip_ref ($child) ;
916 :     }
917 :     }
918 :     }
919 :    
920 :     sub FIG_dist_to_first_tip {
921 :     # distance from $node to first tip along that path
922 :     my ($node) = @_;
923 :     my $path = &get_path_to_first_tip($node);
924 :     distance_along_path(@$path);
925 :     }
926 :    
927 :     sub FIG_steps_to_fist_tip {
928 :     # steps needed to reach first tip from current pos at $node
929 :     my ($node) = @_;
930 :     my $path = get_path_to_first_tip($node);
931 :     return scalar @$path -1;
932 :     }
933 :    
934 :     sub FIG_prefix_of {
935 :     # input: treeref, tipname
936 :     # returns all non-tip nodes along path from root to tip
937 :     my @path = FIG_path_to_tip(@_[0],@_[1]);
938 :     pop @path; #delete tipref from path
939 :     @path;
940 :     }
941 :    
942 :     sub FIG_dist_to_tip {
943 :     # caclulates distance from tree's root to tip
944 :     my ($tree, $tip) = @_;
945 :     my @path = FIG_path_to_tip($tree, $tip);
946 :     distance_along_path(@path);
947 :     }
948 :    
949 :     sub FIG_steps_to_tip {
950 :     # calculates steps from root to tip
951 :     my ($tree, $tip) = @_;
952 :     my @path = FIG_path_to_tip($tree, $tip);
953 :     return scalar @path - 1;
954 :     }
955 :    
956 :     sub FIG_dist_to_node {
957 :     # calculates distance from root to non-tip node
958 :     my ($tree, $node) = @_;
959 :     my @path = FIG_path_to_node_ref( $tree, $node);
960 :     distance_along_path(@path);
961 :     }
962 :    
963 :     sub FIG_steps_to_node {
964 :     # calculates steps from root to non-tip node
965 :     my ($tree, $node) = @_;
966 :     my @path = FIG_path_to_node_ref( $tree, $node);
967 :     return scalar @path -1;
968 :     }
969 :    
970 :     sub FIG_dist_to_root {
971 :     #calculates distance from noderef to root
972 :     my ($tree, $node) = @_;
973 :     FIG_dist_to_node($tree, $node);
974 :     }
975 :    
976 :     sub FIG_steps_to_root {
977 :     #calculates steps from noderef to root
978 :     my ($tree, $node) = @_;
979 :     FIG_steps_to_node($tree, $node);
980 :     }
981 :    
982 :     sub FIG_path_to_first_tip {
983 :     my ($node) = @_;
984 :     &get_path_to_first_tip($node,[]);
985 :     }
986 :    
987 :    
988 :     sub collect_all_tips {
989 :     # collects tiprefs of subtree rooted at $node
990 : golsen 1.2 ($node , @tipList) = @_;
991 : golsen 1.1 my $child;
992 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef }
993 : golsen 1.2 if (&is_FIG_tip( $node ) ) { push( @tipList, $node )}
994 : golsen 1.1 else {
995 :     foreach $child (@{$node->[3]})
996 : golsen 1.2 { &collect_all_tips($child,@tipList); }
997 : golsen 1.1 }
998 : golsen 1.2 return @tipList;
999 :     }
1000 :    
1001 :     sub collect_tips_and_dist {
1002 :     # collects tiprefs of subtree rooted at $node
1003 :     # it also calculates accum. distance from root to each tip
1004 :     $node = shift @_;
1005 :     my $dist = shift @_;
1006 :     @tipList = @_;
1007 :     my $child;
1008 :     my $parent;
1009 :     $dist = defined($dist) ? $dist : 0;
1010 :    
1011 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef }
1012 :     if (&is_FIG_tip( $node ) )
1013 :     {
1014 :     my $d = $dist + $node->[1];
1015 :     push( @tipList, ($node, $d) );
1016 :     }
1017 :     else {
1018 :    
1019 :     $dist += $node->[1];
1020 :     foreach $child (@{$node->[3]})
1021 :     { &collect_tips_and_dist($child, $dist, @tipList);}
1022 :     #now backtracking
1023 :     $parent = $node->[2];
1024 :     $dist -= $parent->[1];
1025 :     }
1026 :     @tipList;
1027 :     }
1028 :    
1029 :     sub sort_list_of_pairs {
1030 :     # gets a list of the form a1, a2, b1, b2, c1, c2 ... where x1, x2 are
1031 :     # two fields for same object, also x1 is a ref and x2 is a string
1032 :     # we sort in ascending order by the second field x2
1033 :     my ( @rest ) = @_;
1034 :     my $mat;
1035 :     my $i=1;
1036 :     while (@rest) {
1037 :     $mat[$i][1] = shift @rest;
1038 :     $mat[$i][2] = shift @rest;
1039 :     $i++;
1040 :     }
1041 :     my @pairs;
1042 :     for (my $k=1; $k < $i; $k++) {
1043 :     for (my $l=$k; $l < $i; $l++) {
1044 :     if ($mat[$l][2] < $mat[$k][2]) {
1045 :     $temp2 = $mat[$k][2]; $temp1 = $mat[$k][1];
1046 :     $mat[$k][2] = $mat[$l][2]; $mat[$k][1] = $mat[$l][1];
1047 :     $mat[$l][2] = $temp2; $mat[$l][1] = $temp1;
1048 :     }
1049 :     }
1050 :     push (@pairs, ($mat[$k]->[1], $mat[$k]->[2]) );
1051 :     }
1052 :     @pairs;
1053 : golsen 1.1 }
1054 :    
1055 :     sub collect_all_nodes {
1056 :     # collects all non-tip noderefs of subtree rooted at $node
1057 : golsen 1.2 ($node , @nodeList) = @_;
1058 : golsen 1.1 my $child;
1059 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
1060 :     if (&is_FIG_tip( $node ) ) { undef }
1061 :     else {
1062 : golsen 1.2 push (@nodeList, $node);
1063 : golsen 1.1 foreach $child (@{$node->[3]})
1064 : golsen 1.2 { &collect_all_nodes($child,@nodeList); }
1065 : golsen 1.1 }
1066 : golsen 1.2 return @nodeList;
1067 :     }
1068 :    
1069 :     sub collect_all_noderef {
1070 :     # collects all noderefs, leaf and nonleaf,
1071 :     # of subtree rooted at $node
1072 :     ($node , @nodeList) = @_;
1073 :     my $child;
1074 :     array_ref($node) || undef;
1075 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
1076 :     else
1077 :     {
1078 :     push (@nodeList, $node);
1079 :     foreach $child (@{$node->[3]})
1080 :     { &collect_all_noderef($child,@nodeList); }
1081 :     }
1082 :    
1083 :     return @nodeList;
1084 : golsen 1.1 }
1085 :    
1086 : golsen 1.2 sub tipref_to_tipname {
1087 :     # gets a list of tip refs and returns a list of tip labels
1088 :     map { get_FIG_label($_) } @_ ;
1089 :     }
1090 : golsen 1.1
1091 :     sub tips_down_within_dist {
1092 :     # collects tips of tree rooted at $node that are within $dist
1093 :     my ($node, $dist) = @_;
1094 :     array_ref($node) && defined($dist) || undef;
1095 :     tot_tips_within_dist($node, $dist);
1096 :     }
1097 :    
1098 :     sub tips_up_within_dist {
1099 :     # collects tips of tree that end at this node and that are within $dist
1100 :     my ($node, $dist, $list) = @_;
1101 :     ! array_ref($node) ? return undef : 1;
1102 :     if ($dist < 0 ) { return undef }
1103 :     my $parent = $node->[2];
1104 :     if ( ! $parent) { return undef }
1105 :     my $vl;
1106 :     if ($parent->[3]->[0] eq $node ) {
1107 :     $vl = tot_tips_within_dist($parent->[3]->[1],
1108 :     ($dist- ($node->[1]+ $parent->[3]->[1]->[1])), $list); }
1109 :     else {
1110 :     $vl = tot_tips_within_dist($parent->[3]->[0],
1111 :     ($dist- ($node->[1]+ $parent->[3]->[0]->[1])), $list) ; }
1112 :     push(@$list, @$vl);
1113 :     tips_up_within_dist($parent, $dist - $node->[1], $list);
1114 :     return $list;
1115 :     }
1116 :    
1117 :     sub tot_tips_within_dist {
1118 :     ($node, $dist1, $tot) = @_;
1119 :     array_ref($node) || undef;
1120 :     my ($child,$len);
1121 :     $len = $dist1;
1122 :     if ($len < 0 ) { return () }
1123 :     if ( is_FIG_tip($node) ) {
1124 :     if ($len >= 0 ) { return push(@$tot,$node->[0]); }
1125 :     else { return (); }
1126 :     }
1127 :     foreach $child (@{$node->[3]}) {
1128 :     tot_tips_within_dist($child,$len-$child->[1],$tot);
1129 :     }
1130 :     $tot? $tot : undef;
1131 :     }
1132 :    
1133 :    
1134 :     sub nodes_down_within_dist {
1135 :     # collects non-tip nodes of tree rooted at $node that are within $dist
1136 :     my ($node, $dist) = @_;
1137 :     array_ref($node) && defined($dist) || undef;
1138 :     tot_nodes_within_dist($node, $dist, []);
1139 :     }
1140 :    
1141 :     sub nodes_up_within_dist {
1142 :     # collects nodes of tree that end at this node and that are within $dist
1143 :     my ($node, $dist, $list) = @_;
1144 :     ! array_ref($node) ? return undef : 1;
1145 :     $dist < 0 ? return undef : push(@$list,$node) ;
1146 :     my $parent = $node->[2];
1147 :     if ( ! $parent) { return }
1148 :     my $vl;
1149 :     if ($parent->[3]->[0] eq $node ) {
1150 :     $vl = tot_nodes_within_dist($parent->[3]->[1],
1151 :     ($dist- ($node->[1]+ $parent->[3]->[1]->[1])) ); }
1152 :     else {
1153 :     $vl = tot_nodes_within_dist($parent->[3]->[0],
1154 :     ($dist- ($node->[1]+ $parent->[3]->[0]->[1])) ) ; }
1155 :     push(@$list, @$vl);
1156 :     nodes_up_within_dist($parent, $dist - $node->[1], $list);
1157 :     return $list;
1158 :     }
1159 :    
1160 :     sub tot_nodes_within_dist {
1161 :     ($node, $dist, $tot) = @_;
1162 :     if ($dist < 0 ) { return undef }
1163 :     if ( is_FIG_root($node) ) { return push(@$tot, $node); }
1164 :     if ( is_FIG_tip($node) ) { return (); }
1165 :     push(@$tot, $node);
1166 :     my ($child,$len);
1167 :     $len = $dist;
1168 :     foreach $child (@{$node->[3]}) {
1169 :     if ( ($len >= $child->[1]) && (! is_FIG_tip($child)))
1170 :     { push(@$tot, $child) }
1171 :     tot_nodes_within_dist($child,$len-$child->[1],$tot);
1172 :     }
1173 :     $tot ? $tot : undef ;
1174 :     }
1175 :    
1176 :     sub tips_down_within_steps {
1177 :     #
1178 :     my ($node, $steps) = @_;
1179 :     array_ref($node) && defined($steps) || undef;
1180 :     tot_tips_within_steps($node, $steps);
1181 :     }
1182 :    
1183 :     sub tips_up_within_steps {
1184 :     my ($node, $steps, $list) = @_;
1185 :     print "\ngetting tips up from node=$node steps left=$steps tips=$list";
1186 :     ! array_ref($node) ? return undef : 1;
1187 :     if ($steps < 0 ) { return undef }
1188 :     my $parent = $node->[2];
1189 :     if ( ! $parent) { return undef }
1190 :     my $vl;
1191 :     if ($parent->[3]->[0] eq $node ) {
1192 :     $vl = tot_tips_within_steps($parent->[3]->[1], ($steps-2), $list); }
1193 :     else {
1194 :     $vl = tot_tips_within_steps($parent->[3]->[0], ($steps-2), $list); }
1195 :     if (@$vl) { push(@$list, @$vl); }
1196 :     tips_up_within_steps($parent, --$steps, $list);
1197 :     return $list;
1198 :     }
1199 :    
1200 :     sub tot_tips_within_steps {
1201 :     ($node, $steps1, $tot) = @_;
1202 :     array_ref($node) || undef;
1203 :     print "\ntot_tips start: node=$node tot=$tot stepsleft=$steps1";
1204 :     my ($child,$len);
1205 :     $len = $steps1;
1206 :     if ($len < 0 ) { return (); }
1207 :     if ( is_FIG_tip($node) ) {
1208 :     $len >= 0 ? return push(@$tot,$node->[0]) : return ();
1209 :     }
1210 :     foreach $child (@{$node->[3]}) {
1211 :     tot_tips_within_steps($child,$len-1,$tot);
1212 :     }
1213 :     print "\ntot_tips end: node=$node tot=$tot stepsleft=$steps1";
1214 :     $tot? $tot : undef;
1215 :     }
1216 :    
1217 : golsen 1.2 sub maxref_of_subtree
1218 :     {
1219 :     ($node) = @_;
1220 :     my ($t, $x) = most_distant_tip_ref($node,1);
1221 :     return ($t, $x);
1222 :     }
1223 :    
1224 :     sub minref_of_subtree
1225 :     {
1226 :     ($node) = @_;
1227 :     my ($t, $x) = closest_tip_ref($node,1);
1228 :     return ($t, $x);
1229 :     }
1230 :    
1231 : golsen 1.1 sub get_path_to_first_tip {
1232 :     ($node, $path) = @_;
1233 :     my $child;
1234 :     array_ref($node) || undef;
1235 :     push(@$path,$node);
1236 :     is_FIG_tip( $node ) ?
1237 :     return $path :
1238 :     return get_path_to_first_tip($node->[3]->[0],$path);
1239 :     }
1240 :    
1241 :     sub FIG_path_to_tip {
1242 :     my ($node, $tip, @path0) = @_;
1243 :     array_ref( $node ) && defined( $tip ) || return undef;
1244 :     push( @path0, $node);
1245 :     my $imax = get_FIG_numDesc($node);
1246 :     if ( $imax < 1 ) {
1247 :     return ( $node->[0] eq $tip ) ? @path0 : () }
1248 :     my @path;
1249 :     for (my $i = 1; $i <= $imax; $i++ ) {
1250 :     @path = FIG_path_to_tip( get_FIG_ith_desc($node, $i),$tip,@path0);
1251 :     if ( @path ) { return @path }
1252 :     }
1253 :    
1254 :     (); # Not found
1255 :     }
1256 :    
1257 :     sub FIG_path_to_root {
1258 :     # input could be noderef or tipname
1259 :     my ($tree, $node) = @_;
1260 :     array_ref($tree) || undef;
1261 :     array_ref($node) ? get_path_to_root($node,[]):
1262 :     reverse FIG_path_to_tip($tree, $node) ;
1263 :     }
1264 :    
1265 :     sub get_path_to_root {
1266 :     ($node, @path) = @_;
1267 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
1268 :     push(@path, $node);
1269 :     if (!$node->[2]) { return @path; }
1270 :     else {
1271 :     get_path_to_root($node->[2],$path);
1272 :     }
1273 :     }
1274 :    
1275 :    
1276 :     sub FIG_path_to_node_ref {
1277 :     # it only works when noderef is in node's subtree
1278 :     my ($node, $noderef, @path0) = @_;
1279 :     push( @path0, $node);
1280 :     if ( $node eq $noderef ) { return @path0 }
1281 :    
1282 :     my @path;
1283 :     my $imax = get_FIG_numDesc($node);
1284 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1285 :     @path =
1286 :     FIG_path_to_node_ref( get_FIG_ith_desc($node, $i), $noderef,@path0);
1287 :     if ( @path ) { return @path }
1288 :     }
1289 :    
1290 :     (); # Not found
1291 :     }
1292 :    
1293 :     sub FIG_path_to_node {
1294 :     # node could be $tipname | [$tipname] | $t1 $t2 $t3
1295 :     my ($node, $tip1, $tip2, $tip3) = @_;
1296 : golsen 1.2 #print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";
1297 : golsen 1.1 array_ref( $node ) && defined( $tip1 ) || return ();
1298 :    
1299 :     # Allow arg 2 to be an array reference
1300 :     if ( array_ref( $tip1 ) ) { ( $tip1, $tip2, $tip3 ) = @$tip1 }
1301 :    
1302 :     my @p1 = FIG_path_to_tip($node, $tip1);
1303 :     @p1 || return ();
1304 : golsen 1.2 #print "\npatht1= @p1";
1305 : golsen 1.1 defined( $tip2 ) && defined( $tip3 ) || return @p1;
1306 :    
1307 :     my @p2 = FIG_path_to_tip($node, $tip2);
1308 :     my @p3 = FIG_path_to_tip($node, $tip3);
1309 :    
1310 :     @p2 && @p3 || return ();
1311 : golsen 1.2 #print "\npatht2= @p2 patht3= @p3";
1312 : golsen 1.1 # Find the common prefix for each pair of paths
1313 :     my @p12 = common_prefix( \@p1, \@p2 );
1314 :     my @p13 = common_prefix( \@p1, \@p3 );
1315 :     my @p23 = common_prefix( \@p2, \@p3 );
1316 :    
1317 :     # Return the longest common prefix of any two paths
1318 :     ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :
1319 :     ( @p13 >= @p23 ) ? @p13 :
1320 :     @p23 ;
1321 :     }
1322 :    
1323 :     sub distance_along_path {
1324 :     # paths with format: [noderef1, noderef2,...]
1325 :     my $node = shift;
1326 :     array_ref( $node ) || return undef;
1327 :     my $d1 = get_FIG_X( $node );
1328 :     my $d2 = @_ ? distance_along_path(@_) : 0;
1329 :     defined($d1) && defined($d2) ? $d1 + $d2 : undef;
1330 :     }
1331 :    
1332 :     sub distance_along_path_2 {
1333 :     # paths with format: [descIndex1, nodeRef1, descRef2, nodeRef2,...]
1334 :     shift; # Discard descendant number
1335 :     my $node = shift;
1336 :     array_ref( $node ) || return undef;
1337 :     my $d1 = get_FIG_X( $node );
1338 :     my $d2 = @_ ? distance_along_path_2(@_) : 0;
1339 :     defined($d1) && defined($d2) ? $d1 + $d2 : undef;
1340 :     }
1341 :    
1342 :     sub most_distant_tip_path {
1343 : golsen 1.2 my ($node) = @_;
1344 :     my ($tmax, $xmax) = most_distant_tip_ref($node);
1345 :     my @pmax = FIG_path_to_node_ref($node, $tmax);
1346 :     @pmax;
1347 :     }
1348 :     sub closest_tip_path {
1349 :     my ($node) = @_;
1350 :     my ($tmin, $xmin) = closest_tip_ref($node);
1351 :     my @pmin = FIG_path_to_node_ref($node, $tmin);
1352 :     @pmin;
1353 :     }
1354 :     sub closest_tip_ref {
1355 :     my ($node) = @_;
1356 :     my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1357 :     my $tmin = shift @tpairs;
1358 :     my $xmin = shift @tpairs;
1359 :     ( $tmin, $xmin );
1360 : golsen 1.1 }
1361 :    
1362 :     sub most_distant_tip_ref {
1363 : golsen 1.2 my ($node) = @_;
1364 :     my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1365 :     my $xmax = pop @tpairs;
1366 :     my $tmax = pop @tpairs;
1367 : golsen 1.1 ( $tmax, $xmax );
1368 :     }
1369 :    
1370 :     sub most_distant_tip_name {
1371 :     my ($tipref, $xmax) = most_distant_tip_ref( $_[0] );
1372 :     ( get_FIG_label( $tipref ), $xmax )
1373 :     }
1374 :    
1375 : golsen 1.2 sub closest_tip_name {
1376 :     my ($tipref, $xmin) = closest_tip_ref( $_[0] );
1377 :     ( get_FIG_label( $tipref ), $xmin )
1378 :     }
1379 : golsen 1.1
1380 :     sub FIG_dist_tip_to_tip {
1381 : golsen 1.2 # tip1 and tip2 should be tip labels and contained in subtree rooted at $node
1382 : golsen 1.1 my ($node, $tip1, $tip2) = @_;
1383 :    
1384 :     array_ref( $node ) && defined( $tip1 )
1385 :     && defined( $tip2 ) || return undef;
1386 :    
1387 :     my @p1 = FIG_path_to_tip($node, $tip1);
1388 :     my @p2 = FIG_path_to_tip($node, $tip2);
1389 :     @p1 && @p2 || return undef;
1390 :    
1391 :     # Find the unique suffixes of the two paths
1392 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1393 : golsen 1.2 my $d1 = @$suf1 ? distance_along_path( @$suf1 ) : 0;
1394 :     my $d2 = @$suf2 ? distance_along_path( @$suf2 ) : 0;
1395 : golsen 1.1 defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1396 :     }
1397 :    
1398 :     sub FIG_dist_node_to_node {
1399 : golsen 1.2 # both node1 and node2 must be refs and in the subtree rooted at $node
1400 : golsen 1.1 # node1 ,node2 could be= $tipname | [$tipname] | $t1 $t2 $t3
1401 :     my ($node, $node1, $node2) = @_;
1402 :    
1403 :     array_ref( $node ) && defined( $node1 )
1404 :     && defined( $node2 ) || return undef;
1405 :     my @p1 = FIG_path_to_node($node, $node1);
1406 :     my @p2 = FIG_path_to_node($node, $node2);
1407 :     @p1 && @p2 || return undef;
1408 :    
1409 :     # Find the unique suffixes of the two paths
1410 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1411 :     my $d1 = @$suf1 ? distance_along_path( @$suf1 ) : 0;
1412 :     my $d2 = @$suf2 ? distance_along_path( @$suf2 ) : 0;
1413 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1414 :     }
1415 :    
1416 :     sub get_FIG_context {
1417 :     # gets tips and nodes within $dist of current $node
1418 :     my($node,$dist) = @_;
1419 :     array_ref($node) && defined($n) || 0;
1420 :     my $tips = FIG_tips_within_dist($node, $dist);
1421 :     my $nodes = FIG_nodes_within_dist($node, $dist);
1422 :     return @$tips + @$nodes;
1423 :     }
1424 :    
1425 :     sub FIG_closest_common_ancestor {
1426 :     # finds common ancestor of up to three tips
1427 :     my ($tree, @tips) = @_;
1428 :     array_ref($tree) || return undef;
1429 :     (scalar @tips > 0) || return undef;
1430 :    
1431 :     my @paths;
1432 :     foreach $tip (@tips) {
1433 :     push( @paths, [ FIG_path_to_tip($tree,$tip) ]);
1434 :     }
1435 :     #simple cases first
1436 :     if (scalar @paths == 1)
1437 :     { my $p = @paths[0];
1438 :     return @$p; }
1439 :     if (scalar @paths == 2)
1440 :     { return common_prefix( @paths[0], @paths[1]) ; }
1441 :     if (scalar @paths == 3)
1442 :     {
1443 :     my @p12 = common_prefix( @paths[0], @paths[1]) ;
1444 :     my @p13 = common_prefix( @paths[0], @paths[2]) ;
1445 :     my @p23 = common_prefix( @paths[1], @paths[2]) ;
1446 :    
1447 :     # Return the shortest common prefix
1448 :     return common_prefix(\@p12,[common_prefix(\@p13,\@p23)]);
1449 :     }
1450 :     # more than three tips. Not processed here
1451 :     undef;
1452 :     }
1453 :    
1454 :    
1455 :     #==================================================================
1456 :     # Tree manipulations
1457 :     # Note: most funtions in this section will alter the tree
1458 :     #==================================================================
1459 :     sub FIG_copy_tree {
1460 :     # creates a copy of the subtree rooted at $node
1461 :     my ($node, $parent) = @_;
1462 :     array_ref( $node ) || return undef;
1463 :     my ( $label, $X, $p, $FIG_desc_list, $node_attrib, $branch_attrib )
1464 :     = @$node;
1465 :    
1466 :     # copying hashes
1467 :     my $nattrib_ref = [];
1468 :     my $battrib_ref = [];
1469 :    
1470 :     my ( $key, $val);
1471 :     if ( hash_ref( $node_attrib ) ) {
1472 :     @$nattrib_ref = map {
1473 :     $key = $_;
1474 :     $val = $node_attrib->{$key};
1475 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val" ;
1476 :     } keys %$node_attrib;
1477 :     }
1478 :     if ( hash_ref( $branch_attrib ) ) {
1479 :     push( @$battrib_ref, map {
1480 :     $key = $_;
1481 :     $val = $branch_attrib->{$key};
1482 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val";
1483 :     } keys %$branch_attrib );
1484 :     }
1485 :    
1486 :     # creating fig node
1487 :     my $nfig=[ $label,$X,$parent,undef,$nattrib_ref,$battrib_ref];
1488 :    
1489 :     # doing the same for each child in descendants list
1490 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
1491 :     my $desc_ref = [ map {FIG_copy_tree( $_, $nfig )} @$FIG_desc_list ];
1492 :     foreach ( @$desc_ref[ 1 .. @$desc_ref-1 ] ) {
1493 :     ( ref( $_ ) eq "ARRAY" ) || return undef
1494 :     }
1495 :     $nfig->[3] = $desc_ref;
1496 :     }
1497 :     else {
1498 :     $nfig->[3] = [ ];
1499 :     }
1500 :    
1501 :     $nfig;
1502 :     }
1503 :    
1504 :     sub FIG_build_tree_from_subtrees {
1505 :     # creates a root node and appends the trees to its descList
1506 :     my($tree1,$tree2, $label, $x) = @_;
1507 :     array_ref($tree1) && array_ref($tree2) || undef;
1508 :     my $nfig = [$label,$x, undef, undef,[],[]];
1509 :     $tree1->[2] = $nfig;
1510 :     $tree2->[2] = $nfig;
1511 :     $nfig->[3]->[0]= $tree1;
1512 :     $nfig->[3]->[1]= $tree2;
1513 :     return $nfig;
1514 :     }
1515 :    
1516 :     sub FIG_reverse_tree {
1517 :     # reverses order of tree [in place]
1518 :     my ($node) = @_;
1519 :    
1520 :     my $imax = get_FIG_numDesc( $node );
1521 :     if ( $imax > 0 ) {
1522 :     set_FIG_descList( $node, reverse get_FIG_descList( $node ) );
1523 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1524 :     FIG_reverse_tree( get_FIG_ith_desc( $node, $i ) );
1525 :     }
1526 :     }
1527 :     $node;
1528 :     }
1529 :    
1530 :     sub FIG_top_tree {
1531 :     # creates a copy of a tree, then truncates all subtrees so all branches
1532 :     # will have lengths no larger than $depth
1533 :     my ($tree, $depth) = @_;
1534 :     array_ref($tree) && defined($depth) || undef;
1535 :     my $newtree = FIG_copy_tree($tree);
1536 :     FIG_chop_tree($newtree, $depth);
1537 :     }
1538 :    
1539 :     sub FIG_chop_tree {
1540 :     # chops branches [i.e. tip and/or complete subtrees]
1541 :     # of tree rooted at $node; resulting branch-lengths are <= $depth
1542 :     my ($node,$depth) = @_;
1543 :     array_ref($node) && defined($depth) || undef;
1544 :     my $sz = FIG_tree_length($node);
1545 :     if ($sz <= $depth)
1546 :     { print "\n nothing to chop depth > treeLength";
1547 :     return undef; }
1548 :     #my $root = get_FIG_root($node);
1549 :     chop_tree($node, $node, $depth);
1550 :     }
1551 :    
1552 :     sub chop_tree {
1553 :     # chops entire sections of the tree rooted at $node
1554 :     # whose branch-lengths are larger than $depth
1555 :     ($tree, $node,$depth) = @_;
1556 :     array_ref($node) && array_ref($root) && defined($depth)|| undef;
1557 :     my ($child, $len);
1558 :     $len = $depth;
1559 :     if ($len < 0)
1560 :     {
1561 :     #need to chop at this point.
1562 :     is_FIG_tip($node) ? return FIG_prune_tip($tree, $node) :
1563 :     return FIG_prune_node($tree, $node);
1564 :     }
1565 :     foreach $child (@{$node->[3]}) {
1566 :     chop_tree($tree, $child, $len-$child->[1]);
1567 :     }
1568 :     }
1569 :    
1570 : golsen 1.2 sub FIG_split_tree {
1571 :     # we split the tree at random into subregions, AKA bunches
1572 :     # Our approach: at least one region is sure to contain
1573 :     # the tree's representative leaves; the other regions
1574 :     # will contain leaves that were selected at random
1575 :    
1576 :     my ($fig, $numBunches) = @_;
1577 :     my @trees;
1578 :     if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
1579 :     if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
1580 :     if ($numBunches == 1) {print "\nno split, numbunch is one";return $fig; }
1581 :    
1582 :    
1583 :     # so far, we will use these heuristics; later on
1584 :     # we need to replace this one with min spanning tree
1585 :     # or some such
1586 :     my $size = FIG_region_size($fig, $numBunches );
1587 :     $trees[1] = FIG_representative_tree(FIG_copy_tree($fig), $size );
1588 :     for (my $i = 2; $i <= $numBunches; $i++) {
1589 :     $trees[$i] = &get_random_minitree(FIG_copy_tree($fig),$size );
1590 :     }
1591 :     return @trees;
1592 :     }
1593 :    
1594 :     sub get_random_minitree {
1595 :     my ($tree,$size) = @_;
1596 :     array_ref($tree) && defined($size) || undef;
1597 :     my $tip;
1598 :     my @tips = FIG_tips_of_tree($tree);
1599 :     my @randTips = random_order(@tips);
1600 :     my @minitree = splice @randTips, 0,$size;
1601 :     my @tipsToremove = set_difference(\@tips, \@minitree);
1602 :     if (! @tipsToremove) {return undef;}
1603 :     foreach $tip (@tipsToremove) { FIG_prune_tip($tree,$tip); }
1604 :     return $tree;
1605 :     }
1606 :    
1607 :    
1608 : golsen 1.1 sub FIG_representative_tree {
1609 :     # thins the tree off of small tips until tree is of specified size
1610 :     my ($tree, $size) = @_;
1611 : golsen 1.2 my $tip;
1612 : golsen 1.1 array_ref($tree) && defined($size) || undef;
1613 : golsen 1.2 my @tiprefs = collect_all_tips( $tree );
1614 :     my @sortedtips = sort by_distance @tiprefs;
1615 :     my $to_remove = (scalar @sortedtips) - $size;
1616 :     if ($to_remove <= 0) { return $tree; }
1617 :     my @tips= tipref_to_tipname(@sortedtips);
1618 : golsen 1.1 while ($to_remove > 0)
1619 :     {
1620 : golsen 1.2 $tip = shift @tips;
1621 : golsen 1.1 FIG_prune_tip($tree,$tip);
1622 :     $to_remove--;
1623 :     }
1624 :     $tree;
1625 :     }
1626 :    
1627 :     sub collapse_FIG_tree {
1628 :     # searches entire tree rooted at $tree and collapses unneces. branches.
1629 :     # there are two cases:
1630 :     # node-tip -> tip collapse
1631 :     # node-node -> node collapse
1632 :     my ($tree) = @_;
1633 :     array_ref($tree) || undef;
1634 :     if ( is_FIG_tip($tree) ) { return; }
1635 :     if ( (! is_FIG_tip($tree) ) && ( get_FIG_numDesc($tree) == 1) )
1636 :     {
1637 :     is_FIG_tip($tree->[3]->[0]) ?
1638 :     FIG_collapse_node_tip($tree) :
1639 :     FIG_collapse_node_node($tree) ;
1640 :     }
1641 :     my $child;
1642 :     foreach $child (@{$tree->[3]}) {
1643 :     collapse_FIG_tree($child);
1644 :     }
1645 :     $tree;
1646 :     }
1647 :     sub FIG_collapse_node_tip {
1648 :     # $node has one descendant which is a tip
1649 :     # we collapse both node and tip into one [tip]
1650 :     my ($node) = @_;
1651 :     array_ref($node) || undef;
1652 :     my $child = $node->[3];
1653 :     if (scalar @$child > 1) { #stop. more than one child
1654 :     return undef; }
1655 :     my $tip = shift @$child;
1656 :     is_FIG_tip($tip) || undef;
1657 :    
1658 :     # collapsing tip and node into one tip";
1659 :     $node->[0] = join($node->[0],$tip->[0]);
1660 :     $node->[1] += $tip->[1];
1661 :     $node->[3] = [];
1662 :     add_FIG_node_attrib($node, $tip->[4]);
1663 :     add_FIG_branch_attrib($node, $tip->[5]);
1664 :    
1665 :     $node;
1666 :     }
1667 :    
1668 :     sub FIG_collapse_node_node {
1669 :     # $node has one descendant which is NOT a tip
1670 :     # we collapse both nodes into one [node]
1671 :     my ($node) = @_;
1672 :     array_ref($node1) || undef;
1673 :    
1674 :     my $child = $node->[3];
1675 :     if (scalar @$child > 1) { return undef; }
1676 :     my $child = shift @$child;
1677 :     if (is_FIG_tip($child) ) { return FIG_collapse_node_tip($node) }
1678 :    
1679 :     # collapsing two nodes into one
1680 :     $node->[0] = join($node->[0],$child->[0]);
1681 :     $node->[1] += $child->[1];
1682 :     $node->[3] = $child->[3];
1683 :     add_FIG_node_attrib($node,$child->[4]);
1684 :     add_FIG_branch_attrib($node,$child->[5]);
1685 :    
1686 :     $node;
1687 :     }
1688 :    
1689 :     sub FIG_prune_tip {
1690 :     # tip node is deleted, then tree is normalized w/ local operations
1691 :     # input could be tipref or tipname
1692 :     my ($tree, $tip1) = @_;
1693 : golsen 1.2
1694 : golsen 1.1 array_ref($tree) && defined($tip1) || undef;
1695 : golsen 1.2
1696 : golsen 1.1 if (! array_ref($tip1) )
1697 :     { # arg 2 is a tipname; we need a tipref
1698 :     $tip1 = get_FIG_tipref($tree,$tip1);
1699 :     }
1700 : golsen 1.2
1701 :     if (!is_FIG_tip($tip1)) {print "\ntip not in tree: ";
1702 :     print $tip1;return undef;}
1703 : golsen 1.1 my $parent = $tip1->[2];
1704 : golsen 1.2 if (! array_ref($parent)) {print "\nlast tip, now empty tree";return undef; }
1705 :     my $children = $parent->[3];
1706 :     my @leaves;
1707 : golsen 1.1 my $tip2;
1708 : golsen 1.2 my $child;
1709 :    
1710 :     #some of the children may not be tips; let's find out
1711 :     foreach $child (@{$parent->[3]})
1712 :     { if ($child->[0]) { push (@leaves,$child); } }
1713 :    
1714 :     if (scalar @leaves == 3)
1715 : golsen 1.1 {
1716 : golsen 1.2 # unrooted tree. Delete tip from the parent's descList
1717 :     delete_FIG_descRef($parent,$tip1);
1718 :     return tree;
1719 : golsen 1.1 }
1720 : golsen 1.2 if (scalar @leaves == 2)
1721 : golsen 1.1 {
1722 : golsen 1.2 # need to collapse tip2 and tip1's parent nodes into one
1723 :     ($tip2) = pop @leaves;
1724 :     if ($tip2->[0] eq $tip1->[0]) { $tip2= pop @leaves; }
1725 :     $parent->[0] = $tip2->[0];
1726 : golsen 1.1 $parent->[1] += $tip2->[1];
1727 : golsen 1.2 $parent->[3] = undef;
1728 :     if (array_ref($tip2->[4]) )
1729 :     {add_FIG_node_attrib($parent, $tip2->[4]);}
1730 :     if (array_ref( $tip2->[5]) )
1731 :     {add_FIG_branch_attrib($parent, $tip2->[5]); }
1732 :     return tree;
1733 : golsen 1.1 }
1734 : golsen 1.2 if (scalar @leaves == 1)
1735 :     {
1736 :     if (@$children == 1) {
1737 :     # just delete tip from the parent's descList
1738 :     $parent->[3] = undef;
1739 :     return tree;
1740 :     }
1741 :     else {
1742 :     # we have one tip and one node hanging out of parent node
1743 :     # we need to collapse two nodes in a row into one
1744 :     FIG_prune_node($parent,$tip1);
1745 :     return tree;
1746 :     }
1747 :     }
1748 :     if (scalar @leaves == 0)
1749 :     { print "\nabsurd, no tips"; return tree; }
1750 :     return $tree;
1751 : golsen 1.1 }
1752 :    
1753 :    
1754 :     sub FIG_prune_node {
1755 :     # entire subtree rooted at $node1 is deleted,
1756 :     # resulting $tree is normalized with local operations
1757 :     my ($tree, $node1) = @_;
1758 :     is_FIG_node($node1) || undef;
1759 :     if (is_FIG_root($node1)) { return uproot_FIG($node1) }
1760 :     my $parent = $node1->[2];
1761 :     my $grandp = $parent->[2];
1762 :     my $children = $parent->[3];
1763 :     my $node2;
1764 :     if ( ! $grandp)
1765 :     { # close to root; just delete it from parent's desc list
1766 :     delete_FIG_descRef($parent,$node1);
1767 :     return $parent;
1768 :     }
1769 :     if (@$children == 2)
1770 :     { # need to collapse parent and sibling into one";
1771 :     $node2 = ($children->[0] eq $node1) ?
1772 :     $children->[1] : $children->[0];
1773 : golsen 1.2 $node2->[0] = $parent->[0];
1774 : golsen 1.1 $node2->[1] += $parent->[1];
1775 :     $node2->[2] = $grandp;
1776 :     add_FIG_node_attrib($node2,$parent->[4]);
1777 :     add_FIG_branch_attrib($node2,$parent->[5]);
1778 :     delete_FIG_descRef($grandp,$parent);
1779 :     add_FIG_desc($grandp,$node2);
1780 :     }
1781 :     else {return undef }
1782 :     $node2;
1783 :     }
1784 :    
1785 :     sub normalize_FIG_tree {
1786 : golsen 1.2 # performs global operations on tree to get rid of nodes
1787 :     # with a single child
1788 : golsen 1.1 my ($node) = @_;
1789 :    
1790 :     my @descends = get_FIG_descList( $node );
1791 :     if ( @descends == 0 ) { return ( $node, lc get_FIG_label( $node ) ) }
1792 :    
1793 :     my %hash = map { (normalize_FIG_tree( $_ ))[1] => $_ } @descends;
1794 :     my @keylist = sort { $a cmp $b } keys %hash;
1795 :     set_FIG_descList( $node, map { $hash{$_} } @keylist );
1796 :    
1797 :     ($node, $keylist[0]);
1798 :     }
1799 :    
1800 :     sub std_unrooted_FIG {
1801 :     my ($tree) = @_;
1802 :     my ($mintip) = sort { lc $a cmp lc $b } FIG_tips_of_tree( $tree );
1803 :     ( normalize_FIG_tree( reroot_next_to_tip( $tree, $mintip ) ) )[0];
1804 :     }
1805 :    
1806 :    
1807 :     sub build_tip_count_hash {
1808 :     my ($node, $cntref) = @_;
1809 :     my ($i, $imax, $cnt);
1810 :    
1811 :     $imax = get_FIG_numDesc($node);
1812 :     if ($imax < 1) { $cnt = 1 }
1813 :     else {
1814 :     $cnt = 0;
1815 :     for ( $i = 1; $i <= $imax; $i++ ) {
1816 :     $cnt += build_tip_count_hash(get_FIG_ith_desc($node, $i),$cntref );
1817 :     }
1818 :     }
1819 :    
1820 :     $cntref->{$node} = $cnt;
1821 :     $cnt;
1822 :     }
1823 :    
1824 :     sub FIG_random_order_tree {
1825 :     my ($node) = @_;
1826 :     my $nd = get_FIG_numDesc($node);
1827 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1828 :     # Reorder this subtree:
1829 :     my $dl_ref = get_FIG_descRef($node);
1830 :     @$dl_ref = random_order( @$dl_ref );
1831 :     # Reorder descendants:
1832 :     for ( my $i = 0; $i < $nd; $i++ ) {
1833 :     FIG_random_order_tree( $dl_ref->[$i] );
1834 :     }
1835 :     $node;
1836 :     }
1837 :    
1838 :     sub reorder_FIG_by_tip_count {
1839 :     my ($node, $cntref, $dir) = @_;
1840 :    
1841 :     my $nd = get_FIG_numDesc($node);
1842 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1843 :    
1844 :     # Reorder this subtree:
1845 :    
1846 :     my $dl_ref = get_FIG_descRef($node);
1847 :     if ( $dir < 0 ) { # Big group first
1848 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1849 :     }
1850 :     elsif ( $dir > 0 ) { # Small group first
1851 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1852 :     }
1853 :    
1854 :     # Reorder within descendant subtrees:
1855 :    
1856 :     my $step = 0;
1857 :     if (abs($dir) < 1e5) {
1858 :     $dir = 1 - $nd; # Midgroup => as is
1859 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1860 :     $step = 2;
1861 :     }
1862 :    
1863 :     for ( my $i = 0; $i < $nd; $i++ ) {
1864 :     reorder_FIG_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1865 :     $dir += $step;
1866 :     }
1867 :    
1868 :     $node;
1869 :     }
1870 :    
1871 :     sub reorder_FIG_against_tip_count {
1872 :     my ($node, $cntref, $dir) = @_;
1873 :    
1874 :     my $nd = get_FIG_numDesc($node);
1875 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1876 :    
1877 :     # Reorder this subtree:
1878 :    
1879 :     my $dl_ref = get_FIG_descRef($node);
1880 :     if ( $dir > 0 ) { # Big group first
1881 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1882 :     }
1883 :     elsif ( $dir < 0 ) { # Small group first
1884 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1885 :     }
1886 :    
1887 :     # Reorder within descendant subtrees:
1888 :    
1889 :     my $step = 0;
1890 :     if (abs($dir) < 1e5) {
1891 :     $dir = 1 - $nd; # Midgroup => as is
1892 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1893 :     $step = 2;
1894 :     }
1895 :    
1896 :     for ( my $i = 0; $i < $nd; $i++ ) {
1897 :     reorder_FIG_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1898 :     $dir += $step;
1899 :     }
1900 :    
1901 :     $node;
1902 :     }
1903 :    
1904 :     sub rearrange_FIG_smallest_out {
1905 :     my ($tree, $dir) = @_;
1906 :     my %cnt;
1907 :    
1908 :     $dir = ! $dir ? 0 : # Undefined or zero
1909 :     $dir <= -2 ? -1000000 :
1910 :     $dir < 0 ? -1 :
1911 :     $dir >= 2 ? 1000000 :
1912 :     1 ;
1913 :     build_tip_count_hash( $tree, \%cnt );
1914 :     reorder_FIG_against_tip_count( $tree, \%cnt, $dir );
1915 :     }
1916 :    
1917 :     sub rearrange_FIG_largest_out {
1918 :     my ($tree, $dir) = @_;
1919 :     my %cnt;
1920 :    
1921 :     $dir = ! $dir ? 0 : # Undefined or zero
1922 :     $dir <= -2 ? -1000000 :
1923 :     $dir < 0 ? -1 :
1924 :     $dir >= 2 ? 1000000 :
1925 :     1 ;
1926 :     build_tip_count_hash( $tree, \%cnt );
1927 :     reorder_FIG_by_tip_count( $tree, \%cnt, $dir );
1928 :     }
1929 :    
1930 :    
1931 :     sub reroot_FIG_by_path {
1932 :     my ($node1, @rest) = @_;
1933 :     array_ref( $node1 ) || return undef;
1934 :    
1935 :     @rest || return $node1;
1936 :    
1937 :     my $node2 = $rest[0];
1938 :     is_desc_of_FIGnode($node1, $node2) || return undef;
1939 :    
1940 :     #removing node2 from node1's descendant list
1941 :     my $dl1 = delete_elm( $node1->[3], $node2 );
1942 :     my $nd1 = @$dl1;
1943 :    
1944 :     # Append node 1 to node 2 descendant list (does not alter numbering):
1945 :     my $dl2 = get_FIG_descRef( $node2 );
1946 :     if ( array_ref($dl2) ) { push (@$dl2, $node1 )}
1947 :     else { set_FIG_descList( $node2, [ $node1 ] ) }
1948 :    
1949 :     # Move c1 comments from node 1 to node 2:
1950 :    
1951 :     my $C11 = $node1->[4]->{ "Newick_C1" };
1952 :     my $C12 = $node2->[4]->{ "Newick_C1" };
1953 :     ! defined( $C11 ) || set_FIG_node_attrib( $node1,( 'Newick_C1' =>undef ));
1954 :     if ( $C12 && @$C12 ) {
1955 :     if ( $C11 && @$C11 ) { unshift @$C12, @$C11 }
1956 :     }
1957 :     elsif ( $C11 && @$C11 ) {set_FIG_node_attrib($node2,('Newick_C1'=>$C11))}
1958 :    
1959 :     # Swap branch lengths and comments for reversal of link direction:
1960 :    
1961 :     my $x1 = get_FIG_X( $node1 );
1962 :     my $x2 = get_FIG_X( $node2 );
1963 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_FIG_X( $node1, $x2 );
1964 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_FIG_X( $node2, $x1 );
1965 :    
1966 :     my $c41 = $node1->[5]->{ "Newick_C4" };
1967 :     my $c42 = $node2->[5]->{ "Newick_C4" };
1968 :     ! defined( $c42 ) || ! @$c42 ||
1969 :     set_FIG_branch_attrib($node1,('Newick_C4'=>$c42)) ;
1970 :     ! defined( $c41 ) || ! @$c41 ||
1971 :     set_FIG_branch_attrib($node2,('Newick_C4'=>$c41)) ;
1972 :    
1973 :    
1974 :     my $c51 = $node1->[5]->{ "Newick_C5" };
1975 :     my $c52 = $node2->[5]->{ "Newick_C5" };
1976 :     ! defined( $c52 ) || ! @$c52 ||
1977 :     set_FIG_branch_attrib($node1,('Newick_C5'=>$c52)) ;
1978 :    
1979 :     ! defined( $c51 ) || ! @$c51 ||
1980 :     set_FIG_branch_attrib($node2,('Newick_C5'=>$c51)) ;
1981 :    
1982 :     reroot_FIG_by_path( @rest );
1983 :     }
1984 :    
1985 :     sub reroot_FIG_to_tip {
1986 :     my ($tree, $tipname) = @_;
1987 :     my @path = FIG_path_to_tip( $tree, $tipname );
1988 :     reroot_FIG_by_path(@path);
1989 :     }
1990 :     sub reroot_FIG_next_to_tip {
1991 :     my ($tree, $tipname) = @_;
1992 :     my @path = FIG_path_to_tip( $tree, $tipname );
1993 :     @path || return undef;
1994 :     @path == 1 ? reroot_FIG_by_path( $tree, 1,get_FIG_ith_desc( $tree, 1 ) )
1995 :     : reroot_FIG_by_path( @path[0 .. @path-3] );
1996 :     }
1997 :     sub reroot_FIG_to_node {
1998 :     reroot_FIG_by_path( FIG_path_to_node( @_ ) );
1999 :     }
2000 :     sub reroot_FIG_to_node_ref {
2001 :     my ($tree, $node) = @_;
2002 :     reroot_FIG_by_path( FIG_path_to_node_ref( $tree, $node ) );
2003 :     }
2004 :    
2005 :     sub uproot_tip_to_node {
2006 :     my ($node) = @_;
2007 :     is_FIG_tip_rooted( $node ) || return $node;
2008 :    
2009 :     # Path to the sole descendant:
2010 :     reroot_FIG_by_path( $node, 1, get_FIG_ith_desc( $node, 1 ) );
2011 :     }
2012 :    
2013 :     sub uproot_FIG {
2014 :     # removes bifurcating tree
2015 :     my ($node0) = @_;
2016 :     is_FIG_rooted( $node0 ) || return $node0;
2017 :    
2018 :     my $node1 = get_FIG_ith_desc( $node0, 1 );
2019 :     my $node2 = get_FIG_ith_desc( $node0, 2 );
2020 :    
2021 :     # Ensure that node1 has at least 1 descendant
2022 :     if (get_FIG_numDesc($node1) ) { }
2023 :     elsif (get_FIG_numDesc($node2) ) { ($node1,$node2) = ($node2, $node1) }
2024 :     else { die "uproot_FIG requires more that 2 taxa\n" }
2025 :    
2026 :     push(@{ get_FIG_descRef($node1) }, $node2);
2027 :    
2028 :     # Prefix node1 branch to that of node2:
2029 :    
2030 :     add_FIG_branch_attrib($node2,get_FIG_branch_attrib($node1));
2031 :     set_FIG_X($node2, $node2->[1]+$node1->[1]);
2032 :    
2033 :     set_FIG_X($node1, undef);
2034 :     set_FIG_branch_attrib($node1, undef);
2035 :    
2036 :    
2037 :     # Tree prefix comment lists (as references):
2038 :     my $C10 = $node0->[4]->{ "Newick_C1" };
2039 :     my $C11 = $node1->[4]->{ "Newick_C1" };
2040 :    
2041 :     if ( $C11 && @$C11 ) {
2042 :     if ( $C10 && @$C10 ) { unshift @$C11, @$C10 }
2043 :     }
2044 :     else { set_FIG_node_attrib($node1,('Newick_C1'=>$C10)) }
2045 :     set_FIG_node_attrib($node0,('Newick_C1'=>undef));
2046 :    
2047 :     $node1;
2048 :     }
2049 :    
2050 :    
2051 :     #------------------------------------------------------------------
2052 :     # I/O [parse/print] functions
2053 :     #------------------------------------------------------------------
2054 :    
2055 :     sub FIG_print_node_attrib {
2056 :     my ($FIG_node) = @_;
2057 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
2058 :     = @$FIG_node;
2059 :     my ($key, $val);
2060 :     if ( hash_ref( $node_attrib ) ) {
2061 :     while ($key = each %$node_attrib)
2062 :     {
2063 :     $val = $node_attrib->{$key};
2064 :     if (@$val > 0) { print "$key: "; map {print "$_, " } @$val;}
2065 :     else { print "$key: ",$val ; }
2066 :     }
2067 :     }
2068 :     }
2069 :    
2070 :     sub FIG_print_branch_attrib {
2071 :     my ($FIG_node) = @_;
2072 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
2073 :     = @$FIG_node;
2074 :     my ($key, $val);
2075 :     if ( hash_ref( $branch_attrib ) ) {
2076 :     while ($key = each %$branch_attrib)
2077 :     {
2078 :     $val = $branch_attrib->{$key};
2079 :     if (@$val > 0) { print "$key: "; map {print "$_, " } @$val;}
2080 :     else { print "$key: ",$val ; }
2081 :     }
2082 :     }
2083 :    
2084 :     }
2085 :    
2086 :     sub print_attrib_hash {
2087 :     my ($hash) = @_;
2088 :     my ($key, $val);
2089 :     if ( hash_ref( $hash ) ) {
2090 :     while ($key = each %$hash)
2091 :     {
2092 :     $val = $hash->{$key};
2093 :     @$val > 1 ? print "$key: ",@$val : print "$key: ",$val ;
2094 :     }
2095 :     }
2096 :     else { print "\nnot a hash table" }
2097 :     }
2098 :    
2099 :     sub FIG_print_node {
2100 :     my ($FIG_node) = @_;
2101 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
2102 :     = @$FIG_node;
2103 :     my $child;
2104 :     print "\nnode info= \n";
2105 :     print "ref : $FIG_node lbl: $label len: $X par: $parent ";
2106 :     print " node?: ", &is_FIG_node($FIG_node);
2107 :     print " leaf?: ", &is_FIG_tip($FIG_node);
2108 :     print "\nnumChildren: ", &get_FIG_numDesc($FIG_node);
2109 :     print " childrenRefs: @$FIG_desc_list ";
2110 :     print "\nnAtt: $node_attrib len = ",&get_FIG_num_node_attrib;
2111 :     print " key:vals= "; print FIG_print_node_attrib($FIG_node);
2112 :     print "\nbAtt: $branch_attrib len =", &get_FIG_num_branch_attrib;
2113 :     print " key:vals= "; print FIG_print_branch_attrib($FIG_node);
2114 :     }
2115 :    
2116 :     sub FIG_print_tree {
2117 :     my ($FIG_node) = @_;
2118 :     my $child;
2119 :     &FIG_print_node($FIG_node);
2120 :     foreach $child (@{$FIG_node->[3]}) { &FIG_print_tree($child); }
2121 :     }
2122 :    
2123 :     sub write_FIG_to_Newick {
2124 :     # writes to file the FIG tree in Newick format
2125 :     my ($figtree) = @_;
2126 :     open $fh, ">newickOut";
2127 :     writeNewickTree( FIGtree_to_newick($figtree), $fh );
2128 :     close $fh;
2129 :     }
2130 :    
2131 :     sub read_FIG_from_str {
2132 :     # reads a string and creates a fig tree with it
2133 :     my ($string) = @_;
2134 :     my $newick = parse_newick_tree_str( $string );
2135 :     my $fig = newick_to_FIGtree( $newick );
2136 :     $fig;
2137 :     }
2138 :    
2139 :     sub layout_FIG_tree {
2140 :     my ($fignode) = @_;
2141 :     layout_tree( FIGtree_to_newick($fignode) );
2142 :     }
2143 :    
2144 :     #=========================================================================
2145 :     # Interconverting Overbeek tree and FIG_tree:
2146 :     #=========================================================================
2147 :     # overbeek_to_FIGtree
2148 :     #-------------------------------------------------------------------------
2149 : golsen 1.2
2150 : golsen 1.1 sub overbeek_to_FIGtree {
2151 :     my ( $ro_node, $parent ) = @_;
2152 :     ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;
2153 :    
2154 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
2155 :    
2156 :     my ( $label, $X, $ro_desc_list, $ro_attrib_list ) = @$ro_node;
2157 :     ( array_ref($ro_desc_list) && ( @$ro_desc_list ) ) || return undef;
2158 :    
2159 :     # Process the node attribute list key value pairs. Newick comments are
2160 :     # special case in that they always go in a list, not a standalone value.
2161 :     # Comments 4 and 5 are branch properties in a FIGtree.
2162 :    
2163 :     my $n_attrib_ref = undef;
2164 :     my $b_attrib_ref = undef;
2165 :    
2166 :     if ( ref( $ro_attrib_list ) eq "ARRAY" ) {
2167 :     my %n_attribs = ();
2168 :     my %b_attribs = ();
2169 :     my ( $key, $val );
2170 :    
2171 :     foreach ( @$ro_attrib_list ) {
2172 :     if ( $_ =~ /^([^\t]+)\t(.*)$/ ) {
2173 :     ( $key, $val ) = ( $1, $2 );
2174 :     if ( $key =~ /^Newick_C[1-3]$/ ) {
2175 :     if ( $n_attribs{ $key } ) { push @{ $n_attribs{ $key } }, $val }
2176 :     else { $n_attribs{ $key } = [ $val ] }
2177 :     }
2178 :     elsif ( $key =~ /^Newick_C[45]$/ ) {
2179 :     if ( $b_attribs{ $key } ) { push @{ $b_attribs{ $key } }, $val }
2180 :     else { $b_attribs{ $key } = [ $val ] }
2181 :     }
2182 :     else {
2183 :     $n_attribs{ $key } = $val;
2184 :     }
2185 :     }
2186 :     }
2187 :     if ( %n_attribs ) { $n_attrib_ref = \%n_attribs }
2188 :     if ( %b_attribs ) { $b_attrib_ref = \%b_attribs }
2189 :     }
2190 :    
2191 :     # We need to create the FIGtree node reference before we can create the
2192 :     # children:
2193 :    
2194 :     my $FIG_node = [ $label,
2195 :     $X,
2196 :     $parent,
2197 :     undef,
2198 :     $b_attrib_ref ? ( $n_attrib_ref, $b_attrib_ref )
2199 :     : $n_attrib_ref ? ( $n_attrib_ref )
2200 :     : ()
2201 :     ];
2202 :    
2203 :     # Build the descendent list, and check that all child nodes are defined:
2204 :    
2205 :     if ( @$ro_desc_list > 1 ) {
2206 :     my $desc_ref = [ map { overbeek_to_FIGtree( $_, $FIG_node )
2207 :     } @$ro_desc_list[ 1 .. @$ro_desc_list-1 ]
2208 :     ];
2209 :     foreach ( @$desc_ref ) { ( ref( $_ ) eq "ARRAY" ) || return undef }
2210 :     $FIG_node->[3] = $desc_ref;
2211 :     }
2212 :    
2213 :     $FIG_node;
2214 :     }
2215 :    
2216 :    
2217 :     #-------------------------------------------------------------------------
2218 :     # FIGtree_to_overbeek
2219 :     #-------------------------------------------------------------------------
2220 :    
2221 :     sub FIGtree_to_overbeek {
2222 :     my ( $FIG_node, $parent ) = @_;
2223 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
2224 :    
2225 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = 0 );
2226 :    
2227 :     my ( $label, $X, undef, $FIG_desc_list, $node_attrib, $branch_attrib ) = @$FIG_node;
2228 :     ( ! $FIG_desc_list ) || ( ref( $FIG_desc_list ) eq "ARRAY" ) || return undef;
2229 :    
2230 :     # Build attribute key-value pairs. Expand lists into multiple
2231 :     # instances of same key:
2232 :    
2233 :     my $attrib_ref = [];
2234 :     my ( $key, $val);
2235 :     if ( ref( $node_attrib ) eq "HASH" ) {
2236 :     @$attrib_ref = map {
2237 :     $key = $_;
2238 :     $val = $node_attrib->{$key};
2239 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val"
2240 :     } keys %$node_attrib;
2241 :     }
2242 :     if ( ref( $branch_attrib ) eq "HASH" ) {
2243 :     push( @$attrib_ref, map {
2244 :     $key = $_;
2245 :     $val = $branch_attrib->{$key};
2246 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val"
2247 :     } keys %$branch_attrib);
2248 :     }
2249 :    
2250 :     # Create the Overbeek node so that we have parent reference for the
2251 :     # children:
2252 :    
2253 :     my $ro_node = [ $label, $X, undef, $attrib_ref ];
2254 :    
2255 :     # Build the descendent list, with the parent node as the first element:
2256 :    
2257 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
2258 :     my $desc_ref = [ $parent,
2259 :     map { FIGtree_to_overbeek( $_, $ro_node ) } @$FIG_desc_list
2260 :     ];
2261 :     foreach ( @$desc_ref[ 1 .. @$desc_ref-1 ] ) {
2262 :     ( ref( $_ ) eq "ARRAY" ) || return undef
2263 :     }
2264 :     $ro_node->[2] = $desc_ref;
2265 :     }
2266 :     else {
2267 :     $ro_node->[2] = [ $parent ];
2268 :     }
2269 :    
2270 :     $ro_node;
2271 :     }
2272 :    
2273 :    
2274 :     #=========================================================================
2275 :     # Parent node references in FIG trees and Overbeek trees.
2276 :     #
2277 :     # Both FIG trees and Overbeek trees include a reference back to the
2278 :     # parent node. We should condsider it it is worth routinely maintaining
2279 :     # these values (creating them as the tree is created), or wether to fill
2280 :     # them in only when needed (which will be very fast).
2281 :     #
2282 :     # The following two routines add/update the values in an existing tree.
2283 :     #=========================================================================
2284 :     # fill_FIGtree_parents
2285 :     #-------------------------------------------------------------------------
2286 :    
2287 :     sub fill_FIGtree_parents {
2288 :     my ( $FIG_node, $parent ) = @_;
2289 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
2290 :    
2291 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
2292 :     $FIG_node->[2] = $parent;
2293 :    
2294 :     # Work through the descendent list:
2295 :    
2296 :     my $desc_list = $FIG_node->[3];
2297 :     if ( ref( $desc_list ) eq "ARRAY" ) {
2298 :     foreach ( @$desc_list ) {
2299 :     fill_FIGtree_parents( $_, $FIG_node ) || return undef;
2300 :     }
2301 :     }
2302 :    
2303 :     $FIG_node;
2304 :     }
2305 :    
2306 :    
2307 :     #-------------------------------------------------------------------------
2308 :     # fill_overbeek_parents
2309 :     #-------------------------------------------------------------------------
2310 :    
2311 :     sub fill_overbeek_parents {
2312 :     my ( $ro_node, $parent ) = @_;
2313 :     ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;
2314 :    
2315 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = 0 );
2316 :    
2317 :     my $desc_list = $ro_node->[2];
2318 :     if ( ! $desc_list ) {
2319 :     $ro_node->[2] = [ $parent ];
2320 :     }
2321 :     else {
2322 :     ( ref( $desc_list ) eq "ARRAY" ) || return undef;
2323 :     $desc_list->[0] = $parent;
2324 :    
2325 :     # Work through the rest of the descendent list:
2326 :    
2327 :     my $last_index = @$desc_list - 1;
2328 :     foreach ( @$desc_list[ 1 .. $last_index ] ) {
2329 :     fill_overbeek_parents( $_, $ro_node ) || return undef;
2330 :     }
2331 :     }
2332 :    
2333 :     $ro_node;
2334 :     }
2335 :    
2336 :    
2337 :     #=========================================================================
2338 :     # Interconverting Newick tree and FIG_tree:
2339 :     #=========================================================================
2340 :     # newick_to_FIGtree
2341 :     #-------------------------------------------------------------------------
2342 :    
2343 :     sub newick_to_FIGtree {
2344 :     my ( $newick_node, $parent ) = @_;
2345 :     ( ref( $newick_node ) eq "ARRAY" ) && ( @$newick_node ) || return undef;
2346 :    
2347 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
2348 :    
2349 :     my ( $desc_list, $label, $X, $c1, $c2, $c3, $c4, $c5 ) = @$newick_node;
2350 :    
2351 :     # Put C1, C2 and C3 values in the node attribute list, with the key
2352 :     # "Newick_CN". Check C1 comments for "FIG_tree_node_attribute"
2353 :     # values. These are pulled out of the Newick comment and are made
2354 :     # into node key-value pairs.
2355 :    
2356 :     my $node_attrib = undef;
2357 :     if ( $c1 || $c2 || $c3 ) {
2358 :     $node_attrib = {};
2359 :     if ( $c1 ) {
2360 :     ( ref( $c1 ) eq "ARRAY" ) || return undef;
2361 :     my @c1b = ();
2362 :     foreach ( @$c1 ) {
2363 :     if ( ( ref( $_ ) eq "ARRAY" )
2364 :     && ( $_->[0] eq "FIG_tree_node_attribute" )
2365 :     ) {
2366 :     $node_attrib->{ $_->[1] } = $_->[2];
2367 :     }
2368 :     else {
2369 :     push @c1b, $_;
2370 :     }
2371 :     }
2372 :     if ( @c1b ) {
2373 :     $node_attrib->{ "Newick_C1" } = ( @$c1 == @c1b ) ? $c1 : \@c1b;
2374 :     }
2375 :     }
2376 :     if ( $c2 ) { $node_attrib->{ "Newick_C2" } = $c2 }
2377 :     if ( $c3 ) { $node_attrib->{ "Newick_C3" } = $c3 }
2378 :     }
2379 :    
2380 :     # Put C4 and C5 values in the branch attribute list, with the key
2381 :     # "Newick_CN". Check C4 comments for "FIG_tree_branch_attribute"
2382 :     # values. These are pulled out of the Newick comment and are made
2383 :     # into branch key-value pairs.
2384 :    
2385 :     my $branch_attrib = undef;
2386 :     if ( $c4 || $c5 ) {
2387 :     $branch_attrib = {};
2388 :     if ( $c4 ) {
2389 :     ( ref( $c4 ) eq "ARRAY" ) || return undef;
2390 :     my @c4b = ();
2391 :     foreach ( @$c4 ) {
2392 :     if ( ( ref( $_ ) eq "ARRAY" )
2393 :     && ( $_->[0] eq "FIG_tree_branch_attribute" )
2394 :     ) {
2395 :     $branch_attrib->{ $_->[1] } = $_->[2];
2396 :     }
2397 :     else {
2398 :     push @c4b, $_;
2399 :     }
2400 :     }
2401 :     if ( @c4b ) {
2402 :     $branch_attrib->{ "Newick_C4" } = ( @$c4 == @c4b ) ? $c4 : \@c4b;
2403 :     }
2404 :     }
2405 :     if ( $c5 ) { $branch_attrib->{ "Newick_C5" } = $c5 }
2406 :     }
2407 :    
2408 :     # We need a FIG node reference before we can create the children
2409 :    
2410 :     my $FIG_node = [ $label,
2411 :     $X,
2412 :     $parent,
2413 :     undef,
2414 :     ( $node_attrib || $branch_attrib ? $node_attrib : () ),
2415 :     ( $branch_attrib ? $branch_attrib : () )
2416 :     ];
2417 :    
2418 :     # Make the descendent list and check that all the children are defined:
2419 :    
2420 :     if ( $desc_list ) {
2421 :     ( ref( $desc_list ) eq "ARRAY" ) || return undef;
2422 :     if ( @$desc_list ) {
2423 :     my $FIG_desc_ref = [ map { newick_to_FIGtree( $_, $FIG_node ) }
2424 :     @$desc_list
2425 :     ];
2426 :     foreach ( @$FIG_desc_ref ) { ( ref( $_ ) eq "ARRAY" ) || return undef }
2427 :     $FIG_node->[3] = $FIG_desc_ref;
2428 :     }
2429 :     }
2430 :    
2431 :     $FIG_node;
2432 :     }
2433 :    
2434 :    
2435 :     #-------------------------------------------------------------------------
2436 :     # FIGtree_to_newick
2437 :     #-------------------------------------------------------------------------
2438 :    
2439 :     sub FIGtree_to_newick {
2440 :     my ( $FIG_node ) = @_;
2441 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
2442 :    
2443 :     my ( $label, $X, undef, $FIG_desc_list, $node_attrib, $branch_attrib ) = @$FIG_node;
2444 :     ( ! $FIG_desc_list ) || ( ref( $FIG_desc_list ) eq "ARRAY" ) || return undef;
2445 :    
2446 :     my ( $c1, $c2, $c3, $c4, $c5 );
2447 :     if ( ref( $node_attrib ) eq "HASH" ) {
2448 :     if ( $node_attrib->{ "Newick_C1" } ) {
2449 :     $c1 = $node_attrib->{ "Newick_C1" };
2450 :     ! defined( $c1 ) || ( ref( $c1 ) eq "ARRAY" ) || ( $c1 = [ $c1 ] );
2451 :     }
2452 :     if ( $node_attrib->{ "Newick_C2" } ) {
2453 :     $c2 = $node_attrib->{ "Newick_C2" };
2454 :     ! defined( $c2 ) || ( ref( $c2 ) eq "ARRAY" ) || ( $c2 = [ $c2 ] );
2455 :     }
2456 :     if ( $node_attrib->{ "Newick_C3" } ) {
2457 :     $c3 = $node_attrib->{ "Newick_C3" };
2458 :     ! defined( $c3 ) || ( ref( $c3 ) eq "ARRAY" ) || ( $c3 = [ $c3 ] );
2459 :     }
2460 :     if ( $node_attrib->{ "Newick_C4" } ) {
2461 :     $c4 = $node_attrib->{ "Newick_C4" };
2462 :     ! defined( $c4 ) || ( ref( $c4 ) eq "ARRAY" ) || ( $c4 = [ $c4 ] );
2463 :     }
2464 :     if ( $node_attrib->{ "Newick_C5" } ) {
2465 :     $c5 = $node_attrib->{ "Newick_C5" };
2466 :     ! defined( $c5 ) || ( ref( $c5 ) eq "ARRAY" ) || ( $c5 = [ $c5 ] );
2467 :     }
2468 :    
2469 :     # Any node attributes that are not newick comments, will get
2470 :     # pushed on C1 as 3-element lists with first element eq
2471 :     # "FIG_tree_node_attribute"
2472 :    
2473 :     my @keys = map { /^Newick_C[1-5]$/ ? () : $_ } keys %$node_attrib;
2474 :     if ( @keys ) {
2475 :     my @c1b = $c1 ? @$c1 : ();
2476 :     push @c1b, map { [ "FIG_tree_node_attribute", $_, $node_attrib->{ $_ } ]
2477 :     } @keys;
2478 :     $c1 = \@c1b;
2479 :     }
2480 :     }
2481 :    
2482 :     if ( ref( $branch_attrib ) eq "HASH" ) {
2483 :     if ( $branch_attrib->{ "Newick_C4" } ) {
2484 :     $c4 = $branch_attrib->{ "Newick_C4" };
2485 :     ! defined( $c4 ) || ( ref( $c4 ) eq "ARRAY" ) || ( $c4 = [ $c4 ] );
2486 :     }
2487 :     if ( $branch_attrib->{ "Newick_C5" } ) {
2488 :     $c5 = $branch_attrib->{ "Newick_C5" };
2489 :     ! defined( $c5 ) || ( ref( $c5 ) eq "ARRAY" ) || ( $c5 = [ $c5 ] );
2490 :     }
2491 :    
2492 :     # Any branch attributes that are not newick comments, will get
2493 :     # pushed on C4 as 3-element lists with first element eq
2494 :     # "FIG_tree_branch_attribute"
2495 :    
2496 :     my @keys = map { /^Newick_C[45]$/ ? () : $_ } keys %$branch_attrib;
2497 :     if ( @keys ) {
2498 :     my @c4b = $c4 ? @$c4 : ();
2499 :     push @c4b, map { [ "FIG_tree_branch_attribute", $_, $branch_attrib->{ $_ } ]
2500 :     } @keys;
2501 :     $c4 = \@c4b;
2502 :     }
2503 :     }
2504 :    
2505 :     my $desc_ref = undef;
2506 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
2507 :     $desc_ref = [ map { FIGtree_to_newick( $_ ) } @$FIG_desc_list ];
2508 :     foreach ( @$desc_ref ) { array_ref( $_ ) || return undef }
2509 :     }
2510 :    
2511 :     [ $desc_ref, $label, $X, $c5 ? ( $c1, $c2, $c3, $c4, $c5 )
2512 :     : $c4 ? ( $c1, $c2, $c3, $c4 )
2513 :     : $c3 ? ( $c1, $c2, $c3 )
2514 :     : $c2 ? ( $c1, $c2 )
2515 :     : $c1 ? ( $c1 )
2516 :     : ()
2517 :     ];
2518 :     }
2519 :    
2520 :    
2521 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3