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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : golsen 1.1 package gjonewicklib;
2 :    
3 :     #===============================================================================
4 :     # perl functions for dealing with trees
5 :     #
6 :     # Usage:
7 :     # use gjonewicklib
8 :     #
9 :     #
10 :     #===============================================================================
11 :     # Tree data structures:
12 :     #===============================================================================
13 :     #
14 :     # Elements in newick text file are:
15 :     #
16 :     # [c1] ( desc_1, desc_2, ... ) [c2] label [c3] : [c4] x [c5]
17 :     #
18 :     # Note that:
19 :     #
20 :     # Comment list 1 can exist on any subtree, but its association with
21 :     # tree components can be upset by rerooting
22 :     # Comment list 2 cannot exist without a descendant list
23 :     # Comment list 3 cannot exist without a label
24 :     # Comment lists 4 and 5 cannot exist without a branch length
25 :     #
26 :     # Elements in perl representation are:
27 :     #
28 :     # $tree = \@rootnode;
29 :     #
30 :     # @node = ( \@desc, # reference to list of descendants
31 :     # $label, # node label
32 :     # $x, # branch length
33 :     # \@c1, # reference to comment list 1
34 :     # \@c2, # reference to comment list 2
35 :     # \@c3, # reference to comment list 3
36 :     # \@c4, # reference to comment list 4
37 :     # \@c5 # reference to comment list 5
38 :     # )
39 :     #
40 :     # At present, no routine tests or enforces the length of the list (a single
41 :     # element list could be a valid internal node).
42 :     #
43 :     # All empty lists can be [] or undef
44 :     #
45 :     # Putting the comments at the end allows a shorter list nearly all the
46 :     # time, but is different from the prolog representation.
47 :     #
48 :     #
49 :     #===============================================================================
50 :     # Tree data extraction:
51 :     #===============================================================================
52 :     #
53 :     # $listref = newick_desc_ref( $noderef )
54 :     # $label = newick_lbl( $noderef )
55 :     # $x = newick_x( $noderef )
56 :     # $listref = newick_c1( $noderef )
57 :     # $listref = newick_c2( $noderef )
58 :     # $listref = newick_c3( $noderef )
59 :     # $listref = newick_c4( $noderef )
60 :     # $listref = newick_c5( $noderef )
61 :     #
62 :     # @desclist = newick_desc_list( $noderef )
63 :     # $n = newick_n_desc( $noderef )
64 :     # $descref = newick_desc_i( $noderef, $i ) # 1-based numbering
65 :     # $bool = newick_is_tip( $noderef )
66 :     #
67 :     # set_newick_desc_ref( $noderef, $listref )
68 :     # set_newick_lbl( $noderef, $label )
69 :     # set_newick_x( $noderef, $x )
70 :     # set_newick_c1( $noderef, $listref )
71 :     # set_newick_c2( $noderef, $listref )
72 :     # set_newick_c3( $noderef, $listref )
73 :     # set_newick_c4( $noderef, $listref )
74 :     # set_newick_c5( $noderef, $listref )
75 :     # set_newick_desc_list( $noderef, @desclist )
76 :     # set_newick_desc_i( $noderef1, $i, $noderef2)
77 :     #
78 :     # $bool = newick_is_rooted( $noderef ) # 2 branches from root
79 :     # $bool = newick_is_unrooted( $noderef ) # 3 or more branches from root
80 :     # $bool = newick_is_tip_rooted( $noderef ) # 1 branch from root
81 :     # $bool = newick_is_bifurcating( $noderef )
82 :     #
83 :     # $n = newick_tip_count( $noderef )
84 :     # @tiprefs = newick_tip_ref_list( $noderef )
85 :     # @tips = newick_tip_list( $noderef )
86 :     # $tipref = newick_first_tip_ref( $noderef )
87 :     # $tip = newick_first_tip( $noderef )
88 :     # @tips = newick_duplicated_tips( $noderef )
89 :     # $bool = newick_tip_in_tree( $noderef, $tipname )
90 :     # @tips = newick_shared_tips( $tree1, $tree2 )
91 :     #
92 :     # $length = newick_tree_length( $noderef )
93 :     # $xmax = newick_max_X( $noderef )
94 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $noderef )
95 :     # ( $tipname, $xmax ) = newick_most_distant_tip( $noderef )
96 :     #
97 :     #-------------------------------------------------------------------------------
98 :     # Paths from root of tree:
99 :     #-------------------------------------------------------------------------------
100 :     #
101 :     # Path descriptions are of form:
102 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN )
103 :     # () is returned upon failure
104 :     #
105 :     # @path = path_to_tip( $treenode, $tipname )
106 :     # @path = path_to_named_node( $treenode, $nodename )
107 :     # @path = path_to_node_ref( $treenode, $noderef )
108 :     #
109 :     # @path = path_to_node( $node, $tip1, $tip2, $tip3 ) # 3 tip names
110 :     # @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] ) # Array of tips
111 :     # @path = path_to_node( $node, $tip1 ) # Use path_to_tip
112 :     # @path = path_to_node( $node, [ $tip1 ] ) # Use path_to_tip
113 :     #
114 :     # $distance = newick_path_length( @path )
115 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
116 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
117 :     #
118 :     #
119 :     #===============================================================================
120 :     # Tree manipulations:
121 :     #===============================================================================
122 :     #
123 :     # $treecopy = copy__newick_tree( $tree )
124 :     #
125 :     #-------------------------------------------------------------------------------
126 :     # The following modify the existing tree, and passibly any components of that
127 :     # tree that are reached by reference. If the old version is still needed, copy
128 :     # before modifying.
129 :     #-------------------------------------------------------------------------------
130 :     #
131 :     # Modify labels:
132 :     #
133 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
134 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
135 :     # $newtree = newick_relabel_tips( $node, \%new_name )
136 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
137 :     #
138 :     # Modify branches:
139 :     #
140 :     # $n_changed = newick_set_undefined_branches( $node, $x )
141 :     # $n_changed = newick_set_all_branches( $node, $x )
142 :     #
143 :     # Modify rooting and/or order:
144 :     #
145 :     # $nrmtree = normalize_newick_tree( $tree )
146 :     # $revtree = reverse_newick_tree( $tree )
147 :     # $stdtree = std_unrooted_newick( $tree )
148 :     # $newtree = aesthetic_newick_tree( $tree, $direction )
149 :     # $rndtree = random_order_newick_tree( $tree )
150 :     # $newtree = reroot_newick_by_path( @path )
151 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
152 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
153 :     # $newtree = reroot_newick_to_node( $tree, @node )
154 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
155 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
156 :     # $newtree = uproot_tip_rooted_newick( $tree )
157 :     # $newtree = uproot_newick( $tree )
158 :     #
159 :     # $newtree = prune_from_newick( $tree, $tip )
160 :     # $newtree = newick_subtree( $tree, @tips )
161 :     # $newtree = newick_subtree( $tree, \@tips )
162 :     #
163 :     #===============================================================================
164 :     # Tree reading and writing:
165 :     #===============================================================================
166 :     #
167 :     # writeNewickTree( $tree )
168 :     # writeNewickTree( $tree, $file )
169 :     # writePrettyTree( $tree, $file )
170 :     # fwriteNewickTree( $file, $tree )
171 :     # $treestring = swriteNewickTree( $tree )
172 :     # $treestring = formatNewickTree( $tree )
173 :     # @textlines = text_plot_newick( $node, $width, $min_dx, $dy )
174 :     # printer_plot_newick( $node, $file, $width, $min_dx, $dy )
175 :     #
176 :     # $tree = parse_newick_tree_str( $string )
177 :     #
178 :     #===============================================================================
179 :    
180 :    
181 :     require Exporter;
182 :    
183 :     our @ISA = qw(Exporter);
184 :     our @EXPORT = qw(
185 :     newick_is_rooted
186 :     newick_is_unrooted
187 :     tree_rooted_on_tip
188 :     newick_is_bifurcating
189 :     newick_tip_count
190 :     newick_tip_list
191 :     newick_first_tip
192 :     newick_duplicated_tips
193 :     newick_tip_in_tree
194 :     newick_shared_tips
195 :    
196 :     newick_tree_length
197 :     newick_max_X
198 :     newick_most_distant_tip_ref
199 :     newick_most_distant_tip_name
200 :    
201 :     std_newick_name
202 :    
203 :     path_to_tip
204 :     path_to_named_node
205 :     path_to_node_ref
206 :     path_to_node
207 :    
208 :     newick_path_length
209 :     tip_to_tip_distance
210 :     node_to_node_distance
211 :    
212 :     copy__newick_tree
213 :    
214 :     newick_relabel_nodes
215 :     newick_relabel_nodes_i
216 :     newick_relabel_tips
217 :     newick_relabel_tips_i
218 :    
219 :     newick_set_undefined_branches
220 :     newick_set_all_branches
221 :    
222 :     normalize_newick_tree
223 :     reverse_newick_tree
224 :     std_unrooted_newick
225 :     aesthetic_newick_tree
226 :     unaesthetic_newick_tree
227 :     random_order_newick_tree
228 :    
229 :     reroot_newick_by_path
230 :     reroot_newick_to_tip
231 :     reroot_newick_next_to_tip
232 :     reroot_newick_to_node
233 :     reroot_newick_to_node_ref
234 :     reroot_newick_to_approx_midpoint
235 :     uproot_tip_rooted_newick
236 :     uproot_newick
237 :    
238 :     prune_from_newick
239 :     newick_subtree
240 :    
241 :     writeNewickTree
242 :     fwriteNewickTree
243 :     strNewickTree
244 :     formatNewickTree
245 :     parse_newick_tree_str
246 :    
247 :     printer_plot_newick
248 :     text_plot_newick
249 :     );
250 :    
251 :     our @EXPORT_OK = qw(
252 :     newick_desc_ref
253 :     newick_lbl
254 :     newick_x
255 :     newick_c1
256 :     newick_c2
257 :     newick_c3
258 :     newick_c4
259 :     newick_c5
260 :     newick_desc_list
261 :     newick_n_desc
262 :     newick_desc_i
263 :     newick_is_tip
264 :     newick_is_valid
265 :    
266 :     set_newick_desc_ref
267 :     set_newick_lbl
268 :     set_newick_x
269 :     set_newick_c1
270 :     set_newick_c2
271 :     set_newick_c3
272 :     set_newick_c4
273 :     set_newick_c5
274 :    
275 :     set_newick_desc_list
276 :     set_newick_desc_i
277 :    
278 :     add_to_newick_branch
279 :     dump_tree
280 :     );
281 :    
282 :    
283 :     use gjolists qw(
284 :     common_prefix
285 :     common_and_unique
286 :     unique_suffixes
287 :    
288 :     unique_set
289 :     duplicates
290 :     random_order
291 :    
292 :     union
293 :     intersection
294 :     set_difference
295 :     );
296 :    
297 :    
298 :     use strict;
299 :    
300 :    
301 :     #-------------------------------------------------------------------------------
302 :     # Internally used definitions
303 :     #-------------------------------------------------------------------------------
304 :    
305 :     sub array_ref { ref( $_[0] ) eq "ARRAY" }
306 :     sub hash_ref { ref( $_[0] ) eq "HASH" }
307 :    
308 :    
309 :     #===============================================================================
310 :     # Extract tree structure values:
311 :     #===============================================================================
312 :     #
313 :     # $listref = newick_desc_ref( $noderef )
314 :     # $string = newick_lbl( $noderef )
315 :     # $real = newick_x( $noderef )
316 :     # $listref = newick_c1( $noderef )
317 :     # $listref = newick_c2( $noderef )
318 :     # $listref = newick_c3( $noderef )
319 :     # $listref = newick_c4( $noderef )
320 :     # $listref = newick_c5( $noderef )
321 :     # @list = newick_desc_list( $noderef )
322 :     # $int = newick_n_desc( $noderef )
323 :     # $listref = newick_desc_i( $noderef )
324 :     # $bool = node_is_tip( $noderef )
325 :     # $bool = node_is_valid( $noderef )
326 :     #
327 :     #-------------------------------------------------------------------------------
328 :    
329 :     sub newick_desc_ref { $_[0]->[0] } # = ${$_[0]}[0]
330 :     sub newick_lbl { $_[0]->[1] }
331 :     sub newick_x { $_[0]->[2] }
332 :     sub newick_c1 { $_[0]->[3] }
333 :     sub newick_c2 { $_[0]->[4] }
334 :     sub newick_c3 { $_[0]->[5] }
335 :     sub newick_c4 { $_[0]->[6] }
336 :     sub newick_c5 { $_[0]->[7] }
337 :    
338 :     sub newick_desc_list {
339 :     my $node = $_[0];
340 :     ! array_ref( $node ) ? undef :
341 :     array_ref( $node->[0] ) ? @{ $node->[0] } :
342 :     () ;
343 :     }
344 :    
345 :     sub newick_n_desc {
346 :     my $node = $_[0];
347 :     ! array_ref( $node ) ? undef :
348 :     array_ref( $node->[0] ) ? scalar @{ $node->[0] } :
349 :     0 ;
350 :     }
351 :    
352 :     sub newick_desc_i {
353 :     my ( $node, $i ) = @_;
354 :     ! array_ref( $node ) ? undef :
355 :     array_ref( $node->[0] ) ? $node->[0]->[$i-1] :
356 :     undef ;
357 :     }
358 :    
359 :     sub node_is_tip {
360 :     my $node = $_[0];
361 :     ! array_ref( $node ) ? undef : # Not a node ref
362 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 0 : # Empty descend list?
363 :     1 ; # No descend list
364 :     }
365 :    
366 :     sub node_is_valid { # An array ref with nonempty descend list or a label
367 :     my $node = $_[0];
368 :     array_ref( $node ) && ( array_ref( $node->[0] ) && @{ $node->[0] }
369 :     || defined( $node->[1] )
370 :     )
371 :     }
372 :    
373 :    
374 :     #-------------------------------------------------------------------------------
375 :     # Set tree structure values
376 :     #-------------------------------------------------------------------------------
377 :    
378 :     sub set_newick_desc_ref { $_[0]->[0] = $_[1] }
379 :     sub set_newick_lbl { $_[0]->[1] = $_[1] }
380 :     sub set_newick_x { $_[0]->[2] = $_[1] }
381 :     sub set_newick_c1 { $_[0]->[3] = $_[1] }
382 :     sub set_newick_c2 { $_[0]->[4] = $_[1] }
383 :     sub set_newick_c3 { $_[0]->[5] = $_[1] }
384 :     sub set_newick_c4 { $_[0]->[6] = $_[1] }
385 :     sub set_newick_c5 { $_[0]->[7] = $_[1] }
386 :    
387 :     sub set_newick_desc_list {
388 :     my $node = shift;
389 :     array_ref( $node ) || return;
390 :     if ( array_ref( $node->[0] ) ) { @{ $node->[0] } = @_ }
391 :     else { $node->[0] = [ @_ ] }
392 :     }
393 :    
394 :     sub set_newick_desc_i {
395 :     my ( $node1, $i, $node2 ) = @_;
396 :     array_ref( $node1 ) && array_ref( $node2 ) || return;
397 :     if ( array_ref( $node1->[0] ) ) { $node1->[0]->[$i-1] = $node2 }
398 :     else { $node1->[0] = [ $node2 ] }
399 :     }
400 :    
401 :    
402 :     #===============================================================================
403 :     # Some tree property tests:
404 :     #===============================================================================
405 :     # Tree is rooted (2 branches at root node)?
406 :     #
407 :     # $bool = newick_is_rooted( $node )
408 :     #-------------------------------------------------------------------------------
409 :     sub newick_is_rooted {
410 :     my $node = $_[0];
411 :     ! array_ref( $node ) ? undef : # Not a node ref
412 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 2 : # 2 branches
413 :     0 ; # No descend list
414 :     }
415 :    
416 :    
417 :     #-------------------------------------------------------------------------------
418 :     # Tree is unrooted (> 2 branches at root node)?
419 :     #
420 :     # $bool = newick_is_unrooted( $node )
421 :     #-------------------------------------------------------------------------------
422 :     sub newick_is_unrooted {
423 :     my $node = $_[0];
424 :     ! array_ref( $node ) ? undef : # Not a node ref
425 :     array_ref( $node->[0] ) ? @{ $node->[0] } >= 3 : # Over 2 branches
426 :     0 ; # No descend list
427 :     }
428 :    
429 :    
430 :     #-------------------------------------------------------------------------------
431 :     # Tree is rooted on a tip (1 branch at root node)?
432 :     #
433 :     # $bool = newick_is_tip_rooted( $node )
434 :     #-------------------------------------------------------------------------------
435 :     sub newick_is_tip_rooted {
436 :     my $node = $_[0];
437 :     ! array_ref( $node ) ? undef : # Not a node ref
438 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 1 : # 1 branch
439 :     0 ; # No descend list
440 :     }
441 :    
442 :     #===============================================================================
443 :     # Everything below this point refers to parts of the tree structure using
444 :     # only the routines above.
445 :     #===============================================================================
446 :     # Tree is bifurcating? If so, return number of descendents of root node.
447 :     #
448 :     # $n_desc = newick_is_bifurcating( $node )
449 :     #-------------------------------------------------------------------------------
450 :     sub newick_is_bifurcating {
451 :     my ( $node, $not_root ) = @_;
452 :     if ( ! array_ref( $node ) ) { return undef } # Bad arg
453 :    
454 :     my $n = newick_n_desc( $node );
455 :     $n == 0 && ! $not_root ? 0 :
456 :     $n == 1 && $not_root ? 0 :
457 :     $n == 3 && $not_root ? 0 :
458 :     $n > 3 ? 0 :
459 :     $n > 2 && ! newick_is_bifurcating( newick_desc_i( $node, 3, 1 ) ) ? 0 :
460 :     $n > 1 && ! newick_is_bifurcating( newick_desc_i( $node, 2, 1 ) ) ? 0 :
461 :     $n > 0 && ! newick_is_bifurcating( newick_desc_i( $node, 1, 1 ) ) ? 0 :
462 :     $n
463 :     }
464 :    
465 :    
466 :     #-------------------------------------------------------------------------------
467 :     # Number of tips:
468 :     #
469 :     # $n = newick_tip_count( $node )
470 :     #-------------------------------------------------------------------------------
471 :     sub newick_tip_count {
472 :     my ( $node, $not_root ) = @_;
473 :    
474 :     my $imax = newick_n_desc( $node );
475 :     if ( $imax < 1 ) { return 1 }
476 :    
477 :     # Special case for tree rooted on tip
478 :    
479 :     my $n = ( $imax == 1 && ( ! $not_root ) ) ? 1 : 0;
480 :    
481 :     foreach ( newick_desc_list( $node ) ) { $n += newick_tip_count( $_, 1 ) }
482 :    
483 :     $n;
484 :     }
485 :    
486 :    
487 :     #-------------------------------------------------------------------------------
488 :     # List of tip nodes:
489 :     #
490 :     # @tips = newick_tip_ref_list( $node )
491 :     #-------------------------------------------------------------------------------
492 :     sub newick_tip_ref_list {
493 :     my ( $node, $not_root ) = @_;
494 :    
495 :     my $imax = newick_n_desc( $node );
496 :     if ( $imax < 1 ) { return $node }
497 :    
498 :     my @list = ();
499 :    
500 :     # Tree rooted on tip?
501 :     if ( $imax == 1 && ! $not_root && newick_lbl( $node ) ) { push @list, $node }
502 :    
503 :     foreach ( newick_desc_list( $node ) ) {
504 :     push @list, newick_tip_ref_list( $_, 1 );
505 :     }
506 :    
507 :     @list;
508 :     }
509 :    
510 :    
511 :     #-------------------------------------------------------------------------------
512 :     # List of tips:
513 :     #
514 :     # @tips = newick_tip_list( $node )
515 :     #-------------------------------------------------------------------------------
516 :     sub newick_tip_list {
517 :     map { newick_lbl( $_ ) } newick_tip_ref_list( $_[0] );
518 :     }
519 :    
520 :    
521 :     #-------------------------------------------------------------------------------
522 :     # First tip node in tree:
523 :     #
524 :     # $tipref = newick_first_tip_ref( $node )
525 :     #-------------------------------------------------------------------------------
526 :     sub newick_first_tip_ref {
527 :     my ( $node, $not_root ) = @_;
528 :     valid_node( $node ) || return undef;
529 :    
530 :     # Arrived at tip, or start of a tip-rooted tree?
531 :     my $n = newick_n_desc( $node );
532 :     if ( ( $n < 1 ) || ( $n == 1 && ! $not_root ) ) { return $node }
533 :    
534 :     newick_first_tip_ref( newick_desc_i( $node, 1 ), 1 );
535 :     }
536 :    
537 :    
538 :     #-------------------------------------------------------------------------------
539 :     # First tip name in tree:
540 :     #
541 :     # $tip = newick_first_tip( $node )
542 :     #-------------------------------------------------------------------------------
543 :     sub newick_first_tip {
544 :     my ( $noderef ) = @_;
545 :    
546 :     my $tipref;
547 :     array_ref( $tipref = newick_first_tip_ref( $noderef ) ) ? newick_lbl( $tipref )
548 :     : undef;
549 :     }
550 :    
551 :    
552 :     #-------------------------------------------------------------------------------
553 :     # List of duplicated tip labels.
554 :     #
555 :     # @tips = newick_duplicated_tips( $node )
556 :     #-------------------------------------------------------------------------------
557 :     sub newick_duplicated_tips {
558 :     duplicates( newick_tip_list( $_[0] ) );
559 :     }
560 :    
561 :    
562 :     #-------------------------------------------------------------------------------
563 :     # Tip in tree?
564 :     #
565 :     # $bool = newick_tip_in_tree( $node, $tipname )
566 :     #-------------------------------------------------------------------------------
567 :     sub newick_tip_in_tree {
568 :     my ( $node, $tip, $not_root ) = @_;
569 :    
570 :     my $n = newick_n_desc( $node );
571 :     if ( $n < 1 ) { return ( newick_lbl( $node ) eq $tip) ? 1 : 0 }
572 :    
573 :     # Special case for tree rooted on tip
574 :    
575 :     if ( $n == 1 && ( ! $not_root ) && newick_lbl( $node ) eq $tip ) { return 1 }
576 :    
577 :     foreach ( newick_desc_list( $node ) ) {
578 :     if ( newick_tip_in_tree( $_, $tip, 1 ) ) { return 1 }
579 :     }
580 :    
581 :     0; # Fall through means not found
582 :     }
583 :    
584 :    
585 :     #-------------------------------------------------------------------------------
586 :     # Tips shared between 2 trees.
587 :     #
588 :     # @tips = newick_shared_tips( $tree1, $tree2 )
589 :     #-------------------------------------------------------------------------------
590 :     sub newick_shared_tips {
591 :     my ( $Tree1, $Tree2 ) = @_;
592 :     my ( @Tips1 ) = newick_tip_list( $Tree1 );
593 :     my ( @Tips2 ) = newick_tip_list( $Tree2 );
594 :     intersection( \@Tips1, \@Tips2 );
595 :     }
596 :    
597 :    
598 :     #-------------------------------------------------------------------------------
599 :     # Tree length.
600 :     #
601 :     # $length = newick_tree_length( $node )
602 :     #-------------------------------------------------------------------------------
603 :     sub newick_tree_length {
604 :     my ( $node, $not_root ) = @_;
605 :    
606 :     my $x = $not_root ? newick_x( $node ) : 0;
607 :     defined( $x ) || ( $x = 1 ); # Convert undefined to 1
608 :    
609 :     foreach ( newick_desc_list( $node ) ) { $x += newick_tree_length( $_, 1 ) }
610 :    
611 :     $x;
612 :     }
613 :    
614 :    
615 :     #-------------------------------------------------------------------------------
616 :     # Tree max X.
617 :     #
618 :     # $xmax = newick_max_X( $node )
619 :     #-------------------------------------------------------------------------------
620 :     sub newick_max_X {
621 :     my ( $node, $not_root ) = @_;
622 :    
623 :     my $xmax = 0;
624 :     foreach ( newick_desc_list( $node ) ) {
625 :     my $x = newick_max_X( $_, 1 );
626 :     if ( $x > $xmax ) { $xmax = $x }
627 :     }
628 :    
629 :     my $x = $not_root ? newick_x( $node ) : 0;
630 :     $xmax + ( defined( $x ) ? $x : 1 ); # Convert undefined to 1
631 :     }
632 :    
633 :    
634 :     #-------------------------------------------------------------------------------
635 :     # Most distant tip from root: distance and path.
636 :     #
637 :     # ( $xmax, @path ) = newick_most_distant_tip_path( $tree )
638 :     #-------------------------------------------------------------------------------
639 :     sub newick_most_distant_tip_path {
640 :     my ( $node, $not_root ) = @_;
641 :    
642 :     my $imax = newick_n_desc( $node );
643 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
644 :     my @pmax = ();
645 :     for ( my $i = 1; $i <= $imax; $i++ ) {
646 :     my ( $x, @path ) = newick_most_distant_tip_path( newick_desc_i( $node, $i ), 1 );
647 :     if ( $x > $xmax ) { $xmax = $x; @pmax = ( $i, @path ) }
648 :     }
649 :    
650 :     my $x = $not_root ? newick_x( $node ) : 0;
651 :     $xmax += defined( $x ) ? $x : 0; # Convert undefined to 1
652 :     ( $xmax, $node, @pmax );
653 :     }
654 :    
655 :    
656 :     #-------------------------------------------------------------------------------
657 :     # Most distant tip from root, and its distance.
658 :     #
659 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $tree )
660 :     #-------------------------------------------------------------------------------
661 :     sub newick_most_distant_tip_ref {
662 :     my ( $node, $not_root ) = @_;
663 :    
664 :     my $imax = newick_n_desc( $node );
665 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
666 :     my $tmax = $node;
667 :     foreach ( newick_desc_list( $node ) ) {
668 :     my ( $t, $x ) = newick_most_distant_tip_ref( $_, 1 );
669 :     if ( $x > $xmax ) { $xmax = $x; $tmax = $t }
670 :     }
671 :    
672 :     my $x = $not_root ? newick_x( $node ) : 0;
673 :     $xmax += defined( $x ) ? $x : 1; # Convert undefined to 1
674 :     ( $tmax, $xmax );
675 :     }
676 :    
677 :    
678 :     #-------------------------------------------------------------------------------
679 :     # Name of most distant tip from root, and its distance.
680 :     #
681 :     # ( $tipname, $xmax ) = newick_most_distant_tip_name( $tree )
682 :     #-------------------------------------------------------------------------------
683 :     sub newick_most_distant_tip_name {
684 :     my ( $tipref, $xmax ) = newick_most_distant_tip_ref( $_[0] );
685 :     ( newick_lbl( $tipref ), $xmax )
686 :     }
687 :    
688 :    
689 :     #-------------------------------------------------------------------------------
690 :     # Standard node name:
691 :     # Tip label if at a tip
692 :     # Three sorted tip labels intersecting at node, each being smallest
693 :     # of all the tips of their subtrees
694 :     #
695 :     # @TipOrTips = std_node_name( $Tree, $Node )
696 :     #-------------------------------------------------------------------------------
697 :     sub std_node_name {
698 :     my $tree = $_[0];
699 :    
700 :     # Node reference is last element of path to node
701 :    
702 :     my $noderef = ( path_to_node( @_ ) )[-1];
703 :     defined( $noderef ) || return ();
704 :    
705 :     if ( node_is_tip( $noderef ) || $noderef eq $tree ) { # Is it a tip?
706 :     return newick_lbl( $noderef );
707 :     }
708 :    
709 :     # Work through lists of tips in descendant subtrees, removing them from
710 :     # @rest, and keeping the best tip for each subtree.
711 :    
712 :     my @rest = tips_in_newick( $tree );
713 :     my @best = map {
714 :     my @tips = sort { lc $a cmp lc $b } tips_in_newick( $_ );
715 :     @rest = set_difference( \@rest, \@tips );
716 :     $tips[0];
717 :     } newick_desc_list( $noderef );
718 :    
719 :     # Best of the rest of the tree
720 :     push @best, ( sort { lc $a cmp lc $b } @rest )[0];
721 :    
722 :     # Take the top 3, in order:
723 :    
724 :     ( @best >= 3 ) ? ( sort { lc $a cmp lc $b } @best )[0 .. 2] : ();
725 :     }
726 :    
727 :    
728 :     #===============================================================================
729 :     # Functions to find paths in trees.
730 :     #
731 :     # Path descriptions are of form:
732 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN ) # Always odd
733 :     # () is returned upon failure
734 :     #
735 :     # Numbering of descendants is 1-based.
736 :     #===============================================================================
737 :     # Path to tip:
738 :     #
739 :     # @path = path_to_tip( $treenode, $tipname )
740 :     #-------------------------------------------------------------------------------
741 :     sub path_to_tip {
742 :     my ( $node, $tip, @path0 ) = @_;
743 :    
744 :     push @path0, $node;
745 :     my $imax = newick_n_desc( $node );
746 :     if ( $imax < 1 ) { return ( newick_lbl( $node ) eq $tip ) ? @path0 : () }
747 :    
748 :     # Special case for tree rooted on tip
749 :    
750 :     if ( ( $imax == 1 ) # One descendant
751 :     && ( @path0 == 1 ) # First step in path
752 :     && ( newick_lbl( $node ) eq $tip ) # Label matches
753 :     ) { return @path0 }
754 :    
755 :     my @path;
756 :     for (my $i = 1; $i <= $imax; $i++ ) {
757 :     @path = path_to_tip( newick_desc_i( $node, $i ), $tip, ( @path0, $i ) );
758 :     if ( @path ) { return @path }
759 :     }
760 :    
761 :     (); # Not found
762 :     }
763 :    
764 :    
765 :     #-------------------------------------------------------------------------------
766 :     # Path to named node.
767 :     # Like path to tip, but will find named internal nodes as well.
768 :     #
769 :     # @path = path_to_named_node( $treenode, $name )
770 :     #-------------------------------------------------------------------------------
771 :     sub path_to_named_node {
772 :     my ( $node, $name, @path0 ) = @_;
773 :    
774 :     push @path0, $node;
775 :     if ( newick_lbl( $node ) eq $name ) { return @path0 }
776 :    
777 :     my @path;
778 :     my $imax = newick_n_desc( $node );
779 :     for ( my $i = 1; $i <= $imax; $i++ ) {
780 :     @path = path_to_named_node( newick_desc_i( $node, $i ), $name, ( @path0, $i ) );
781 :     if ( @path ) { return @path }
782 :     }
783 :    
784 :     (); # Not found
785 :     }
786 :    
787 :    
788 :     #-------------------------------------------------------------------------------
789 :     # Path to node reference.
790 :     #
791 :     # @path = path_to_node_ref( $treenode, $noderef )
792 :     #-------------------------------------------------------------------------------
793 :     sub path_to_node_ref {
794 :     my ( $node, $noderef, @path0 ) = @_;
795 :    
796 :     push @path0, $node;
797 :     if ( $node eq $noderef ) { return @path0 }
798 :    
799 :     my @path;
800 :     my $imax = newick_n_desc( $node );
801 :     for ( my $i = 1; $i <= $imax; $i++ ) {
802 :     @path = path_to_node_ref( newick_desc_i( $node, $i ), $noderef, ( @path0, $i ) );
803 :     if ( @path ) { return @path }
804 :     }
805 :    
806 :     (); # Not found
807 :     }
808 :    
809 :    
810 :     #-------------------------------------------------------------------------------
811 :     # Path to node, as defined by 1 or 3 tips.
812 :     #
813 :     # @path = path_to_node( $node, $tip1, $tip2, $tip3 ) # 3 tip names
814 :     # @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] ) # Allow array ref
815 :     # @path = path_to_node( $node, $tip1 ) # Use path_to_tip
816 :     # @path = path_to_node( $node, [ $tip1 ] ) # Use path_to_tip
817 :     #-------------------------------------------------------------------------------
818 :     sub path_to_node {
819 :     my ( $node, $tip1, $tip2, $tip3 ) = @_;
820 :     array_ref( $node ) && defined( $tip1 ) || return ();
821 :    
822 :     # Allow arg 2 to be an array reference
823 :     if ( array_ref( $tip1 ) ) { ( $tip1, $tip2, $tip3 ) = @$tip1 }
824 :    
825 :     my @p1 = path_to_tip( $node, $tip1 ); # Path to first tip
826 :     @p1 || return (); # Was the tip found?
827 :     defined( $tip2 ) && defined( $tip3 ) || return @p1; # Two more defined?
828 :    
829 :     my @p2 = path_to_tip( $node, $tip2 );
830 :     my @p3 = path_to_tip( $node, $tip3 );
831 :     @p2 && @p3 || return (); # Were they found?
832 :    
833 :     # Find the common prefix for each pair of paths
834 :     my @p12 = common_prefix( \@p1, \@p2 );
835 :     my @p13 = common_prefix( \@p1, \@p3 );
836 :     my @p23 = common_prefix( \@p2, \@p3 );
837 :    
838 :     # Return the longest common prefix of any two paths
839 :     ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :
840 :     ( @p13 >= @p23 ) ? @p13 :
841 :     @p23 ;
842 :     }
843 :    
844 :    
845 :     #-------------------------------------------------------------------------------
846 :     # Distance along path.
847 :     #
848 :     # $distance = newick_path_length( @path )
849 :     #-------------------------------------------------------------------------------
850 :     sub newick_path_length {
851 :     my $node = shift; # Discard the first node
852 :     array_ref( $node ) || return undef;
853 :     @_ ? distance_along_path_2( @_ ) : 0;
854 :     }
855 :    
856 :    
857 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
858 :     # This expects to get path minus root node:
859 :     #
860 :     # $distance = distance_along_path_2( @path )
861 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
862 :     sub distance_along_path_2 {
863 :     shift; # Discard descendant number
864 :     my $node = shift;
865 :     array_ref( $node ) || return undef;
866 :     my $d1 = newick_x( $node );
867 :     my $d2 = @_ ? distance_along_path_2(@_) : 0;
868 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
869 :     }
870 :    
871 :    
872 :     #-------------------------------------------------------------------------------
873 :     # Tip-to-tip distance.
874 :     #
875 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
876 :     #-------------------------------------------------------------------------------
877 :     sub tip_to_tip_distance {
878 :     my ( $node, $tip1, $tip2 ) = @_;
879 :    
880 :     array_ref( $node ) && defined( $tip1 )
881 :     && defined( $tip2 ) || return undef;
882 :     my @p1 = path_to_tip( $node, $tip1 );
883 :     my @p2 = path_to_tip( $node, $tip2 );
884 :     @p1 && @p2 || return undef; # Were they found?
885 :    
886 :     # Find the unique suffixes of the two paths
887 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 ); # Common node is lost
888 :     my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
889 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
890 :    
891 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
892 :     }
893 :    
894 :    
895 :     #-------------------------------------------------------------------------------
896 :     # Node-to-node distance.
897 :     # Nodes can be: $tipname
898 :     # [ $tipname ]
899 :     # [ $tipname1, $tipname2, $tipname3 ]
900 :     #
901 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
902 :     #-------------------------------------------------------------------------------
903 :     sub node_to_node_distance {
904 :     my ( $node, $node1, $node2 ) = @_;
905 :    
906 :     array_ref( $node ) && defined( $node1 )
907 :     && defined( $node2 ) || return undef;
908 :     my @p1 = path_to_node( $node, $node1 );
909 :     my @p2 = path_to_node( $node, $node2 );
910 :     @p1 && @p2 || return undef; # Were they found?
911 :    
912 :     # Find the unique suffixes of the two paths
913 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 ); # Common node is lost
914 :     my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
915 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
916 :    
917 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
918 :     }
919 :    
920 :    
921 :     #===============================================================================
922 :     # Tree manipulations:
923 :     #===============================================================================
924 :     # Copy tree.
925 :     # Lists are copied, except that references to empty lists go to undef.
926 :     # Only defined fields are added, so tree list may be shorter than 8 fields.
927 :     #
928 :     # $treecopy = copy__newick_tree( $tree )
929 :     #-------------------------------------------------------------------------------
930 :     sub copy__newick_tree {
931 :     my ( $node ) = @_;
932 :     array_ref( $node ) || return undef;
933 :    
934 :     my $nn = []; # Reference to a new node structure
935 :     # Build a new descendant list, if not empty
936 :     my @dl = newick_desc_list( $node );
937 :     set_newick_desc_ref( $nn, @dl ? [ map { copy__newick_tree( $_ ) } @dl ]
938 :     : undef
939 :     );
940 :    
941 :     # Copy label and x, if defined
942 :     my ( $l, $x );
943 :     if ( defined( $l = newick_lbl( $node ) ) ) { set_newick_lbl( $nn, $l ) }
944 :     if ( defined( $x = newick_x( $node ) ) ) { set_newick_x( $nn, $x ) }
945 :    
946 :     # Build new comment lists, when not empty ( does not extend array unless
947 :     # necessary)
948 :     my $c;
949 :     if ( $c = newick_c1( $node ) and @$c ) { set_newick_c1( $nn, [ @$c ] ) }
950 :     if ( $c = newick_c2( $node ) and @$c ) { set_newick_c2( $nn, [ @$c ] ) }
951 :     if ( $c = newick_c3( $node ) and @$c ) { set_newick_c3( $nn, [ @$c ] ) }
952 :     if ( $c = newick_c4( $node ) and @$c ) { set_newick_c4( $nn, [ @$c ] ) }
953 :     if ( $c = newick_c5( $node ) and @$c ) { set_newick_c5( $nn, [ @$c ] ) }
954 :    
955 :     $nn;
956 :     }
957 :    
958 :    
959 :     #-------------------------------------------------------------------------------
960 :     # Use a hash to relabel the nodes in a newick tree.
961 :     #
962 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
963 :     #-------------------------------------------------------------------------------
964 :     sub newick_relabel_nodes {
965 :     my ( $node, $new_name ) = @_;
966 :    
967 :     my ( $lbl, $new );
968 :     if ( defined( $lbl = newick_lbl( $node ) )
969 :     && ( $lbl ne "" )
970 :     && defined( $new = $new_name->{ $lbl } )
971 :     ) {
972 :     set_newick_lbl( $node, $new );
973 :     }
974 :    
975 :     foreach ( newick_desc_list( $node ) ) {
976 :     newick_relabel_nodes( $_, $new_name );
977 :     }
978 :    
979 :     $node;
980 :     }
981 :    
982 :    
983 :     #-------------------------------------------------------------------------------
984 :     # Use a hash to relabel the nodes in a newick tree (case insensitive).
985 :     #
986 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
987 :     #-------------------------------------------------------------------------------
988 :     sub newick_relabel_nodes_i {
989 :     my ( $node, $new_name ) = @_;
990 :    
991 :     # Add any necessary lowercase keys to the hash:
992 :    
993 :     my $lc_lbl;
994 :     foreach ( keys %$new_name ) {
995 :     $lc_lbl = lc $_;
996 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
997 :     }
998 :    
999 :     newick_relabel_nodes_i2( $node, $new_name );
1000 :     }
1001 :    
1002 :    
1003 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1004 :     # Do the actual relabeling
1005 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1006 :     sub newick_relabel_nodes_i2 {
1007 :     my ( $node, $new_name ) = @_;
1008 :    
1009 :     my ( $lbl, $new );
1010 :     if ( defined( $lbl = newick_lbl( $node ) )
1011 :     && ( $lbl ne "" )
1012 :     && defined( $new = $new_name->{ lc $lbl } )
1013 :     ) {
1014 :     set_newick_lbl( $node, $new );
1015 :     }
1016 :    
1017 :     foreach ( newick_desc_list( $node ) ) {
1018 :     newick_relabel_nodes_i2( $_, $new_name );
1019 :     }
1020 :    
1021 :     $node;
1022 :     }
1023 :    
1024 :    
1025 :     #-------------------------------------------------------------------------------
1026 :     # Use a hash to relabel the tips in a newick tree.
1027 :     #
1028 :     # $newtree = newick_relabel_tips( $node, \%new_name )
1029 :     #-------------------------------------------------------------------------------
1030 :     sub newick_relabel_tips {
1031 :     my ( $node, $new_name ) = @_;
1032 :    
1033 :     my @desc = newick_desc_list( $node );
1034 :    
1035 :     if ( @desc ) {
1036 :     foreach ( @desc ) { newick_relabel_tips( $_, $new_name ) }
1037 :     }
1038 :     else {
1039 :     my ( $lbl, $new );
1040 :     if ( defined( $lbl = newick_lbl( $node ) )
1041 :     && ( $lbl ne "" )
1042 :     && defined( $new = $new_name->{ $lbl } )
1043 :     ) {
1044 :     set_newick_lbl( $node, $new );
1045 :     }
1046 :     }
1047 :    
1048 :     $node;
1049 :     }
1050 :    
1051 :    
1052 :     #-------------------------------------------------------------------------------
1053 :     # Use a hash to relabel the tips in a newick tree (case insensitive).
1054 :     #
1055 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
1056 :     #-------------------------------------------------------------------------------
1057 :     sub newick_relabel_tips_i {
1058 :     my ( $node, $new_name ) = @_;
1059 :    
1060 :     # Add any necessary lowercase keys to the hash:
1061 :    
1062 :     my $lc_lbl;
1063 :     foreach ( keys %$new_name ) {
1064 :     $lc_lbl = lc $_;
1065 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
1066 :     }
1067 :    
1068 :     newick_relabel_tips_i2( $node, $new_name );
1069 :     }
1070 :    
1071 :    
1072 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1073 :     # Do the actual relabeling
1074 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1075 :     sub newick_relabel_tips_i2 {
1076 :     my ( $node, $new_name ) = @_;
1077 :    
1078 :     my @desc = newick_desc_list( $node );
1079 :    
1080 :     if ( @desc ) {
1081 :     foreach ( @desc ) { newick_relabel_tips_i2( $_, $new_name ) }
1082 :     }
1083 :     else {
1084 :     my ( $lbl, $new );
1085 :     if ( defined( $lbl = newick_lbl( $node ) )
1086 :     && ( $lbl ne "" )
1087 :     && defined( $new = $new_name->{ lc $lbl } )
1088 :     ) {
1089 :     set_newick_lbl( $node, $new );
1090 :     }
1091 :     }
1092 :    
1093 :     $node;
1094 :     }
1095 :    
1096 :    
1097 :     #-------------------------------------------------------------------------------
1098 :     # Set undefined branch lenghts (except root) to length x.
1099 :     #
1100 :     # $n_changed = newick_set_undefined_branches( $node, $x )
1101 :     #-------------------------------------------------------------------------------
1102 :     sub newick_set_undefined_branches {
1103 :     my ( $node, $x, $not_root ) = @_;
1104 :    
1105 :     my $n = 0;
1106 :     if ( $not_root && ! defined( newick_x( $node ) ) ) {
1107 :     set_newick_x( $node, $x );
1108 :     $n++;
1109 :     }
1110 :    
1111 :     foreach ( newick_desc_list( $node ) ) {
1112 :     $n += newick_set_undefined_branches( $_, $x, 1 );
1113 :     }
1114 :    
1115 :     $n;
1116 :     }
1117 :    
1118 :    
1119 :     #-------------------------------------------------------------------------------
1120 :     # Set all branch lenghts (except root) to length x.
1121 :     #
1122 :     # $n_changed = newick_set_all_branches( $node, $x )
1123 :     #-------------------------------------------------------------------------------
1124 :     sub newick_set_all_branches {
1125 :     my ( $node, $x, $not_root ) = @_;
1126 :    
1127 :     my $n = 0;
1128 :     if ( $not_root ) {
1129 :     set_newick_x( $node, $x );
1130 :     $n++;
1131 :     }
1132 :    
1133 :     foreach ( newick_desc_list( $node ) ) {
1134 :     $n += newick_set_all_branches( $_, $x, 1 );
1135 :     }
1136 :    
1137 :     $n;
1138 :     }
1139 :    
1140 :    
1141 :     #-------------------------------------------------------------------------------
1142 :     # Normalize tree order (in place).
1143 :     #
1144 :     # ( $tree, $label1 ) = normalize_newick_tree( $tree )
1145 :     #-------------------------------------------------------------------------------
1146 :     sub normalize_newick_tree {
1147 :     my ( $node ) = @_;
1148 :    
1149 :     my @descends = newick_desc_list( $node );
1150 :     if ( @descends == 0 ) { return ( $node, lc newick_lbl( $node ) ) }
1151 :    
1152 :     my %hash = map { (normalize_newick_tree( $_ ))[1] => $_ } @descends;
1153 :     my @keylist = sort { $a cmp $b } keys %hash;
1154 :     set_newick_desc_list( $node, map { $hash{$_} } @keylist );
1155 :    
1156 :     ( $node, $keylist[0] );
1157 :     }
1158 :    
1159 :    
1160 :     #-------------------------------------------------------------------------------
1161 :     # Reverse tree order (in place).
1162 :     #
1163 :     # $tree = reverse_newick_tree( $tree )
1164 :     #-------------------------------------------------------------------------------
1165 :     sub reverse_newick_tree {
1166 :     my ( $node ) = @_;
1167 :    
1168 :     my @descends = newick_desc_list( $node );
1169 :     if ( @descends ) {
1170 :     set_newick_desc_list( $node, reverse @descends );
1171 :     foreach ( @descends ) { reverse_newick_tree( $_ ) }
1172 :     }
1173 :     $node;
1174 :     }
1175 :    
1176 :    
1177 :     #-------------------------------------------------------------------------------
1178 :     # Standard unrooted tree (in place).
1179 :     #
1180 :     # $stdtree = std_unrooted_newick( $tree )
1181 :     #-------------------------------------------------------------------------------
1182 :     sub std_unrooted_newick {
1183 :     my ( $tree ) = @_;
1184 :    
1185 :     my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
1186 :     ( normalize_newick_tree( reroot_newick_next_to_tip( $tree, $mintip ) ) )[0];
1187 :     }
1188 :    
1189 :    
1190 :     #-------------------------------------------------------------------------------
1191 :     # Move largest groups to periphery of tree (in place).
1192 :     #
1193 :     # dir <= -2 for up-sweeping tree (big groups always first),
1194 :     # = -1 for big group first, balanced tree,
1195 :     # = 0 for balanced tree,
1196 :     # = 1 for small group first, balanced tree, and
1197 :     # >= 2 for down-sweeping tree (small groups always top)
1198 :     #
1199 :     # $tree = aesthetic_newick_tree( $treeref, $dir )
1200 :     #-------------------------------------------------------------------------------
1201 :     sub aesthetic_newick_tree {
1202 :     my ( $tree, $dir ) = @_;
1203 :     my %cnt;
1204 :    
1205 :     $dir = ! $dir ? 0 : # Undefined or zero
1206 :     $dir <= -2 ? -1000000 :
1207 :     $dir < 0 ? -1 :
1208 :     $dir >= 2 ? 1000000 :
1209 :     1 ;
1210 :     build_tip_count_hash( $tree, \%cnt );
1211 :     reorder_by_tip_count( $tree, \%cnt, $dir );
1212 :     }
1213 :    
1214 :    
1215 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1216 :     # Build a hash to look up the number of descendants of each node.
1217 :     # Access count with $cntref->{$noderef}
1218 :     #
1219 :     # $count = build_tip_count_hash( $node, $cnt_hash_ref )
1220 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1221 :     sub build_tip_count_hash {
1222 :     my ( $node, $cntref ) = @_;
1223 :     my ( $i, $cnt );
1224 :    
1225 :     if ( newick_n_desc( $node ) < 1 ) { $cnt = 1 }
1226 :     else {
1227 :     $cnt = 0;
1228 :     foreach ( newick_desc_list( $node ) ) {
1229 :     $cnt += build_tip_count_hash( $_, $cntref );
1230 :     }
1231 :     }
1232 :    
1233 :     $cntref->{$node} = $cnt;
1234 :     $cnt;
1235 :     }
1236 :    
1237 :    
1238 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1239 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
1240 :     # dir < 0 for upward branch (big group first),
1241 :     # = 0 for no change, and
1242 :     # > 0 for downward branch (small group first).
1243 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1244 :     sub reorder_by_tip_count {
1245 :     my ( $node, $cntref, $dir ) = @_;
1246 :    
1247 :     my $nd = newick_n_desc( $node );
1248 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1249 :    
1250 :     # Reorder this subtree:
1251 :    
1252 :     my $dl_ref = newick_desc_ref( $node );
1253 :     if ( $dir < 0 ) { # Big group first
1254 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1255 :     }
1256 :     elsif ( $dir > 0 ) { # Small group first
1257 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1258 :     }
1259 :    
1260 :     # Reorder within descendant subtrees:
1261 :    
1262 :     my $step = 0;
1263 :     if ( abs( $dir ) < 1e5 ) {
1264 :     $dir = 1 - $nd; # Midgroup => as is
1265 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1266 :     $step = 2;
1267 :     }
1268 :    
1269 :     for ( my $i = 0; $i < $nd; $i++ ) {
1270 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1271 :     $dir += $step;
1272 :     }
1273 :    
1274 :     $node;
1275 :     }
1276 :    
1277 :    
1278 :     #-------------------------------------------------------------------------------
1279 :     # Move smallest groups to periphery of tree (in place).
1280 :     #
1281 :     # dir <= -2 for up-sweeping tree (big groups always first),
1282 :     # = -1 for big group first, balanced tree,
1283 :     # = 0 for balanced tree,
1284 :     # = 1 for small group first, balanced tree, and
1285 :     # >= 2 for down-sweeping tree (small groups always top)
1286 :     #
1287 :     # $tree = unaesthetic_newick_tree( $treeref, $dir )
1288 :     #-------------------------------------------------------------------------------
1289 :     sub unaesthetic_newick_tree {
1290 :     my ( $tree, $dir ) = @_;
1291 :     my %cnt;
1292 :    
1293 :     $dir = ! $dir ? 0 : # Undefined or zero
1294 :     $dir <= -2 ? -1000000 :
1295 :     $dir < 0 ? -1 :
1296 :     $dir >= 2 ? 1000000 :
1297 :     1 ;
1298 :     build_tip_count_hash( $tree, \%cnt );
1299 :     reorder_against_tip_count( $tree, \%cnt, $dir );
1300 :     }
1301 :    
1302 :    
1303 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1304 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
1305 :     # dir < 0 for upward branch (big group first),
1306 :     # = 0 for no change, and
1307 :     # > 0 for downward branch (small group first).
1308 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1309 :     sub reorder_against_tip_count {
1310 :     my ( $node, $cntref, $dir ) = @_;
1311 :    
1312 :     my $nd = newick_n_desc( $node );
1313 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1314 :    
1315 :     # Reorder this subtree:
1316 :    
1317 :     my $dl_ref = newick_desc_ref( $node );
1318 :     if ( $dir > 0 ) { # Big group first
1319 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1320 :     }
1321 :     elsif ( $dir < 0 ) { # Small group first
1322 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1323 :     }
1324 :    
1325 :     # Reorder within descendant subtrees:
1326 :    
1327 :     my $step = 0;
1328 :     if (abs( $dir ) < 1e5) {
1329 :     $dir = 1 - $nd; # Midgroup => as is
1330 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1331 :     $step = 2;
1332 :     }
1333 :    
1334 :     for ( my $i = 0; $i < $nd; $i++ ) {
1335 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1336 :     $dir += $step;
1337 :     }
1338 :    
1339 :     $node;
1340 :     }
1341 :    
1342 :    
1343 :     #-------------------------------------------------------------------------------
1344 :     # Randomize descendant order at each node (in place).
1345 :     #
1346 :     # $tree = random_order_newick_tree( $tree )
1347 :     #-------------------------------------------------------------------------------
1348 :     sub random_order_newick_tree {
1349 :     my ( $node ) = @_;
1350 :    
1351 :     my $nd = newick_n_desc( $node );
1352 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1353 :    
1354 :     # Reorder this subtree:
1355 :    
1356 :     my $dl_ref = newick_desc_ref( $node );
1357 :     @$dl_ref = random_order( @$dl_ref );
1358 :    
1359 :     # Reorder descendants:
1360 :    
1361 :     foreach ( @$dl_ref ) { random_order_newick_tree( $_ ) }
1362 :    
1363 :     $node;
1364 :     }
1365 :    
1366 :    
1367 :     #-------------------------------------------------------------------------------
1368 :     # Reroot a tree to the node that lies at the end of a path.
1369 :     #
1370 :     # $newtree = reroot_newick_by_path( @path )
1371 :     #-------------------------------------------------------------------------------
1372 :     sub reroot_newick_by_path {
1373 :     my ( $node1, $path1, @rest ) = @_;
1374 :     array_ref( $node1 ) || return undef; # Always expect a node
1375 :    
1376 :     defined( $path1 ) && @rest || return $node1; # If no path, we're done
1377 :    
1378 :     my $node2 = $rest[0]; # Next element in path is node 2
1379 :     newick_desc_i( $node1, $path1 ) eq $node2 || return undef; # Check link
1380 :    
1381 :     # Remove node 2 from node 1 descendant list. Could use a simple splice:
1382 :     #
1383 :     # splice( @$dl1, $path1-1, 1 );
1384 :     #
1385 :     # But this maintains the cyclic order of the nodes:
1386 :    
1387 :     my $dl1 = newick_desc_ref( $node1 );
1388 :     my $nd1 = @$dl1;
1389 :     if ( $path1 == 1 ) { shift @$dl1 }
1390 :     elsif ( $path1 == $nd1 ) { pop @$dl1 }
1391 :     else { @$dl1 = ( @$dl1[ $path1 .. $nd1-1 ]
1392 :     , @$dl1[ 0 .. $path1-2 ]
1393 :     )
1394 :     }
1395 :    
1396 :     # Append node 1 to node 2 descendant list (does not alter numbering):
1397 :    
1398 :     my $dl2 = newick_desc_ref( $node2 );
1399 :     if ( array_ref( $dl2 ) ) { push @$dl2, $node1 }
1400 :     else { set_newick_desc_list( $node2, [ $node1 ] ) }
1401 :    
1402 :     # Move c1 comments from node 1 to node 2:
1403 :    
1404 :     my $C11 = newick_c1( $node1 );
1405 :     my $C12 = newick_c1( $node2 );
1406 :     ! defined( $C11 ) || set_newick_c1( $node1, undef ); # Remove them from node 1
1407 :     if ( $C12 && @$C12 ) { # If node 2 comments and
1408 :     if ( $C11 && @$C11 ) { unshift @$C12, @$C11 } # Node 1, prefix 1 to 2
1409 :     }
1410 :     elsif ( $C11 && @$C11 ) { set_newick_c1( $node2, $C11 ) } # Otherwise move node 1 link
1411 :    
1412 :     # Swap branch lengths and comments for reversal of link direction:
1413 :    
1414 :     my $x1 = newick_x( $node1 );
1415 :     my $x2 = newick_x( $node2 );
1416 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node1, $x2 );
1417 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node2, $x1 );
1418 :    
1419 :     my $c41 = newick_c4( $node1 );
1420 :     my $c42 = newick_c4( $node2 );
1421 :     ! defined( $c42 ) || ! @$c42 || set_newick_c4( $node1, $c42 );
1422 :     ! defined( $c41 ) || ! @$c41 || set_newick_c4( $node2, $c41 );
1423 :    
1424 :     my $c51 = newick_c5( $node1 );
1425 :     my $c52 = newick_c5( $node2 );
1426 :     ! defined( $c52 ) || ! @$c52 || set_newick_c5( $node1, $c52 );
1427 :     ! defined( $c51 ) || ! @$c51 || set_newick_c5( $node2, $c51 );
1428 :    
1429 :     reroot_newick_by_path( @rest ); # Node 2 is first element of rest
1430 :     }
1431 :    
1432 :    
1433 :     #-------------------------------------------------------------------------------
1434 :     # Move root of tree to named tip.
1435 :     #
1436 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
1437 :     #-------------------------------------------------------------------------------
1438 :     sub reroot_newick_to_tip {
1439 :     my ( $tree, $tipname ) = @_;
1440 :     reroot_newick_by_path( path_to_tip( $tree, $tipname ) );
1441 :     }
1442 :    
1443 :    
1444 :     #-------------------------------------------------------------------------------
1445 :     # Move root of tree to be node adjacent to a named tip.
1446 :     #
1447 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
1448 :     #-------------------------------------------------------------------------------
1449 :     sub reroot_newick_next_to_tip {
1450 :     my ( $tree, $tipname ) = @_;
1451 :     my @path = path_to_tip( $tree, $tipname );
1452 :     @path || return undef;
1453 :     @path == 1 ? reroot_newick_by_path( $tree, 1, newick_desc_i( $tree, 1 ) )
1454 :     : reroot_newick_by_path( @path[0 .. @path-3] );
1455 :     }
1456 :    
1457 :    
1458 :     #-------------------------------------------------------------------------------
1459 :     # Move root of tree to a node, defined by 1 or 3 tip names.
1460 :     #
1461 :     # $newtree = reroot_newick_to_node( $tree, @node )
1462 :     #-------------------------------------------------------------------------------
1463 :     sub reroot_newick_to_node {
1464 :     reroot_newick_by_path( path_to_node( @_ ) );
1465 :     }
1466 :    
1467 :    
1468 :     #-------------------------------------------------------------------------------
1469 :     # Move root of tree to a node, defined by reference.
1470 :     #
1471 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
1472 :     #-------------------------------------------------------------------------------
1473 :     sub reroot_newick_to_node_ref {
1474 :     my ( $tree, $node ) = @_;
1475 :     reroot_newick_by_path( path_to_node_ref( $tree, $node ) );
1476 :     }
1477 :    
1478 :    
1479 :     #-------------------------------------------------------------------------------
1480 :     # Move root of tree to an approximate midpoint.
1481 :     #
1482 :     # $newtree = reroot_newick_to_approx_midpoint( $tree )
1483 :     #-------------------------------------------------------------------------------
1484 :     sub reroot_newick_to_approx_midpoint {
1485 :     my ( $tree ) = @_;
1486 :     # Compile average tip to node distances assending
1487 :    
1488 :     my $dists1 = average_to_tips_1( $tree );
1489 :    
1490 :     # Compile average tip to node distances descending, returning midpoint node
1491 :    
1492 :     my $node = average_to_tips_2( $dists1, undef, undef );
1493 :    
1494 :     # Reroot
1495 :    
1496 :     $node ? reroot_newick_to_node_ref( $tree, $node ) : $tree
1497 :     }
1498 :    
1499 :    
1500 :     sub average_to_tips_1 {
1501 :     my ( $node ) = @_;
1502 :    
1503 :     my @desc_dists = map { average_to_tips_1( $_ ) } newick_desc_list( $node );
1504 :     my $x_below = 0;
1505 :     if ( @desc_dists )
1506 :     {
1507 :     foreach ( @desc_dists ) { $x_below += $_->[0] }
1508 :     $x_below /= @desc_dists;
1509 :     }
1510 :     my $x = newick_x( $node ) || 0;
1511 :     my $x_net = $x_below + $x;
1512 :    
1513 :     [ $x_net, $x, $x_below, [ @desc_dists ], $node ]
1514 :     }
1515 :    
1516 :    
1517 :     sub average_to_tips_2 {
1518 :     my ( $dists1, $x_above, $anc_node ) = @_;
1519 :     my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;
1520 :    
1521 :     # Are we done? Root is in this node's branch, or "above"?
1522 :    
1523 :     # defined( $x_above ) and print STDERR "x_above = $x_above\n";
1524 :     # print STDERR "x = $x\n";
1525 :     # print STDERR "x_below = $x_below\n";
1526 :     # print STDERR "n_desc = ", scalar @$desc_list, "\n\n";
1527 :    
1528 :     if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
1529 :     {
1530 :     # At this point the root can only be in this node's branch,
1531 :     # or "above" it in the current rooting of the tree (which
1532 :     # would mean that the midpoint is actually down a different
1533 :     # path from the root of the current tree).
1534 :     #
1535 :     # Is the root in the current branch?
1536 :    
1537 :     if ( ( $x_below + $x ) >= $x_above )
1538 :     {
1539 :     return ( $x_above >= $x_below ) ? $anc_node : $node;
1540 :     }
1541 :     else
1542 :     {
1543 :     return undef;
1544 :     }
1545 :     }
1546 :    
1547 :     # The root must be some where below this node:
1548 :    
1549 :     my $n_1 = @$desc_list + ( $anc_node ? 1 : 0 ) - 1;
1550 :     my $ttl_dist = ( @$desc_list * $x_below ) + ( defined( $x_above ) ? ( $x_above + $x ) : 0 );
1551 :    
1552 :     foreach ( @$desc_list )
1553 :     {
1554 :     # If input tree is tip_rooted, $n-1 can be 0, so:
1555 :    
1556 :     my $above2 = $n_1 ? ( ( $ttl_dist - $_->[0] ) / $n_1 ) : 0;
1557 :     my $root = average_to_tips_2( $_, $above2, $node );
1558 :     if ( $root ) { return $root }
1559 :     }
1560 :    
1561 :     # Was not anywhere below this node (oh-oh):
1562 :    
1563 :     return undef;
1564 :     }
1565 :    
1566 :    
1567 :     #-------------------------------------------------------------------------------
1568 :     # Move root of tree from tip to adjacent node.
1569 :     #
1570 :     # $newtree = uproot_tip_rooted_newick( $tree )
1571 :     #-------------------------------------------------------------------------------
1572 :     sub uproot_tip_rooted_newick {
1573 :     my ( $node ) = @_;
1574 :     newick_is_tip_rooted( $node ) || return $node;
1575 :    
1576 :     # Path to the sole descendant:
1577 :    
1578 :     reroot_newick_by_path( $node, 1, newick_desc_i( $node, 1 ) );
1579 :     }
1580 :    
1581 :    
1582 :     #-------------------------------------------------------------------------------
1583 :     # Remove root bifurcation.
1584 :     #
1585 :     # Root node label, label comment and descendant list comment are discarded.
1586 :     #
1587 :     # $newtree = uproot_newick( $tree )
1588 :     #-------------------------------------------------------------------------------
1589 :     sub uproot_newick {
1590 :     my ( $node0 ) = @_;
1591 :     newick_is_rooted( $node0 ) || return $node0;
1592 :    
1593 :     my ( $node1, $node2 ) = newick_desc_list( $node0 );
1594 :    
1595 :     # Ensure that node1 has at least 1 descendant
1596 :    
1597 :     if ( newick_n_desc( $node1 ) ) {
1598 :     push @{ newick_desc_ref( $node1 ) }, $node2; # Add node2 to descend list
1599 :     }
1600 :    
1601 :     # Or node2 has at least 1 descendant
1602 :    
1603 :     elsif ( newick_n_desc( $node2 ) ) {
1604 :     unshift @{ newick_desc_ref( $node2 ) }, $node1; # Add node1 to descend list
1605 :     ( $node1, $node2 ) = ( $node2, $node1 ); # And reverse labels
1606 :     }
1607 :    
1608 :     # We could make this into a tip rooted tree, but for now:
1609 :    
1610 :     else { return $node0 }
1611 :    
1612 :     # Prefix node1 branch to that of node2:
1613 :    
1614 :     add_to_newick_branch( $node2, $node1 );
1615 :     set_newick_x( $node1, undef );
1616 :    
1617 :     # Tree prefix comment lists (as references):
1618 :    
1619 :     my $C10 = newick_c1( $node0 );
1620 :     my $C11 = newick_c1( $node1 );
1621 :     if ( $C11 && @$C11 ) {
1622 :     if ( $C10 && @$C10 ) { unshift @$C11, @$C10 } # Prefix to node1 comments
1623 :     }
1624 :     elsif ( $C10 && @$C10 ) {
1625 :     set_newick_c1( $node1, $C10 ) # Or move node0 comments to node1
1626 :     }
1627 :    
1628 :     $node1;
1629 :     }
1630 :    
1631 :    
1632 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1633 :     # Prefix branch of node2 to that of node1:
1634 :     #
1635 :     # $node1 = add_to_newick_branch( $node1, $node2 )
1636 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1637 :     sub add_to_newick_branch {
1638 :     my ( $node1, $node2 ) = @_;
1639 :     array_ref( $node1 ) || die "add_to_newick_branch: arg 1 not array ref\n";
1640 :     array_ref( $node2 ) || die "add_to_newick_branch: arg 2 not array ref\n";
1641 :    
1642 :     # Node structure template:
1643 :     # my ( $DL, $L, $X, $C1, $C2, $C3, $C4, $C5 ) = @$node;
1644 :    
1645 :     # Fix branch lengths for joining of two branches:
1646 :    
1647 :     set_newick_x( $node1, newick_x( $node1 ) + newick_x( $node2 ) );
1648 :    
1649 :     # Merge branch length comments:
1650 :    
1651 :     my $C41 = newick_c4( $node1 ); # Ref to node1 C4
1652 :     my $C42 = newick_c4( $node2 ); # Ref to node2 C4
1653 :     if ( $C41 && @$C41 ) {
1654 :     if ( $C42 && @$C42 ) { unshift @$C41, @$C42 } # Add node2 comment
1655 :     }
1656 :     elsif ( $C42 && @$C42 ) { set_newick_c4( $node1, $C42 ) } # Or move node1 comment
1657 :    
1658 :     my $C51 = newick_c5( $node1 ); # Ref to node1 C5
1659 :     my $C52 = newick_c5( $node2 ); # Ref to node2 C5
1660 :     if ( $C51 && @$C51 ) {
1661 :     if ( $C52 && @$C52 ) { unshift @$C51, @$C52 } # Add node2 comment
1662 :     }
1663 :     elsif ( $C52 && @$C52 ) { set_newick_c5( $node1, $C52 ) } # Or move node1 comment
1664 :    
1665 :     $node1;
1666 :     }
1667 :    
1668 :    
1669 :     #-------------------------------------------------------------------------------
1670 :     # Prune one or more tips from a tree:
1671 :     # Caveat: if one tip is listed, the original tree is modified.
1672 :     # if more than one tip is listed, a copy of the tree is returen
1673 :     # (even if it is just listing the same tip twice!).
1674 :     #
1675 :     # $newtree = prune_from_newick( $tree, $tip )
1676 :     # $newtree = prune_from_newick( $tree, @tips )
1677 :     # $newtree = prune_from_newick( $tree, \@tips )
1678 :     #-------------------------------------------------------------------------------
1679 :     sub prune_from_newick {
1680 :     my ( $tr, @tips ) = @_;
1681 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
1682 :    
1683 :     if ( @tips == 0 ) { return $tr }
1684 :     if ( @tips == 1 ) { return prune_1_from_newick( $tr, @tips ) }
1685 :    
1686 :     my %del = map { ( $_, 1 ) } @tips;
1687 :     my @keep = grep { ! $del{ $_ } } newick_tip_list( $tr );
1688 :     newick_subtree( $tr, @keep );
1689 :     }
1690 :    
1691 :    
1692 :     #-------------------------------------------------------------------------------
1693 :     # Prune a tip from a tree:
1694 :     #
1695 :     # $newtree = prune_1_from_newick( $tree, $tip )
1696 :     #-------------------------------------------------------------------------------
1697 :     sub prune_1_from_newick {
1698 :     my ( $tr, $tip ) = @_;
1699 :     my @path = path_to_tip( $tr, $tip );
1700 :     if ( @path < 3 ) { return $tr }
1701 :    
1702 :     my $node = $path[-1]; # Node with the tip
1703 :     my $i1 = $path[-2]; # Descendant number of node in ancestor desc list
1704 :     my $anc1 = $path[-3]; # Ancestor of node
1705 :     my $nd1 = newick_n_desc( $anc1 ); # Number of descendants of ancestor
1706 :     my $anc2 = ( @path >= 5 ) ? $path[-5] : undef; # Ancestor of anc1
1707 :    
1708 :     # dump_tree( $node );
1709 :     # print STDERR "i1 = $i1\n";
1710 :     # dump_tree( $anc1 );
1711 :     # print STDERR "nd1 = $nd1\n";
1712 :     # defined( $anc2 ) && dump_tree( $anc2 );
1713 :    
1714 :     if ( $nd1 > 3 || ( $anc2 && $nd1 > 2 ) ) { # Tip joins at multifurcation
1715 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant
1716 :     }
1717 :    
1718 :     elsif ( $anc2 ) { # Tip joins at internal bifurcation
1719 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
1720 :     add_to_newick_branch( $sis, $anc1 ); # combine internal branches
1721 :     set_newick_desc_i( $anc2, $path[-4], $sis ); # remove $anc1
1722 :     }
1723 :    
1724 :     elsif ( $nd1 == 2) { # Tip joins bifurcating root node
1725 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
1726 :     $sis->[1] = $anc1->[1] if ! $sis->[1] && $anc1->[1]; # root label
1727 :     $sis->[2] = undef; # root branch len
1728 :     $sis->[3] = $anc1->[3] if ! $sis->[3] && $anc1->[3]; # tree comment
1729 :     $sis->[4] = $anc1->[4] if ! $sis->[4] && $anc1->[4]; # desc list comment
1730 :     $sis->[5] = $anc1->[5] if ! $sis->[5] && $anc1->[5]; # label comment
1731 :     $sis->[6] = undef if $sis->[6]; # root branch comment
1732 :     $sis->[7] = undef if $sis->[7]; # root branch comment
1733 :     $tr = $sis; # sister is new root
1734 :     }
1735 :    
1736 :     elsif ( $nd1 == 3 ) { # Tip joins trifurcating root:
1737 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant, and
1738 :     $tr = uproot_newick( $tr ); # fix the rooting
1739 :     }
1740 :    
1741 :     else {
1742 :     return undef;
1743 :     }
1744 :    
1745 :     return $tr;
1746 :     }
1747 :    
1748 :    
1749 :     #-------------------------------------------------------------------------------
1750 :     # Produce a subtree with the desired tips:
1751 :     #
1752 :     # Except for (some) tip nodes, the tree produced is a copy.
1753 :     # There is no check that requested tips exist.
1754 :     #
1755 :     # $newtree = newick_subtree( $tree, @tips )
1756 :     # $newtree = newick_subtree( $tree, \@tips )
1757 :     #-------------------------------------------------------------------------------
1758 :     sub newick_subtree {
1759 :     my ( $tr, @tips ) = @_;
1760 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
1761 :    
1762 :     if ( @tips < 2 ) { return undef }
1763 :     my $was_rooted = newick_is_rooted( $tr );
1764 :     my $keephash = { map { ( $_, 1 ) } @tips };
1765 :     my $tr2 = subtree1( $tr, $keephash );
1766 :     $tr2 = uproot_newick( $tr2 ) if ! $was_rooted && newick_is_rooted( $tr2 );
1767 :     $tr2->[2] = undef if $tr2; # undef root branch length
1768 :     $tr2;
1769 :     }
1770 :    
1771 :    
1772 :     sub subtree1 {
1773 :     my ( $tr, $keep ) = @_;
1774 :     my @desc1 = newick_desc_list( $tr );
1775 :    
1776 :     # Is this a tip, and is it in the keep list?
1777 :    
1778 :     if ( @desc1 < 1 ) {
1779 :     return ( $keep->{ newick_lbl( $tr ) } ) ? $tr : undef;
1780 :     }
1781 :    
1782 :     # Internal node: analyze the descendants:
1783 :    
1784 :     my @desc2 = ();
1785 :     foreach ( @desc1 ) {
1786 :     my $desc = subtree1( $_, $keep );
1787 :     if ( $desc && @$desc ) { push @desc2, $desc }
1788 :     }
1789 :    
1790 :     if ( @desc2 == 0 ) { return undef }
1791 :     if ( @desc2 > 1 ) { return [ \@desc2, @$tr[ 1 .. @$tr - 1 ] ] }
1792 :    
1793 :     # Exactly 1 descendant
1794 :    
1795 :     my $desc = $desc2[ 0 ];
1796 :     my @nn = ( $desc->[0],
1797 :     $desc->[1] ? $desc->[1] : $tr->[1],
1798 :     defined( $tr->[2] ) ? $desc->[2] + $tr->[2] : undef
1799 :     );
1800 :    
1801 :     # Merge comments (only recreating the ones that existed):
1802 :    
1803 :     if ( $tr->[3] && @{$tr->[3]} || $desc->[3] && @{$desc->[3]} ) {
1804 :     $nn[3] = [ $tr->[3] ? @{$tr->[3]} : (), $desc->[3] ? @{$desc->[3]} : () ];
1805 :     }
1806 :     if ( $tr->[4] && @{$tr->[4]} || $desc->[4] && @{$desc->[4]} ) {
1807 :     $nn[4] = [ $tr->[4] ? @{$tr->[4]} : (), $desc->[4] ? @{$desc->[4]} : () ];
1808 :     }
1809 :     if ( $tr->[5] && @{$tr->[5]} || $desc->[5] && @{$desc->[5]} ) {
1810 :     $nn[5] = [ $tr->[5] ? @{$tr->[5]} : (), $desc->[5] ? @{$desc->[5]} : () ];
1811 :     }
1812 :     if ( $tr->[6] && @{$tr->[6]} || $desc->[6] && @{$desc->[6]} ) {
1813 :     $nn[6] = [ $tr->[6] ? @{$tr->[6]} : (), $desc->[6] ? @{$desc->[6]} : () ];
1814 :     }
1815 :     if ( $tr->[7] && @{$tr->[7]} || $desc->[7] && @{$desc->[7]} ) {
1816 :     $nn[7] = [ $tr->[7] ? @{$tr->[7]} : (), $desc->[7] ? @{$desc->[7]} : () ];
1817 :     }
1818 :    
1819 :     return \@nn;
1820 :     }
1821 :    
1822 :    
1823 :     #===============================================================================
1824 :     #
1825 :     # Tree writing and reading
1826 :     #
1827 :     #===============================================================================
1828 :     # writeNewickTree( $tree [, $file ] )
1829 :     #-------------------------------------------------------------------------------
1830 :     sub writeNewickTree {
1831 :     my ( $tree, $file ) = @_;
1832 :     $file || ( $file = *STDOUT );
1833 :     print $file ( strNewickTree( $tree ), "\n" );
1834 :     }
1835 :    
1836 :    
1837 :     #-------------------------------------------------------------------------------
1838 :     # fwriteNewickTree( $file, $tree ) # Args reversed to writeNewickTree
1839 :     #-------------------------------------------------------------------------------
1840 :     sub fwriteNewickTree { writeNewickTree( $_[1], $_[0] ) }
1841 :    
1842 :    
1843 :     #-------------------------------------------------------------------------------
1844 :     # $treestring = strNewickTree( $tree )
1845 :     #-------------------------------------------------------------------------------
1846 :     sub strNewickTree {
1847 :     my $node = shift @_;
1848 :     strNewickSubtree( $node, "" ) . ";";
1849 :     }
1850 :    
1851 :    
1852 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1853 :     # $string = strNewickSubtree( $node, $prefix )
1854 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1855 :     sub strNewickSubtree {
1856 :     my ( $node, $prefix ) = @_;
1857 :     my $s;
1858 :    
1859 :     $s = strNewickComments( newick_c1( $node ), $prefix );
1860 :     if ( $s ) { $prefix = " " }
1861 :    
1862 :     my $ndesc;
1863 :     if ( $ndesc = newick_n_desc( $node ) ) {
1864 :     for (my $d = 1; $d <= $ndesc; $d++) {
1865 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : "," )
1866 :     . strNewickSubtree( newick_desc_i( $node, $d ), " " );
1867 :     }
1868 :    
1869 :     $s .= ")" . strNewickComments( newick_c2( $node ), " " );
1870 :     $prefix = " ";
1871 :     }
1872 :    
1873 :     if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {
1874 :     $s .= $prefix
1875 :     . q_newick_lbl( $node )
1876 :     . strNewickComments( newick_c3( $node ), " " );
1877 :     }
1878 :    
1879 :     if ( defined( newick_x( $node ) ) ) {
1880 :     $s .= ":"
1881 :     . strNewickComments( newick_c4( $node ), " " )
1882 :     . sprintf( " %.6f", newick_x( $node ) )
1883 :     . strNewickComments( newick_c5( $node ), " " );
1884 :     }
1885 :    
1886 :     $s;
1887 :     }
1888 :    
1889 :    
1890 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1891 :     # $string = strNewickComments( $clist, $prefix )
1892 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1893 :     sub strNewickComments {
1894 :     my ( $clist, $prefix ) = @_;
1895 :     array_ref( $clist ) && ( @$clist > 0 ) || return "";
1896 :     $prefix . "[" . join( "] [", @$clist ) . "]";
1897 :     }
1898 :    
1899 :    
1900 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1901 :     # $quoted_label = q_newick_lbl( $label )
1902 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1903 :     sub q_newick_lbl {
1904 :     my $lbl = newick_lbl( $_[0] );
1905 :     defined( $lbl ) && ( $lbl ne "" ) || return undef;
1906 :    
1907 :     if ( $lbl =~ m/^[^][()_:;,]+$/ # Anything but []()_:;,
1908 :     && $lbl !~ m/^'/ ) { # and does not start with '
1909 :     $lbl =~ s/ /_/g; # Recode blanks as _
1910 :     return $lbl;
1911 :     }
1912 :    
1913 :     else {
1914 :     $lbl =~ s/'/''/g; # Double existing single quote marks
1915 :     return q(') . $lbl . q('); # Wrap in single quote marks
1916 :     }
1917 :     }
1918 :    
1919 :    
1920 :     #===============================================================================
1921 :     # $treestring = formatNewickTree( $tree )
1922 :     #===============================================================================
1923 :     sub formatNewickTree {
1924 :     formatNewickSubtree( $_[0], "", "" ) . ";";
1925 :     }
1926 :    
1927 :    
1928 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1929 :     # $string = formatNewickSubtree( $node, $prefix, $indent )
1930 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1931 :     sub formatNewickSubtree {
1932 :     my ( $node, $prefix, $indent ) = @_;
1933 :     my $s;
1934 :    
1935 :     $s = formatNewickComments( newick_c1( $node ), $prefix, $indent );
1936 :     if ( $s ) { $prefix = "\n$indent" }
1937 :    
1938 :     if ( my $ndesc = newick_n_desc( $node ) ) {
1939 :     for (my $d = 1; $d <= $ndesc; $d++) {
1940 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : ",\n$indent " )
1941 :     . formatNewickSubtree( newick_desc_i( $node, $d ), " ", $indent . " " );
1942 :     }
1943 :    
1944 :     $s .= "\n$indent)" . formatNewickComments( newick_c2( $node ), " ", $indent );
1945 :     $prefix = " ";
1946 :     }
1947 :    
1948 :     if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {
1949 :     $s .= $prefix
1950 :     . q_newick_lbl( $node )
1951 :     . formatNewickComments( newick_c3( $node ), " ", $indent );
1952 :     }
1953 :    
1954 :     if ( defined( newick_x( $node ) ) ) {
1955 :     $s .= ":"
1956 :     . formatNewickComments( newick_c4( $node ), " ", $indent )
1957 :     . sprintf(" %.6f", newick_x( $node ) )
1958 :     . formatNewickComments( newick_c5( $node ), " ", $indent );
1959 :     }
1960 :    
1961 :     $s;
1962 :     }
1963 :    
1964 :    
1965 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1966 :     # $string = formatNewickComments( $clist, $prefix, $indent )
1967 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1968 :     sub formatNewickComments {
1969 :     my ( $clist, $prefix, $indent ) = @_;
1970 :     array_ref( $clist ) && @$clist || return "";
1971 :     $prefix . "[" . join( "] [", @$clist ) . "]";
1972 :     }
1973 :    
1974 :    
1975 :     #===============================================================================
1976 :     # Tree reader adapted from the C language reader in fastDNAml
1977 :     #
1978 :     # $tree = parse_newick_tree_str( $string )
1979 :     #===============================================================================
1980 :     sub parse_newick_tree_str {
1981 :     my $s = shift @_;
1982 :    
1983 :     my ( $ind, $rootnode ) = parse_newick_subtree( $s, 0 );
1984 :     if ( substr( $s, $ind, 1 ) ne ";") { warn "warning: tree missing ';'\n" }
1985 :     $rootnode;
1986 :     }
1987 :    
1988 :    
1989 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1990 :     # Read a subtrees recursively (everything of tree but a semicolon)
1991 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1992 :     sub parse_newick_subtree {
1993 :     my ( $s, $ind ) = @_;
1994 :    
1995 :     my $newnode = [];
1996 :     my @dlist = ();
1997 :     my ( $lbl, $x, $c1, $c2, $c3, $c4, $c5 );
1998 :    
1999 :     ( $ind, $c1 ) = getNextTreeChar( $s, $ind ); # Comment 1
2000 :     if ( ! defined( $ind ) ) { treeParseError( "missing subtree" ) }
2001 :     if ( $c1 && @$c1 ) { set_newick_c1( $newnode, $c1 ) }
2002 :    
2003 :     if ( substr( $s, $ind, 1 ) eq "(" ) { # New internal node
2004 :     while ( ! @dlist || ( substr( $s, $ind, 1 ) eq "," ) ) {
2005 :     my $desc;
2006 :     ( $ind, $desc ) = parse_newick_subtree( $s, $ind+1 );
2007 :     if (! $ind) { return () }
2008 :     push @dlist, $desc;
2009 :     }
2010 :     if ( substr( $s, $ind, 1 ) ne ")" ) { treeParseError( "missing ')'" ) }
2011 :    
2012 :     ( $ind, $c2 ) = getNextTreeChar( $s, $ind+1 ); # Comment 2
2013 :     if ( $c2 && @$c2 ) { set_newick_c2( $newnode, $c2 ) }
2014 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Node label
2015 :     }
2016 :    
2017 :     elsif ( substr( $s, $ind, 1 ) =~ /[^][(,):;]/ ) { # New tip
2018 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Tip label
2019 :     if (! $ind) { return () }
2020 :     }
2021 :    
2022 :     @dlist || $lbl || treeParseError( "no descendant list or label" );
2023 :    
2024 :     if ( @dlist ) { set_newick_desc_ref( $newnode, \@dlist ) }
2025 :     if ( $lbl ) { set_newick_lbl( $newnode, $lbl ) }
2026 :    
2027 :     ( $ind, $c3 ) = getNextTreeChar( $s, $ind ); # Comment 3
2028 :     if ( $c3 && @$c3 ) { set_newick_c3( $newnode, $c3 ) }
2029 :    
2030 :     if (substr( $s, $ind, 1 ) eq ":") { # Branch length
2031 :     ( $ind, $c4 ) = getNextTreeChar( $s, $ind+1 ); # Comment 4
2032 :     if ( $c4 && @$c4 ) { set_newick_c4( $newnode, $c4 ) }
2033 :     ( $ind, $x ) = parseBranchLength( $s, $ind );
2034 :     if ( defined( $x ) ) { set_newick_x( $newnode, $x ) }
2035 :     ( $ind, $c5 ) = getNextTreeChar( $s, $ind ); # Comment 5
2036 :     if ( $c5 && @$c5 ) { set_newick_c5( $newnode, $c5 ) }
2037 :     }
2038 :    
2039 :     ( $ind, $newnode );
2040 :     }
2041 :    
2042 :    
2043 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2044 :     # Read a Newick tree label
2045 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2046 :     sub parseTreeNodeLabel { # Empty string is permitted
2047 :     my ( $s, $ind ) = @_;
2048 :     my ( $lbl, $c );
2049 :    
2050 :     if ( substr( $s, $ind, 1 ) eq "'") {
2051 :     my $ind1 = ++$ind;
2052 :    
2053 :     while ( ) {
2054 :     if ( ! defined( $c = substr( $s, $ind, 1 ) ) || $c eq "" ) {
2055 :     treeParseError( "missing close quote on label '" . substr( $s, $ind1 ) . "'" )
2056 :     }
2057 :     elsif ( $c ne "'" ) { $ind++ }
2058 :     elsif ( substr( $s, $ind, 2 ) eq "''" ) { $ind += 2 }
2059 :     else { last }
2060 :     }
2061 :    
2062 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
2063 :     $lbl =~ s/''/'/g;
2064 :     $ind++;
2065 :     }
2066 :    
2067 :     else {
2068 :     my $ind1 = $ind;
2069 :     while ( defined( $c = substr($s, $ind, 1) ) && $c ne "" && $c !~ /[][\s(,):;]/ ) { $ind++ }
2070 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
2071 :     $lbl =~ s/_/ /g;
2072 :     }
2073 :    
2074 :     ( $ind, $lbl );
2075 :     }
2076 :    
2077 :    
2078 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2079 :     # Read a Newick tree branch length
2080 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2081 :     sub parseBranchLength {
2082 :     my ( $s, $ind ) = @_;
2083 :    
2084 :     my $c = substr( $s, $ind, 1 );
2085 :    
2086 :     my $sign = ( $c ne "-" ) ? 1 : -1; # Sign
2087 :     if ( $c =~ /[-+]/ ) { $c = substr( $s, ++$ind, 1 ) }
2088 :    
2089 :     if ( $c !~ /^[.0-9]$/ ) { # Allows starting with decimal
2090 :     treeParseError( "invalid branch length character '$c'" )
2091 :     }
2092 :    
2093 :     my $v = 0;
2094 :     while ( $c =~ /[0-9]/ ) { # Whole number
2095 :     $v = 10 * $v + $c;
2096 :     $c = substr( $s, ++$ind, 1 );
2097 :     }
2098 :    
2099 :     if ( $c eq "." ) { # Fraction
2100 :     my $f = 0.1;
2101 :     $c = substr( $s, ++$ind, 1 );
2102 :     while ( $c =~ /[0-9]/ ) {
2103 :     $v += $f * $c;
2104 :     $f *= 0.1;
2105 :     $c = substr( $s, ++$ind, 1 );
2106 :     }
2107 :     }
2108 :    
2109 :     $v *= $sign;
2110 :    
2111 :     if ( $c =~ /[dDeEgG]/ ) { # Exponent
2112 :     $c = substr( $s, ++$ind, 1 );
2113 :     my $esign = ( $c ne "-" ) ? 1 : -1;
2114 :     if ( $c =~ /^[-+]$/ ) { $c = substr( $s, ++$ind, 1 ) }
2115 :     if ( $c !~ /^[0-9]$/ ) {
2116 :     treeParseError( "missing branch length exponent '$c'" )
2117 :     }
2118 :    
2119 :     my $e = 0;
2120 :     while ( $c =~ /[0-9]/ ) {
2121 :     $e = 10 * $e + $c;
2122 :     $c = substr( $s, ++$ind, 1 );
2123 :     }
2124 :     $e *= $esign;
2125 :     $v *= 10**$e;
2126 :     }
2127 :    
2128 :     ( $ind, $v );
2129 :     }
2130 :    
2131 :    
2132 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2133 :     # ( $index, /@commentlist ) = getNextTreeChar( $string, $index )
2134 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2135 :     sub getNextTreeChar { # Move to next nonblank, noncomment character
2136 :     my ( $s, $ind ) = @_;
2137 :    
2138 :     my @clist = ();
2139 :    
2140 :     # Skip white space
2141 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
2142 :    
2143 :     # Loop while it is a comment:
2144 :     while ( substr( $s, $ind, 1 ) eq "[" ) {
2145 :     $ind++;
2146 :    
2147 :     # Find end
2148 :     if ( substr( $s, $ind ) !~ /^([^]]*)\]/ ) {
2149 :     treeParseError( "comment missing closing bracket '["
2150 :     . substr( $s, $ind ) . "'" )
2151 :     }
2152 :     my $comment = $1;
2153 :    
2154 :     # Save if it includes any "text"
2155 :     if ( $comment =~ m/\S/ ) { push @clist, $comment }
2156 :    
2157 :     $ind += length( $comment ) + 1; # Comment plus closing bracket
2158 :    
2159 :     # Skip white space
2160 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
2161 :     }
2162 :    
2163 :     ( $ind, @clist ? \@clist : undef )
2164 :     }
2165 :    
2166 :    
2167 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2168 :     # treeParseError( $message )
2169 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2170 :     sub treeParseError { die "Error: parse_newick_subtree: " . $_[0] . "\n" }
2171 :    
2172 :    
2173 :     #===============================================================================
2174 :     # Make a printer plot of a tree:
2175 :     #
2176 :     # $node newick tree root node
2177 :     # $file undef (= *STDOUT), *STDOUT, *STDERR, or a file name.
2178 :     # $width the approximate characters for the tree without labels
2179 :     # $min_dx the minimum horizontal branch length
2180 :     # $dy the vertical space per taxon
2181 :     #
2182 :     # printer_plot_newick( $node, $file (D=*STDOUT), $width (D=68), $min_dx (D=2), $dy (D=1) )
2183 :     #===============================================================================
2184 :     sub printer_plot_newick {
2185 :     my ( $node, $file, $width, $min_dx, $dy ) = @_;
2186 :    
2187 :     my ( $fh, $close );
2188 :     if ( ! defined( $file ) ) {
2189 :     $fh = *STDOUT;
2190 :     }
2191 :     elsif ( $file =~ /^\*/ ) {
2192 :     $fh = $file;
2193 :     }
2194 :     else {
2195 :     open $fh, ">$file" or die "Could not open $file for writing printer_plot_newick\n";
2196 :     $close = 1;
2197 :     }
2198 :    
2199 :     print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";
2200 :     if ( $close ) { close $fh }
2201 :     }
2202 :    
2203 :    
2204 :     #===============================================================================
2205 :     # Make a text plot of a tree:
2206 :     #
2207 :     # $node newick tree root node
2208 :     # $width the approximate characters for the tree without labels
2209 :     # $min_dx the minimum horizontal branch length
2210 :     # $dy the vertical space per taxon
2211 :     #
2212 :     # @textlines = text_plot_newick( $node, $width (D=68), $min_dx (D=2), $dy (D=1) )
2213 :     #===============================================================================
2214 :     sub text_plot_newick {
2215 :     my ( $node, $width, $min_dx, $dy ) = @_;
2216 :     array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
2217 :     defined( $min_dx ) and ( $min_dx >= 0 ) or $min_dx = 2;
2218 :     defined( $dy ) and ( $dy >= 1 ) or $dy = 1;
2219 :     defined( $width ) or $width = 68;
2220 :    
2221 :     $min_dx = int( $min_dx );
2222 :     $dy = int( $dy );
2223 :     my $x_scale = $width / newick_max_X( $node );
2224 :    
2225 :     my $hash = {};
2226 :     layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );
2227 :    
2228 :     # dump_tree_hash( $node, $hash ); exit;
2229 :    
2230 :     # Generate the lines of the tree one by one:
2231 :    
2232 :     my ( $y1, $y2 ) = @{ $hash->{ $node } };
2233 :     map { text_tree_row( $node, $hash, $_, "", "+" ) } ( $y1 .. $y2 );
2234 :     }
2235 :    
2236 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2237 :     # ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy )
2238 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2239 :     sub layout_printer_plot {
2240 :     my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;
2241 :     array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
2242 :     hash_ref( $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
2243 :    
2244 :     my $dx = newick_x( $node );
2245 :     if ( defined( $dx ) ) {
2246 :     $dx *= $x_scale;
2247 :     $dx >= $min_dx or $dx = $min_dx;
2248 :     }
2249 :     else {
2250 :     $dx = ( $x0 > 0 ) ? $min_dx : 0;
2251 :     }
2252 :     $dx = int( $dx + 0.4999 );
2253 :    
2254 :     my ( $x, $xmax, $y, $ymax, $y1, $y2, $yn1, $yn2 );
2255 :    
2256 :     $x = $x0 + $dx;
2257 :     $y1 = int( $y0 + 0.5 * $dy + 0.4999 );
2258 :     my @dl = newick_desc_list( $node );
2259 :    
2260 :     if ( ! @dl ) { # A tip
2261 :     $xmax = $x;
2262 :     $y = $yn1 = $yn2 = $y2 = $y1;
2263 :     $ymax = $y + 0.5 * $dy;
2264 :     }
2265 :    
2266 :     else { # A subtree
2267 :     $xmax = -1;
2268 :     my $xmaxi;
2269 :     my $yi;
2270 :     my @ylist = ();
2271 :     $ymax = $y0;
2272 :    
2273 :     foreach ( @dl ) {
2274 :     ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy );
2275 :     push @ylist, $yi;
2276 :     if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
2277 :     }
2278 :    
2279 :     # Use of y-list is overkill for saving first and last values,
2280 :     # but eases implimentation of alternative y-value calculations.
2281 :    
2282 :     $yn1 = $ylist[ 0];
2283 :     $yn2 = $ylist[-1];
2284 :     $y = int( 0.5 * ( $yn1 + $yn2 ) + 0.4999 );
2285 :     }
2286 :    
2287 :     $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
2288 :    
2289 :     $hash->{ $node } = [ $y1, $y2, $x0, $x, $y, $yn1, $yn2 ];
2290 :     ( $xmax, $ymax, $y );
2291 :     }
2292 :    
2293 :    
2294 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2295 :     # Debug routine
2296 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2297 :     sub dump_tree {
2298 :     my ( $node, $prefix ) = @_;
2299 :     defined( $prefix ) or $prefix = "";
2300 :     print STDERR $prefix, join(", ", @$node), "\n";
2301 :     my @dl = $node->[0] ? @{$node->[0]} : ();
2302 :     foreach ( @dl ) { dump_tree( $_, $prefix . " " ) }
2303 :     $prefix or print STDERR "\n";
2304 :     }
2305 :    
2306 :    
2307 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2308 :     # Debug routine
2309 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2310 :     sub dump_tree_hash {
2311 :     my ( $node, $hash, $prefix ) = @_;
2312 :     defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
2313 :     print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
2314 :     my @dl = $node->[0] ? @{$node->[0]} : ();
2315 :     foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . " " ) }
2316 :     }
2317 :    
2318 :    
2319 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2320 :     # $line = text_tree_row( $node, $hash, $row, $line, $symb )
2321 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2322 :     sub text_tree_row {
2323 :     my ( $node, $hash, $row, $line, $symb ) = @_;
2324 :    
2325 :     my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
2326 :     if ( $row < $y1 || $row > $y2 ) { return $line }
2327 :    
2328 :     if ( length( $line ) < $x0 ) { $line .= " " x ( $x0 - length( $line ) ) }
2329 :    
2330 :     if ( $row == $y ) {
2331 :     $line = substr( $line, 0, $x0 ) . $symb . (( $x > $x0 ) ? "-" x ($x - $x0) : "");
2332 :     }
2333 :    
2334 :     elsif ( $row > $yn1 && $row < $yn2 ) {
2335 :     if ( length( $line ) < $x ) { $line .= " " x ( $x - length( $line ) ) . "|" }
2336 :     else { substr( $line, $x ) = "|" }
2337 :     }
2338 :    
2339 :     my @dl = newick_desc_list( $node );
2340 :    
2341 :     if ( @dl < 1 ) {
2342 :     $line .= " " . $node->[1];
2343 :     }
2344 :    
2345 :     else {
2346 :     my @list = map { [ $_, "+" ] } @dl; # Print symbol for line
2347 :     $list[ 0]->[1] = "/";
2348 :     $list[-1]->[1] = "\\";
2349 :    
2350 :     foreach ( @list ) {
2351 :     my ( $n, $s ) = @$_;
2352 :     if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
2353 :     $line = text_tree_row( $n, $hash, $row, $line, $s );
2354 :     }
2355 :     }
2356 :    
2357 :     if ( $row == $y ) { substr( $line, $x, 1 ) = "+" }
2358 :     }
2359 :    
2360 :     return $line;
2361 :     }
2362 :    
2363 :    
2364 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3