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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3