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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3