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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3