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

Annotation of /FigKernelPackages/FIGtree.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3