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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.17 # This is a SAS component.
2 :    
3 : olson 1.2 #
4 : golsen 1.20 # Copyright (c) 2003-2010 University of Chicago and Fellowship
5 : olson 1.2 # for Interpretations of Genomes. All Rights Reserved.
6 :     #
7 :     # This file is part of the SEED Toolkit.
8 : golsen 1.9 #
9 : olson 1.2 # The SEED Toolkit is free software. You can redistribute
10 :     # it and/or modify it under the terms of the SEED Toolkit
11 : golsen 1.9 # Public License.
12 : olson 1.2 #
13 :     # You should have received a copy of the SEED Toolkit Public License
14 :     # along with this program; if not write to the University of Chicago
15 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
16 :     # Genomes at veronika@thefig.info or download a copy from
17 :     # http://www.theseed.org/LICENSE.TXT.
18 :     #
19 :    
20 : golsen 1.1 package gjonewicklib;
21 :    
22 :     #===============================================================================
23 :     # perl functions for dealing with trees
24 :     #
25 : golsen 1.24 # Usage: use gjonewicklib
26 : golsen 1.1 #
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 : golsen 1.9 #
37 : golsen 1.1 # 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 : golsen 1.9 # $bool = is_overbeek_tree( $tree )
81 :     # $bool = is_gjonewick_tree( $tree )
82 :     #
83 : overbeek 1.7 # $gjonewick = overbeek_to_gjonewick( $overbeek )
84 :     # $overbeek = gjonewick_to_overbeek( $gjonewick )
85 :     #
86 : golsen 1.1 #===============================================================================
87 :     # Tree data extraction:
88 :     #===============================================================================
89 :     #
90 :     # $listref = newick_desc_ref( $noderef )
91 :     # $label = newick_lbl( $noderef )
92 :     # $x = newick_x( $noderef )
93 :     # $listref = newick_c1( $noderef )
94 :     # $listref = newick_c2( $noderef )
95 :     # $listref = newick_c3( $noderef )
96 :     # $listref = newick_c4( $noderef )
97 :     # $listref = newick_c5( $noderef )
98 :     #
99 :     # @desclist = newick_desc_list( $noderef )
100 :     # $n = newick_n_desc( $noderef )
101 :     # $descref = newick_desc_i( $noderef, $i ) # 1-based numbering
102 : golsen 1.24 #
103 :     # $bool = node_is_tip( $noderef )
104 :     # $bool = node_is_valid( $noderef )
105 :     # $bool = node_has_lbl( $noderef )
106 :     # $bool = node_lbl_is( $noderef, $label )
107 : golsen 1.1 #
108 :     # set_newick_desc_ref( $noderef, $listref )
109 :     # set_newick_lbl( $noderef, $label )
110 :     # set_newick_x( $noderef, $x )
111 :     # set_newick_c1( $noderef, $listref )
112 :     # set_newick_c2( $noderef, $listref )
113 :     # set_newick_c3( $noderef, $listref )
114 :     # set_newick_c4( $noderef, $listref )
115 :     # set_newick_c5( $noderef, $listref )
116 :     # set_newick_desc_list( $noderef, @desclist )
117 : golsen 1.9 # set_newick_desc_i( $noderef1, $i, $noderef2 ) # 1-based numbering
118 : golsen 1.8 #
119 :     # $bool = newick_is_valid( $noderef ) # verify that tree is valid
120 : golsen 1.1 #
121 :     # $bool = newick_is_rooted( $noderef ) # 2 branches from root
122 :     # $bool = newick_is_unrooted( $noderef ) # 3 or more branches from root
123 :     # $bool = newick_is_tip_rooted( $noderef ) # 1 branch from root
124 :     # $bool = newick_is_bifurcating( $noderef )
125 :     #
126 :     # $n = newick_tip_count( $noderef )
127 :     # @tiprefs = newick_tip_ref_list( $noderef )
128 : golsen 1.9 # \@tiprefs = newick_tip_ref_list( $noderef )
129 : golsen 1.1 # @tips = newick_tip_list( $noderef )
130 : golsen 1.9 # \@tips = newick_tip_list( $noderef )
131 :     #
132 : golsen 1.1 # $tipref = newick_first_tip_ref( $noderef )
133 :     # $tip = newick_first_tip( $noderef )
134 : golsen 1.9 #
135 : golsen 1.1 # @tips = newick_duplicated_tips( $noderef )
136 : golsen 1.9 # \@tips = newick_duplicated_tips( $noderef )
137 :     #
138 : golsen 1.1 # $bool = newick_tip_in_tree( $noderef, $tipname )
139 : golsen 1.9 #
140 : golsen 1.1 # @tips = newick_shared_tips( $tree1, $tree2 )
141 : golsen 1.9 # \@tips = newick_shared_tips( $tree1, $tree2 )
142 : golsen 1.1 #
143 :     # $length = newick_tree_length( $noderef )
144 : golsen 1.9 #
145 :     # %tip_distances = newick_tip_distances( $noderef )
146 :     # \%tip_distances = newick_tip_distances( $noderef )
147 :     #
148 : golsen 1.1 # $xmax = newick_max_X( $noderef )
149 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $noderef )
150 : golsen 1.9 # ( $tipname, $xmax ) = newick_most_distant_tip_name( $noderef )
151 : golsen 1.1 #
152 : golsen 1.20 # Provide a standard name by which two trees can be compared for same topology
153 :     #
154 :     # $stdname = std_tree_name( $tree )
155 :     #
156 : golsen 1.8 # Tree tip insertion point (tip is on branch of length x that
157 :     # is inserted into branch connecting node1 and node2, a distance
158 :     # x1 from node1 and x2 from node2):
159 :     #
160 : golsen 1.9 # [ $node1, $x1, $node2, $x2, $x ] = newick_tip_insertion_point( $tree, $tip )
161 : golsen 1.8 #
162 :     # Standardized label for a node in terms of intersection of 3 lowest sorting
163 :     # tips (sort is lower case):
164 :     #
165 : golsen 1.9 # @TipOrTips = std_node_name( $tree, $node )
166 : golsen 1.8 #
167 : golsen 1.1 #-------------------------------------------------------------------------------
168 :     # Paths from root of tree:
169 :     #-------------------------------------------------------------------------------
170 :     #
171 :     # Path descriptions are of form:
172 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN )
173 :     # () is returned upon failure
174 :     #
175 : golsen 1.24 # @path = path_to_tip( $treenode, $tipname )
176 :     # \%paths = paths_to_tips( $treenode, \@%tips )
177 :     # @path = path_to_named_node( $treenode, $nodename )
178 :     # \%paths = paths_to_named_nodes( $treenode, \@names )
179 :     # @path = path_to_node_ref( $treenode, $noderef )
180 :     #
181 :     # @path = path_to_node( $node, $name1, $name2, $name3 ) # 3 node names
182 :     # @path = path_to_node( $node, [ $name1, $name2, $name3 ] ) # Array of names
183 :     # @path = path_to_node( $node, $name1, $name2 ) # 2 node names
184 :     # @path = path_to_node( $node, [ $name1, $name2 ] ) # Array of names
185 :     # @path = path_to_node( $node, $name1 ) # 1 node name
186 :     # @path = path_to_node( $node, [ $name1 ] ) # Array with name
187 : golsen 1.1 #
188 :     # $distance = newick_path_length( @path )
189 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
190 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
191 :     #
192 :     #
193 :     #===============================================================================
194 :     # Tree manipulations:
195 :     #===============================================================================
196 :     #
197 : overbeek 1.4 # $treecopy = copy_newick_tree( $tree )
198 : golsen 1.1 #
199 :     #-------------------------------------------------------------------------------
200 : golsen 1.8 # The following modify the existing tree, and possibly any components of that
201 : golsen 1.1 # tree that are reached by reference. If the old version is still needed, copy
202 :     # before modifying.
203 :     #-------------------------------------------------------------------------------
204 :     #
205 :     # Modify labels:
206 :     #
207 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
208 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
209 :     # $newtree = newick_relabel_tips( $node, \%new_name )
210 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
211 :     #
212 :     # Modify branches:
213 :     #
214 :     # $n_changed = newick_set_undefined_branches( $node, $x )
215 :     # $n_changed = newick_set_all_branches( $node, $x )
216 : golsen 1.5 # $n_changed = newick_fix_negative_branches( $tree )
217 : overbeek 1.7 # $node = newick_rescale_branches( $node, $factor )
218 : golsen 1.24 # $node = newick_random_branch_lengths( $node, $x1, $x2 )
219 : golsen 1.15 # $node = newick_modify_branches( $node, \&function )
220 :     # $node = newick_modify_branches( $node, \&function, \@func_parms )
221 : golsen 1.1 #
222 : golsen 1.8 # Modify comments:
223 :     #
224 :     # $node = newick_strip_comments( $node )
225 :     #
226 : golsen 1.1 # Modify rooting and/or order:
227 :     #
228 :     # $nrmtree = normalize_newick_tree( $tree )
229 :     # $revtree = reverse_newick_tree( $tree )
230 :     # $stdtree = std_unrooted_newick( $tree )
231 :     # $newtree = aesthetic_newick_tree( $tree, $direction )
232 :     # $rndtree = random_order_newick_tree( $tree )
233 : golsen 1.24 # $newtree - reroot_tree( $tree, \%options )
234 : golsen 1.1 # $newtree = reroot_newick_by_path( @path )
235 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
236 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
237 :     # $newtree = reroot_newick_to_node( $tree, @node )
238 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
239 : golsen 1.9 # $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
240 : golsen 1.24 # $newtree = reroot_newick_at_dist_between_nodes( $tree, $node1, $node2, $distance )
241 : golsen 1.12 # $newtree = reroot_newick_to_midpoint( $tree ) # unweighted
242 :     # $newtree = reroot_newick_to_midpoint_w( $tree ) # weight by tips
243 : golsen 1.5 # $newtree = reroot_newick_to_approx_midpoint( $tree ) # unweighted
244 :     # $newtree = reroot_newick_to_approx_midpoint_w( $tree ) # weight by tips
245 : golsen 1.1 # $newtree = uproot_tip_rooted_newick( $tree )
246 :     # $newtree = uproot_newick( $tree )
247 :     #
248 :     # $newtree = prune_from_newick( $tree, $tip )
249 : golsen 1.12 # $newtree = rooted_newick_subtree( $tree, @tips )
250 :     # $newtree = rooted_newick_subtree( $tree, \@tips )
251 : golsen 1.1 # $newtree = newick_subtree( $tree, @tips )
252 :     # $newtree = newick_subtree( $tree, \@tips )
253 : golsen 1.12 # $newtree = newick_covering_subtree( $tree, @tips )
254 :     # $newtree = newick_covering_subtree( $tree, \@tips )
255 : golsen 1.1 #
256 : golsen 1.5 # $newtree = collapse_zero_length_branches( $tree )
257 :     #
258 : golsen 1.8 # $node = newick_insert_at_node( $node, $subtree )
259 :     # $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
260 :     #
261 : golsen 1.1 #===============================================================================
262 : golsen 1.9 # Tree neighborhood: subtree of n tips to represent a larger tree.
263 :     #===============================================================================
264 :     #
265 :     # Focus around root:
266 :     #
267 :     # $subtree = root_neighborhood_representative_tree( $tree, $n, \%tip_priority )
268 :     # $subtree = root_neighborhood_representative_tree( $tree, $n )
269 :     # @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
270 :     # @tips = root_neighborhood_representative_tips( $tree, $n )
271 :     # \@tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
272 :     # \@tips = root_neighborhood_representative_tips( $tree, $n )
273 :     #
274 :     # Focus around a tip insertion point (the tip is not in the subtree):
275 :     #
276 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )
277 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )
278 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
279 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
280 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
281 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
282 :     #
283 :     #===============================================================================
284 : golsen 1.22 # Random trees
285 :     #===============================================================================
286 :     #
287 :     # $tree = random_equibranch_tree( @tips, \%options )
288 :     # $tree = random_equibranch_tree( \@tips, \%options )
289 :     # $tree = random_equibranch_tree( @tips )
290 :     # $tree = random_equibranch_tree( \@tips )
291 :     #
292 :     # $tree = random_ultrametric_tree( @tips, \%options )
293 :     # $tree = random_ultrametric_tree( \@tips, \%options )
294 :     # $tree = random_ultrametric_tree( @tips )
295 :     # $tree = random_ultrametric_tree( \@tips )
296 :     #
297 :     #===============================================================================
298 : golsen 1.1 # Tree reading and writing:
299 :     #===============================================================================
300 : golsen 1.9 # Write machine-readable trees:
301 : golsen 1.1 #
302 :     # writeNewickTree( $tree )
303 :     # writeNewickTree( $tree, $file )
304 : overbeek 1.7 # writeNewickTree( $tree, \*FH )
305 :     # fwriteNewickTree( $file, $tree ) # Matches the C arg list for f... I/O
306 : golsen 1.1 # $treestring = swriteNewickTree( $tree )
307 :     # $treestring = formatNewickTree( $tree )
308 : golsen 1.9 #
309 :     # Write human-readable trees:
310 :     #
311 : golsen 1.1 # @textlines = text_plot_newick( $node, $width, $min_dx, $dy )
312 :     # printer_plot_newick( $node, $file, $width, $min_dx, $dy )
313 :     #
314 : golsen 1.9 # Read trees:
315 :     #
316 : golsen 1.24 # $tree = read_newick_tree( $file ) # reads to a semicolon
317 :     # @trees = read_newick_trees( $file ) # reads to end of file
318 : overbeek 1.7 # $tree = parse_newick_tree_str( $string )
319 : golsen 1.1 #
320 :     #===============================================================================
321 :    
322 :    
323 : golsen 1.8 use Carp;
324 :     use Data::Dumper;
325 : golsen 1.9 use strict;
326 : golsen 1.8
327 : golsen 1.1 require Exporter;
328 :    
329 :     our @ISA = qw(Exporter);
330 :     our @EXPORT = qw(
331 : golsen 1.9 is_overbeek_tree
332 :     is_gjonewick_tree
333 : overbeek 1.7 overbeek_to_gjonewick
334 :     gjonewick_to_overbeek
335 : golsen 1.8 newick_is_valid
336 : golsen 1.1 newick_is_rooted
337 :     newick_is_unrooted
338 :     tree_rooted_on_tip
339 :     newick_is_bifurcating
340 :     newick_tip_count
341 : golsen 1.9 newick_tip_ref_list
342 : golsen 1.1 newick_tip_list
343 : golsen 1.9
344 : golsen 1.1 newick_first_tip
345 :     newick_duplicated_tips
346 :     newick_tip_in_tree
347 :     newick_shared_tips
348 :    
349 :     newick_tree_length
350 : golsen 1.9 newick_tip_distances
351 : golsen 1.1 newick_max_X
352 :     newick_most_distant_tip_ref
353 :     newick_most_distant_tip_name
354 : golsen 1.9
355 :     newick_tip_insertion_point
356 :    
357 : golsen 1.20 std_tree_name
358 : golsen 1.1
359 :     path_to_tip
360 :     path_to_named_node
361 :     path_to_node_ref
362 :     path_to_node
363 :    
364 :     newick_path_length
365 :     tip_to_tip_distance
366 :     node_to_node_distance
367 :    
368 : overbeek 1.4 copy_newick_tree
369 : golsen 1.1
370 :     newick_relabel_nodes
371 :     newick_relabel_nodes_i
372 :     newick_relabel_tips
373 :     newick_relabel_tips_i
374 :    
375 :     newick_set_undefined_branches
376 :     newick_set_all_branches
377 : golsen 1.5 newick_fix_negative_branches
378 : overbeek 1.7 newick_rescale_branches
379 : golsen 1.24 newick_random_branch_lengths
380 : golsen 1.15 newick_modify_branches
381 : golsen 1.1
382 : golsen 1.8 newick_strip_comments
383 :    
384 : golsen 1.1 normalize_newick_tree
385 :     reverse_newick_tree
386 :     std_unrooted_newick
387 :     aesthetic_newick_tree
388 :     unaesthetic_newick_tree
389 :     random_order_newick_tree
390 :    
391 : golsen 1.24 reroot_tree
392 : golsen 1.1 reroot_newick_by_path
393 :     reroot_newick_to_tip
394 :     reroot_newick_next_to_tip
395 :     reroot_newick_to_node
396 :     reroot_newick_to_node_ref
397 : golsen 1.9 reroot_newick_between_nodes
398 : golsen 1.24 reroot_newick_at_dist_between_nodes
399 : golsen 1.12 reroot_newick_to_midpoint
400 :     reroot_newick_to_midpoint_w
401 : golsen 1.1 reroot_newick_to_approx_midpoint
402 : golsen 1.5 reroot_newick_to_approx_midpoint_w
403 : golsen 1.1 uproot_tip_rooted_newick
404 :     uproot_newick
405 :    
406 :     prune_from_newick
407 : golsen 1.12 rooted_newick_subtree
408 : golsen 1.1 newick_subtree
409 : golsen 1.12 newick_covering_subtree
410 : golsen 1.5 collapse_zero_length_branches
411 : golsen 1.1
412 : golsen 1.8 newick_insert_at_node
413 :     newick_insert_between_nodes
414 :    
415 : golsen 1.9 root_neighborhood_representative_tree
416 :     root_neighborhood_representative_tips
417 :     tip_neighborhood_representative_tree
418 :     tip_neighborhood_representative_tips
419 :    
420 : golsen 1.22 random_equibranch_tree
421 :     random_ultrametric_tree
422 :    
423 : golsen 1.1 writeNewickTree
424 :     fwriteNewickTree
425 :     strNewickTree
426 :     formatNewickTree
427 : overbeek 1.7
428 :     read_newick_tree
429 :     read_newick_trees
430 : golsen 1.1 parse_newick_tree_str
431 :    
432 :     printer_plot_newick
433 :     text_plot_newick
434 :     );
435 :    
436 :     our @EXPORT_OK = qw(
437 :     newick_desc_ref
438 :     newick_lbl
439 :     newick_x
440 :     newick_c1
441 :     newick_c2
442 :     newick_c3
443 :     newick_c4
444 :     newick_c5
445 :     newick_desc_list
446 :     newick_n_desc
447 :     newick_desc_i
448 : golsen 1.24
449 :     node_is_tip
450 :     node_is_valid
451 :     node_has_lbl
452 :     node_lbl_is
453 : golsen 1.1
454 :     set_newick_desc_ref
455 :     set_newick_lbl
456 :     set_newick_x
457 :     set_newick_c1
458 :     set_newick_c2
459 :     set_newick_c3
460 :     set_newick_c4
461 :     set_newick_c5
462 :    
463 :     set_newick_desc_list
464 :     set_newick_desc_i
465 :    
466 :     add_to_newick_branch
467 :     dump_tree
468 :     );
469 :    
470 :    
471 :     #-------------------------------------------------------------------------------
472 :     # Internally used definitions
473 :     #-------------------------------------------------------------------------------
474 :    
475 : golsen 1.21 sub array_ref { $_[0] && ref( $_[0] ) eq 'ARRAY' }
476 :     sub hash_ref { $_[0] && ref( $_[0] ) eq 'HASH' }
477 : golsen 1.1
478 : golsen 1.24 sub max { $_[0] >= $_[1] ? $_[0] : $_[1] }
479 :     sub min { $_[0] <= $_[1] ? $_[0] : $_[1] }
480 :    
481 : golsen 1.1
482 :     #===============================================================================
483 : golsen 1.9 # Interconvert overbeek and gjonewick trees:
484 : overbeek 1.7 #===============================================================================
485 :    
486 : golsen 1.24 sub is_overbeek_tree { array_ref( $_[0] ) && array_ref( $_[0]->[2] ) }
487 : golsen 1.9
488 :     sub is_gjonewick_tree { array_ref( $_[0] ) && array_ref( $_[0]->[0] ) }
489 :    
490 : overbeek 1.7 sub overbeek_to_gjonewick
491 :     {
492 :     return () unless ref( $_[0] ) eq 'ARRAY';
493 :     my ( $lbl, $x, $desc ) = @{ $_[0] };
494 :     my ( undef, @desc ) = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
495 :     [ [ map { overbeek_to_gjonewick( $_ ) } @desc ], $lbl, $x ]
496 :     }
497 :    
498 :     sub gjonewick_to_overbeek
499 :     {
500 :     return () unless ref( $_[0] ) eq 'ARRAY';
501 :     my ( $desc, $lbl, $x ) = @{ $_[0] };
502 : golsen 1.24 my @desc = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
503 : overbeek 1.7 my $parent = $_[1];
504 : golsen 1.24 my $node = [ $lbl, $x, undef, [] ];
505 : overbeek 1.7 $node->[2] = [ $parent, map { gjonewick_to_overbeek( $_, $node ) } @desc ];
506 :     return $node;
507 :     }
508 :    
509 : golsen 1.9
510 : overbeek 1.7 #===============================================================================
511 : golsen 1.1 # Extract tree structure values:
512 :     #===============================================================================
513 :     #
514 :     # $listref = newick_desc_ref( $noderef )
515 :     # $string = newick_lbl( $noderef )
516 :     # $real = newick_x( $noderef )
517 :     # $listref = newick_c1( $noderef )
518 :     # $listref = newick_c2( $noderef )
519 :     # $listref = newick_c3( $noderef )
520 :     # $listref = newick_c4( $noderef )
521 :     # $listref = newick_c5( $noderef )
522 :     # @list = newick_desc_list( $noderef )
523 :     # $int = newick_n_desc( $noderef )
524 :     # $listref = newick_desc_i( $noderef )
525 : golsen 1.24 #
526 : golsen 1.1 # $bool = node_is_tip( $noderef )
527 :     # $bool = node_is_valid( $noderef )
528 : golsen 1.24 # $bool = node_has_lbl( $noderef )
529 :     # $bool = node_lbl_is( $noderef, $label )
530 : golsen 1.1 #
531 :     #-------------------------------------------------------------------------------
532 :    
533 : golsen 1.24 sub newick_desc_ref { ref($_[0]) ? $_[0]->[0] : Carp::confess() }
534 : golsen 1.8 sub newick_lbl { ref($_[0]) ? $_[0]->[1] : Carp::confess() }
535 : golsen 1.12 sub newick_x { ref($_[0]) ? $_[0]->[2] : Carp::confess() }
536 : golsen 1.10 sub newick_c1 { ref($_[0]) ? $_[0]->[3] : Carp::confess() }
537 : golsen 1.12 sub newick_c2 { ref($_[0]) ? $_[0]->[4] : Carp::confess() }
538 :     sub newick_c3 { ref($_[0]) ? $_[0]->[5] : Carp::confess() }
539 :     sub newick_c4 { ref($_[0]) ? $_[0]->[6] : Carp::confess() }
540 :     sub newick_c5 { ref($_[0]) ? $_[0]->[7] : Carp::confess() }
541 : golsen 1.1
542 : golsen 1.24 sub newick_desc_list
543 :     {
544 :     local $_ = $_[0];
545 :     array_ref( $_ ) && array_ref( $_->[0] ) ? @{ $_->[0] } : ();
546 : golsen 1.1 }
547 :    
548 : golsen 1.24 sub newick_n_desc
549 :     {
550 :     local $_ = $_[0];
551 :     array_ref( $_ ) && array_ref( $_->[0] ) ? scalar @{ $_->[0] } : 0;
552 : golsen 1.1 }
553 :    
554 : golsen 1.24 sub newick_desc_i
555 :     {
556 :     local $_ = $_[0];
557 :     my $i = $_[1];
558 :     array_ref( $_ ) && $i && array_ref( $_->[0] ) ? $_->[0]->[$i-1] : undef;
559 : golsen 1.1 }
560 :    
561 : golsen 1.24 sub node_is_tip
562 :     {
563 :     local $_ = $_[0];
564 :     ! array_ref( $_ ) ? undef : # Not a node ref
565 :     array_ref( $_->[0] ) ? @{ $_->[0] } == 0 : # Empty descend list?
566 :     1 ; # No descend list
567 : golsen 1.1 }
568 :    
569 : golsen 1.24 sub node_is_valid # An array ref with nonempty descend list or a label
570 :     {
571 :     local $_ = $_[0];
572 :     array_ref( $_ ) && ( array_ref( $_->[0] ) && @{ $_->[0] } || defined( $_->[1] ) )
573 : golsen 1.1 }
574 :    
575 : golsen 1.24 sub node_has_lbl { local $_ = $_[0]->[1]; defined( $_ ) && ( $_ ne '' ) }
576 :    
577 :     sub node_lbl_is { local $_ = $_[0]->[1]; defined( $_ ) && ( $_ eq $_[1] ) }
578 :    
579 : golsen 1.1
580 :     #-------------------------------------------------------------------------------
581 :     # Set tree structure values
582 :     #-------------------------------------------------------------------------------
583 :    
584 :     sub set_newick_desc_ref { $_[0]->[0] = $_[1] }
585 :     sub set_newick_lbl { $_[0]->[1] = $_[1] }
586 :     sub set_newick_x { $_[0]->[2] = $_[1] }
587 :     sub set_newick_c1 { $_[0]->[3] = $_[1] }
588 :     sub set_newick_c2 { $_[0]->[4] = $_[1] }
589 :     sub set_newick_c3 { $_[0]->[5] = $_[1] }
590 :     sub set_newick_c4 { $_[0]->[6] = $_[1] }
591 :     sub set_newick_c5 { $_[0]->[7] = $_[1] }
592 :    
593 : golsen 1.24 sub set_newick_desc_list
594 :     {
595 :     local $_ = shift;
596 :     array_ref( $_ ) || return;
597 :     if ( array_ref( $_->[0] ) ) { @{ $_->[0] } = @_ }
598 :     else { $_->[0] = [ @_ ] }
599 : golsen 1.1 }
600 :    
601 : golsen 1.24 sub set_newick_desc_i
602 :     {
603 : golsen 1.1 my ( $node1, $i, $node2 ) = @_;
604 :     array_ref( $node1 ) && array_ref( $node2 ) || return;
605 :     if ( array_ref( $node1->[0] ) ) { $node1->[0]->[$i-1] = $node2 }
606 :     else { $node1->[0] = [ $node2 ] }
607 :     }
608 :    
609 :    
610 :     #===============================================================================
611 :     # Some tree property tests:
612 :     #===============================================================================
613 : golsen 1.8 # Tree is valid?
614 :     #
615 :     # $bool = newick_is_valid( $node, $verbose )
616 :     #-------------------------------------------------------------------------------
617 :     sub newick_is_valid
618 :     {
619 :     my $node = shift;
620 :    
621 :     if ( ! array_ref( $node ) )
622 :     {
623 :     print STDERR "Node is not array reference\n" if $_[0];
624 :     return 0;
625 :     }
626 :    
627 :     my @node = @$node;
628 :     if ( ! @node )
629 :     {
630 :     print STDERR "Node is empty array reference\n" if $_[0];
631 :     return 0;
632 :     }
633 :    
634 :     # Must have descendant or label:
635 :    
636 :     if ( ! ( array_ref( $node[0] ) && @{ $node[0] } ) && ! $node[2] )
637 :     {
638 :     print STDERR "Node has neither descendant nor label\n" if $_[0];
639 :     return 0;
640 :     }
641 :    
642 :     # If comments are present, they must be array references
643 :    
644 :     foreach ( ( @node > 3 ) ? @node[ 3 .. $#node ] : () )
645 :     {
646 :     if ( defined( $_ ) && ! array_ref( $_ ) )
647 :     {
648 :     print STDERR "Node has neither descendant or label\n" if $_[0];
649 :     return 0;
650 :     }
651 :     }
652 :    
653 :     # Inspect the descendants:
654 :    
655 :     foreach ( array_ref( $node[0] ) ? @{ $node[0] } : () )
656 :     {
657 :     newick_is_valid( $_, @_ ) || return 0
658 :     }
659 :    
660 :     return 1;
661 :     }
662 :    
663 :    
664 :     #-------------------------------------------------------------------------------
665 : golsen 1.1 # Tree is rooted (2 branches at root node)?
666 :     #
667 :     # $bool = newick_is_rooted( $node )
668 :     #-------------------------------------------------------------------------------
669 : golsen 1.24 sub newick_is_rooted
670 :     {
671 :     local $_ = $_[0];
672 :     ! array_ref( $_ ) ? undef : # Not a node ref
673 :     array_ref( $_->[0] ) ? @{ $_->[0] } == 2 : # 2 branches
674 :     0 ; # No descend list
675 : golsen 1.1 }
676 :    
677 :    
678 :     #-------------------------------------------------------------------------------
679 :     # Tree is unrooted (> 2 branches at root node)?
680 :     #
681 :     # $bool = newick_is_unrooted( $node )
682 :     #-------------------------------------------------------------------------------
683 : golsen 1.24 sub newick_is_unrooted
684 :     {
685 :     local $_ = $_[0];
686 :     ! array_ref( $_ ) ? undef : # Not a node ref
687 :     array_ref( $_->[0] ) ? @{ $_->[0] } >= 3 : # Over 2 branches
688 :     0 ; # No descend list
689 : golsen 1.1 }
690 :    
691 :    
692 :     #-------------------------------------------------------------------------------
693 :     # Tree is rooted on a tip (1 branch at root node)?
694 :     #
695 :     # $bool = newick_is_tip_rooted( $node )
696 :     #-------------------------------------------------------------------------------
697 : golsen 1.24 sub newick_is_tip_rooted
698 :     {
699 :     local $_ = $_[0];
700 :     ! array_ref( $_ ) ? undef : # Not a node ref
701 :     array_ref( $_->[0] ) ? @{ $_->[0] } == 1 : # 1 branch
702 :     0 ; # No descend list
703 : golsen 1.1 }
704 :    
705 :     #===============================================================================
706 :     # Everything below this point refers to parts of the tree structure using
707 :     # only the routines above.
708 :     #===============================================================================
709 :     # Tree is bifurcating? If so, return number of descendents of root node.
710 :     #
711 :     # $n_desc = newick_is_bifurcating( $node )
712 :     #-------------------------------------------------------------------------------
713 : golsen 1.24 sub newick_is_bifurcating
714 :     {
715 : golsen 1.1 my ( $node, $not_root ) = @_;
716 :     if ( ! array_ref( $node ) ) { return undef } # Bad arg
717 :    
718 :     my $n = newick_n_desc( $node );
719 :     $n == 0 && ! $not_root ? 0 :
720 :     $n == 1 && $not_root ? 0 :
721 :     $n == 3 && $not_root ? 0 :
722 :     $n > 3 ? 0 :
723 :     $n > 2 && ! newick_is_bifurcating( newick_desc_i( $node, 3, 1 ) ) ? 0 :
724 :     $n > 1 && ! newick_is_bifurcating( newick_desc_i( $node, 2, 1 ) ) ? 0 :
725 :     $n > 0 && ! newick_is_bifurcating( newick_desc_i( $node, 1, 1 ) ) ? 0 :
726 :     $n
727 :     }
728 :    
729 :    
730 :     #-------------------------------------------------------------------------------
731 :     # Number of tips:
732 :     #
733 :     # $n = newick_tip_count( $node )
734 :     #-------------------------------------------------------------------------------
735 : golsen 1.24 sub newick_tip_count
736 :     {
737 : golsen 1.1 my ( $node, $not_root ) = @_;
738 :    
739 :     my $imax = newick_n_desc( $node );
740 :     if ( $imax < 1 ) { return 1 }
741 :    
742 :     # Special case for tree rooted on tip
743 :    
744 :     my $n = ( $imax == 1 && ( ! $not_root ) ) ? 1 : 0;
745 :    
746 :     foreach ( newick_desc_list( $node ) ) { $n += newick_tip_count( $_, 1 ) }
747 :    
748 :     $n;
749 :     }
750 :    
751 :    
752 :     #-------------------------------------------------------------------------------
753 :     # List of tip nodes:
754 :     #
755 : golsen 1.9 # @tips = newick_tip_ref_list( $noderef )
756 :     # \@tips = newick_tip_ref_list( $noderef )
757 : golsen 1.1 #-------------------------------------------------------------------------------
758 : golsen 1.24 sub newick_tip_ref_list
759 :     {
760 : golsen 1.1 my ( $node, $not_root ) = @_;
761 :    
762 :     my $imax = newick_n_desc( $node );
763 :     if ( $imax < 1 ) { return $node }
764 :    
765 :     my @list = ();
766 :    
767 :     # Tree rooted on tip?
768 : golsen 1.24 if ( ! $not_root && ( $imax == 1 ) && node_has_lbl( $node ) ) { push @list, $node }
769 : golsen 1.1
770 :     foreach ( newick_desc_list( $node ) ) {
771 :     push @list, newick_tip_ref_list( $_, 1 );
772 :     }
773 :    
774 : golsen 1.9 wantarray ? @list : \@list;
775 : golsen 1.1 }
776 :    
777 :    
778 :     #-------------------------------------------------------------------------------
779 :     # List of tips:
780 :     #
781 :     # @tips = newick_tip_list( $node )
782 : golsen 1.9 # \@tips = newick_tip_list( $node )
783 : golsen 1.1 #-------------------------------------------------------------------------------
784 : golsen 1.24 sub newick_tip_list
785 :     {
786 : golsen 1.9 my @tips = map { newick_lbl( $_ ) } newick_tip_ref_list( $_[0] );
787 :     wantarray ? @tips : \@tips;
788 : golsen 1.1 }
789 :    
790 :    
791 :     #-------------------------------------------------------------------------------
792 :     # First tip node in tree:
793 :     #
794 :     # $tipref = newick_first_tip_ref( $node )
795 :     #-------------------------------------------------------------------------------
796 : golsen 1.24 sub newick_first_tip_ref
797 :     {
798 : golsen 1.1 my ( $node, $not_root ) = @_;
799 :     valid_node( $node ) || return undef;
800 :    
801 :     # Arrived at tip, or start of a tip-rooted tree?
802 :     my $n = newick_n_desc( $node );
803 :     if ( ( $n < 1 ) || ( $n == 1 && ! $not_root ) ) { return $node }
804 :    
805 :     newick_first_tip_ref( newick_desc_i( $node, 1 ), 1 );
806 :     }
807 :    
808 :    
809 :     #-------------------------------------------------------------------------------
810 :     # First tip name in tree:
811 :     #
812 :     # $tip = newick_first_tip( $node )
813 :     #-------------------------------------------------------------------------------
814 : golsen 1.24 sub newick_first_tip
815 :     {
816 : golsen 1.1 my ( $noderef ) = @_;
817 :    
818 :     my $tipref;
819 :     array_ref( $tipref = newick_first_tip_ref( $noderef ) ) ? newick_lbl( $tipref )
820 : golsen 1.9 : undef;
821 : golsen 1.1 }
822 :    
823 :    
824 :     #-------------------------------------------------------------------------------
825 :     # List of duplicated tip labels.
826 :     #
827 :     # @tips = newick_duplicated_tips( $node )
828 : golsen 1.9 # \@tips = newick_duplicated_tips( $node )
829 : golsen 1.1 #-------------------------------------------------------------------------------
830 : golsen 1.24 sub newick_duplicated_tips
831 :     {
832 : golsen 1.9 my @tips = &duplicates( newick_tip_list( $_[0] ) );
833 :     wantarray ? @tips : \@tips;
834 : golsen 1.1 }
835 :    
836 :    
837 :     #-------------------------------------------------------------------------------
838 :     # Tip in tree?
839 :     #
840 :     # $bool = newick_tip_in_tree( $node, $tipname )
841 :     #-------------------------------------------------------------------------------
842 : golsen 1.24 sub newick_tip_in_tree
843 :     {
844 : golsen 1.1 my ( $node, $tip, $not_root ) = @_;
845 :    
846 :     my $n = newick_n_desc( $node );
847 : golsen 1.24 if ( $n < 1 ) { return node_lbl_is( $node, $tip ) ? 1 : 0 }
848 : golsen 1.1
849 :     # Special case for tree rooted on tip
850 :    
851 : golsen 1.24 if ( ( $n == 1 ) && ( ! $not_root ) && node_lbl_is( $node, $tip ) )
852 :     {
853 :     return 1
854 :     }
855 : golsen 1.1
856 :     foreach ( newick_desc_list( $node ) ) {
857 :     if ( newick_tip_in_tree( $_, $tip, 1 ) ) { return 1 }
858 :     }
859 :    
860 :     0; # Fall through means not found
861 :     }
862 :    
863 :    
864 :     #-------------------------------------------------------------------------------
865 :     # Tips shared between 2 trees.
866 :     #
867 :     # @tips = newick_shared_tips( $tree1, $tree2 )
868 : golsen 1.9 # \@tips = newick_shared_tips( $tree1, $tree2 )
869 : golsen 1.1 #-------------------------------------------------------------------------------
870 : golsen 1.24 sub newick_shared_tips
871 :     {
872 : golsen 1.9 my ( $tree1, $tree2 ) = @_;
873 :     my $tips1 = newick_tip_list( $tree1 );
874 :     my $tips2 = newick_tip_list( $tree2 );
875 :     my @tips = &intersection( $tips1, $tips2 );
876 :     wantarray ? @tips : \@tips;
877 : golsen 1.1 }
878 :    
879 :    
880 :     #-------------------------------------------------------------------------------
881 :     # Tree length.
882 :     #
883 :     # $length = newick_tree_length( $node )
884 :     #-------------------------------------------------------------------------------
885 : golsen 1.24 sub newick_tree_length
886 :     {
887 : golsen 1.1 my ( $node, $not_root ) = @_;
888 :    
889 :     my $x = $not_root ? newick_x( $node ) : 0;
890 :     defined( $x ) || ( $x = 1 ); # Convert undefined to 1
891 :    
892 :     foreach ( newick_desc_list( $node ) ) { $x += newick_tree_length( $_, 1 ) }
893 :    
894 :     $x;
895 :     }
896 :    
897 :    
898 :     #-------------------------------------------------------------------------------
899 : golsen 1.9 # Hash of tip nodes and corresponding distances from root:
900 :     #
901 :     # %tip_distances = newick_tip_distances( $node )
902 :     # \%tip_distances = newick_tip_distances( $node )
903 :     #-------------------------------------------------------------------------------
904 :     sub newick_tip_distances
905 :     {
906 :     my ( $node, $x, $hash ) = @_;
907 :     my $root = ! $hash;
908 :     ref( $hash ) eq 'HASH' or $hash = {};
909 :    
910 :     $x ||= 0;
911 :     $x += newick_x( $node ) || 0;
912 :    
913 :     # Is it a tip?
914 :    
915 :     my $n_desc = newick_n_desc( $node );
916 :     if ( ! $n_desc )
917 :     {
918 :     $hash->{ newick_lbl( $node ) } = $x;
919 :     return $hash;
920 :     }
921 :    
922 :     # Tree rooted on tip?
923 :    
924 : golsen 1.24 if ( $root && ( $n_desc == 1 ) && node_has_lbl( $node ) )
925 : golsen 1.9 {
926 :     $hash->{ newick_lbl( $node ) } = 0; # Distance to root is zero
927 :     }
928 :    
929 : golsen 1.24 foreach ( newick_desc_list( $node ) ) { newick_tip_distances( $_, $x, $hash ) }
930 : golsen 1.9
931 :     wantarray ? %$hash : $hash;
932 :     }
933 :    
934 :    
935 :     #-------------------------------------------------------------------------------
936 : golsen 1.1 # Tree max X.
937 :     #
938 :     # $xmax = newick_max_X( $node )
939 :     #-------------------------------------------------------------------------------
940 : golsen 1.24 sub newick_max_X
941 :     {
942 : golsen 1.1 my ( $node, $not_root ) = @_;
943 :    
944 :     my $xmax = 0;
945 :     foreach ( newick_desc_list( $node ) ) {
946 :     my $x = newick_max_X( $_, 1 );
947 :     if ( $x > $xmax ) { $xmax = $x }
948 :     }
949 :    
950 :     my $x = $not_root ? newick_x( $node ) : 0;
951 :     $xmax + ( defined( $x ) ? $x : 1 ); # Convert undefined to 1
952 :     }
953 :    
954 :    
955 :     #-------------------------------------------------------------------------------
956 :     # Most distant tip from root: distance and path.
957 :     #
958 :     # ( $xmax, @path ) = newick_most_distant_tip_path( $tree )
959 :     #-------------------------------------------------------------------------------
960 : golsen 1.24 sub newick_most_distant_tip_path
961 :     {
962 : golsen 1.1 my ( $node, $not_root ) = @_;
963 :    
964 :     my $imax = newick_n_desc( $node );
965 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
966 :     my @pmax = ();
967 :     for ( my $i = 1; $i <= $imax; $i++ ) {
968 :     my ( $x, @path ) = newick_most_distant_tip_path( newick_desc_i( $node, $i ), 1 );
969 :     if ( $x > $xmax ) { $xmax = $x; @pmax = ( $i, @path ) }
970 :     }
971 :    
972 :     my $x = $not_root ? newick_x( $node ) : 0;
973 :     $xmax += defined( $x ) ? $x : 0; # Convert undefined to 1
974 :     ( $xmax, $node, @pmax );
975 :     }
976 :    
977 :    
978 :     #-------------------------------------------------------------------------------
979 :     # Most distant tip from root, and its distance.
980 :     #
981 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $tree )
982 :     #-------------------------------------------------------------------------------
983 : golsen 1.24 sub newick_most_distant_tip_ref
984 :     {
985 : golsen 1.1 my ( $node, $not_root ) = @_;
986 :    
987 :     my $imax = newick_n_desc( $node );
988 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
989 :     my $tmax = $node;
990 :     foreach ( newick_desc_list( $node ) ) {
991 :     my ( $t, $x ) = newick_most_distant_tip_ref( $_, 1 );
992 :     if ( $x > $xmax ) { $xmax = $x; $tmax = $t }
993 :     }
994 :    
995 :     my $x = $not_root ? newick_x( $node ) : 0;
996 :     $xmax += defined( $x ) ? $x : 1; # Convert undefined to 1
997 :     ( $tmax, $xmax );
998 :     }
999 :    
1000 :    
1001 :     #-------------------------------------------------------------------------------
1002 :     # Name of most distant tip from root, and its distance.
1003 :     #
1004 :     # ( $tipname, $xmax ) = newick_most_distant_tip_name( $tree )
1005 :     #-------------------------------------------------------------------------------
1006 : golsen 1.24 sub newick_most_distant_tip_name
1007 :     {
1008 : golsen 1.1 my ( $tipref, $xmax ) = newick_most_distant_tip_ref( $_[0] );
1009 :     ( newick_lbl( $tipref ), $xmax )
1010 :     }
1011 :    
1012 :    
1013 :     #-------------------------------------------------------------------------------
1014 : golsen 1.8 # Tree tip insertion point (with standard node labels):
1015 :     #
1016 :     # [ $node1, $x1, $node2, $x2, $x ]
1017 :     # = newick_tip_insertion_point( $tree, $tip )
1018 :     #
1019 :     # Which means: tip is on a branch of length x that is inserted into the branch
1020 :     # connecting node1 and node2, at distance x1 from node1 and x2 from node2.
1021 :     #
1022 :     # x1 +------ n1a (lowest sorting tip of this subtree)
1023 :     # +--------n1
1024 :     # | +------n1b (lowest sorting tip of this subtree)
1025 :     # tip-------n
1026 :     # x | +------------- n2a (lowest sorting tip of this subtree)
1027 :     # +------n2
1028 :     # x2 +-------- n2b (lowest sorting tip of this subtree)
1029 :     #
1030 :     # The designations of 1 vs 2, and a vs b are chosen such that:
1031 :     # n1a < n1b, and n2a < n2b, and n1a < n2a
1032 :     #
1033 :     # Then the statandard description becomes:
1034 :     #
1035 :     # [ [ $n1a, min(n1b,n2a), max(n1b,n2a) ], x1,
1036 :     # [ $n2a, min(n2b,n1a), max(n2b,n1a) ], x2,
1037 :     # x
1038 :     # ]
1039 :     #
1040 :     #-------------------------------------------------------------------------------
1041 :     sub newick_tip_insertion_point
1042 :     {
1043 :     my ( $tree, $tip ) = @_;
1044 :     $tree && $tip && ref( $tree ) eq 'ARRAY' or return undef;
1045 :     $tree = copy_newick_tree( $tree ) or return undef;
1046 :     $tree = reroot_newick_to_tip( $tree, $tip ) or return undef;
1047 :     my $node = $tree;
1048 :    
1049 :     my $x = 0; # Distance to node
1050 :     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
1051 :     $node = $dl->[0]; # Node adjacent to tip
1052 :     $dl = newick_desc_ref( $node );
1053 :     while ( $dl && ( @$dl == 1 ) ) # Traverse unbranched nodes
1054 :     {
1055 :     $node = $dl->[0];
1056 :     $x += newick_x( $node );
1057 :     $dl = newick_desc_ref( $node );
1058 :     }
1059 :     $x += newick_x( $node );
1060 :    
1061 :     # We are now at the node that is the insertion point.
1062 :     # Is it a tip?
1063 :    
1064 :     my @description;
1065 :    
1066 :     if ( ( ! $dl ) || @$dl == 0 )
1067 :     {
1068 :     @description = ( [ newick_lbl( $node ) ], 0, undef, 0, $x );
1069 :     }
1070 :    
1071 :     # Is it a trifurcation or greater, in which case it does not go
1072 :     # away with tip deletion?
1073 :    
1074 :     elsif ( @$dl > 2 )
1075 :     {
1076 :     @description = ( [ std_node_name( $node, $node ) ], 0, undef, 0, $x );
1077 :     }
1078 :    
1079 :     # The node is bifurcating. We need to describe it.
1080 :    
1081 :     else
1082 :     {
1083 : golsen 1.9 my ( $n1, $x1 ) = describe_descendant( $dl->[0] );
1084 :     my ( $n2, $x2 ) = describe_descendant( $dl->[1] );
1085 : golsen 1.8
1086 :     if ( @$n1 == 2 ) { push @$n1, $n2->[0] }
1087 :     if ( @$n2 == 2 )
1088 :     {
1089 :     @$n2 = sort { lc $a cmp lc $b } ( @$n2, $n1->[0] );
1090 :     }
1091 :     if ( @$n1 == 3 ) { @$n2 = sort { lc $a cmp lc $b } @$n2 }
1092 :     @description = ( $n1, $x1, $n2, $x2, $x );
1093 :     }
1094 :    
1095 :     return wantarray ? @description : \@description;
1096 :     }
1097 :    
1098 :    
1099 : golsen 1.9 sub describe_descendant
1100 : golsen 1.8 {
1101 :     my $node = shift;
1102 :    
1103 :     my $x = 0; # Distance to node
1104 :     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
1105 :     while ( $dl && ( @$dl == 1 ) ) # Traverse unbranched nodes
1106 :     {
1107 :     $node = $dl->[0];
1108 : golsen 1.9 $x += newick_x( $node );
1109 : golsen 1.8 $dl = newick_desc_ref( $node );
1110 :     }
1111 :     $x += newick_x( $node );
1112 :    
1113 :     # Is it a tip? Return list of one tip;
1114 :    
1115 : golsen 1.24 if ( ( ! $dl ) || ! @$dl ) { return ( [ newick_lbl( $node ) ], $x ) }
1116 : golsen 1.8
1117 :     # Get tips of each descendent, keeping lowest sorting from each.
1118 :     # Return the two lowest of those (the third will come from the
1119 :     # other side of the original node).
1120 :    
1121 : golsen 1.9 my @rep_tips = sort { lc $a cmp lc $b }
1122 :     map { ( sort { lc $a cmp lc $b } newick_tip_list( $_ ) )[0] }
1123 :     @$dl;
1124 :     return ( [ @rep_tips[0,1] ], $x );
1125 : golsen 1.8 }
1126 :    
1127 :    
1128 :     #-------------------------------------------------------------------------------
1129 : golsen 1.1 # Standard node name:
1130 :     # Tip label if at a tip
1131 :     # Three sorted tip labels intersecting at node, each being smallest
1132 :     # of all the tips of their subtrees
1133 :     #
1134 : golsen 1.9 # @TipOrTips = std_node_name( $tree, $node )
1135 : golsen 1.1 #-------------------------------------------------------------------------------
1136 : golsen 1.24 sub std_node_name
1137 :     {
1138 : golsen 1.1 my $tree = $_[0];
1139 :    
1140 :     # Node reference is last element of path to node
1141 :    
1142 :     my $noderef = ( path_to_node( @_ ) )[-1];
1143 :     defined( $noderef ) || return ();
1144 :    
1145 : golsen 1.24 if ( node_is_tip( $noderef ) || ( $noderef eq $tree ) ) { # Is it a tip?
1146 : golsen 1.1 return newick_lbl( $noderef );
1147 :     }
1148 :    
1149 :     # Work through lists of tips in descendant subtrees, removing them from
1150 :     # @rest, and keeping the best tip for each subtree.
1151 :    
1152 : golsen 1.8 my @rest = newick_tip_list( $tree );
1153 : golsen 1.9 my @best = map
1154 :     {
1155 : golsen 1.8 my @tips = sort { lc $a cmp lc $b } newick_tip_list( $_ );
1156 : golsen 1.9 @rest = &set_difference( \@rest, \@tips );
1157 : golsen 1.1 $tips[0];
1158 : golsen 1.9 } newick_desc_list( $noderef );
1159 : golsen 1.1
1160 :     # Best of the rest of the tree
1161 :     push @best, ( sort { lc $a cmp lc $b } @rest )[0];
1162 :    
1163 :     # Take the top 3, in order:
1164 :    
1165 :     ( @best >= 3 ) ? ( sort { lc $a cmp lc $b } @best )[0 .. 2] : ();
1166 :     }
1167 :    
1168 :    
1169 :     #===============================================================================
1170 :     # Functions to find paths in trees.
1171 :     #
1172 :     # Path descriptions are of form:
1173 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN ) # Always odd
1174 :     # () is returned upon failure
1175 :     #
1176 :     # Numbering of descendants is 1-based.
1177 :     #===============================================================================
1178 :     # Path to tip:
1179 :     #
1180 :     # @path = path_to_tip( $treenode, $tipname )
1181 :     #-------------------------------------------------------------------------------
1182 : golsen 1.24 sub path_to_tip
1183 :     {
1184 :     my ( $node, $tip ) = @_;
1185 : golsen 1.1
1186 :     my $imax = newick_n_desc( $node );
1187 :    
1188 : golsen 1.24 # Tip (including root tip):
1189 :    
1190 :     return ( $node ) if ( $imax < 2 ) && node_lbl_is( $node, $tip );
1191 : golsen 1.1
1192 : golsen 1.24 for ( my $i = 1; $i <= $imax; $i++ ) {
1193 :     my @suf = path_to_tip( newick_desc_i( $node, $i ), $tip );
1194 :     return ( $node, $i, @suf ) if @suf;
1195 : golsen 1.1 }
1196 :    
1197 :     (); # Not found
1198 :     }
1199 :    
1200 :    
1201 :     #-------------------------------------------------------------------------------
1202 : golsen 1.24 # Paths to tips:
1203 :     #
1204 :     # \%paths = paths_to_tips( $treenode, \@tips )
1205 :     # \%paths = paths_to_tips( $treenode, \%tips )
1206 :     #
1207 :     #-------------------------------------------------------------------------------
1208 :     sub paths_to_tips
1209 :     {
1210 :     my ( $node, $tips ) = @_;
1211 :     return {} if ! ( $tips && ref( $tips ) );
1212 :    
1213 :     # Replace request for list with request by hash
1214 :    
1215 :     if ( ref( $tips ) eq 'ARRAY' ) { $tips = { map { $_ => 1 } @$tips } }
1216 :    
1217 :     my $paths = {};
1218 :     my $imax = newick_n_desc( $node );
1219 :     if ( $imax < 2 )
1220 :     {
1221 :     my $lbl;
1222 :     if ( node_has_lbl( $node ) && defined( $lbl = newick_lbl( $node ) ) && $tips->{ $lbl } )
1223 :     {
1224 :     delete $tips->{ $lbl };
1225 :     $paths->{ $lbl } = [ $node ];
1226 :     }
1227 :     return $paths if ! $imax; # tip (no more to do it tested below)
1228 :     }
1229 :    
1230 :     for ( my $i = 1; $i <= $imax && keys %$tips; $i++ )
1231 :     {
1232 :     my $new = paths_to_tips( newick_desc_i( $node, $i ), $tips );
1233 :     foreach ( keys %$new )
1234 :     {
1235 :     splice @{ $new->{ $_ } }, 0, 0, ( $node, $i );
1236 :     $paths->{ $_ } = $new->{ $_ };
1237 :     }
1238 :     }
1239 :    
1240 :     return $paths;
1241 :     }
1242 :    
1243 :    
1244 :     #-------------------------------------------------------------------------------
1245 :     # Path to named node. Like path to tip, but also finds named internal nodes.
1246 : golsen 1.1 #
1247 :     # @path = path_to_named_node( $treenode, $name )
1248 : golsen 1.24 #
1249 : golsen 1.1 #-------------------------------------------------------------------------------
1250 : golsen 1.24 sub path_to_named_node
1251 :     {
1252 :     my ( $node, $name ) = @_;
1253 : golsen 1.1
1254 : golsen 1.24 return ( $node ) if node_lbl_is( $node, $name );
1255 : golsen 1.1
1256 :     my $imax = newick_n_desc( $node );
1257 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1258 : golsen 1.24 my @suf = path_to_named_node( newick_desc_i( $node, $i ), $name );
1259 :     return ( $node, $i, @suf ) if @suf;
1260 : golsen 1.1 }
1261 :    
1262 :     (); # Not found
1263 :     }
1264 :    
1265 :    
1266 :     #-------------------------------------------------------------------------------
1267 : golsen 1.24 # Paths to named nodes in tree (need not be tips):
1268 :     #
1269 :     # \%paths = paths_to_named_nodes( $treenode, \@names )
1270 :     # \%paths = paths_to_named_nodes( $treenode, \%names )
1271 :     #
1272 :     #-------------------------------------------------------------------------------
1273 :     sub paths_to_named_nodes
1274 :     {
1275 :     my ( $node, $names ) = @_;
1276 :     return {} if ! ( $names && ref( $names ) );
1277 :    
1278 :     # Replace request for list with request by hash
1279 :    
1280 :     if ( ref( $names ) eq 'ARRAY' ) { $names = { map { $_ => 1 } @$names } }
1281 :    
1282 :     my $paths = {};
1283 :     my $imax = newick_n_desc( $node );
1284 :    
1285 :     my $lbl;
1286 :     if ( node_has_lbl( $node ) && defined( $lbl = newick_lbl( $node ) ) && $names->{ $lbl } )
1287 :     {
1288 :     delete $names->{ $lbl };
1289 :     $paths->{ $lbl } = [ $node ];
1290 :     }
1291 :     return $paths if ! $imax; # tip (no more to do it tested below)
1292 :    
1293 :     for ( my $i = 1; $i <= $imax && keys %$names; $i++ )
1294 :     {
1295 :     my $new = paths_to_named_nodes( newick_desc_i( $node, $i ), $names );
1296 :     foreach ( keys %$new )
1297 :     {
1298 :     splice @{ $new->{ $_ } }, 0, 0, ( $node, $i );
1299 :     $paths->{ $_ } = $new->{ $_ };
1300 :     }
1301 :     }
1302 :    
1303 :     return $paths;
1304 :     }
1305 :    
1306 :    
1307 :     #-------------------------------------------------------------------------------
1308 : golsen 1.1 # Path to node reference.
1309 :     #
1310 :     # @path = path_to_node_ref( $treenode, $noderef )
1311 : golsen 1.24 #
1312 : golsen 1.1 #-------------------------------------------------------------------------------
1313 : golsen 1.24 sub path_to_node_ref
1314 :     {
1315 :     my ( $node, $noderef ) = @_;
1316 : golsen 1.1
1317 : golsen 1.24 return ( $node ) if ( $node eq $noderef );
1318 : golsen 1.1
1319 :     my $imax = newick_n_desc( $node );
1320 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1321 : golsen 1.24 my @suf = path_to_node_ref( newick_desc_i( $node, $i ), $noderef );
1322 :     return ( $node, $i, @suf ) if @suf;
1323 : golsen 1.1 }
1324 :    
1325 :     (); # Not found
1326 :     }
1327 :    
1328 :    
1329 :     #-------------------------------------------------------------------------------
1330 : golsen 1.24 # Path to node, as defined by 1, 2 or 3 node names (usually tips).
1331 : golsen 1.1 #
1332 : golsen 1.24 # @path = path_to_node( $tree, $name1, $name2, $name3 ) # 3 tip names
1333 :     # @path = path_to_node( $tree, [ $name1, $name2, $name3 ] ) # Allow array ref
1334 :     # @path = path_to_node( $tree, $name1, $name2 ) # 2 tip names
1335 :     # @path = path_to_node( $tree, [ $name1, $name2 ] ) # Allow array ref
1336 :     # @path = path_to_node( $tree, $name1 ) # Path to tip or named node
1337 :     # @path = path_to_node( $tree, [ $name1 ] ) # Allow array ref
1338 :     #
1339 :     #-------------------------------------------------------------------------------
1340 :     sub path_to_node
1341 :     {
1342 :     my ( $tree, @names ) = @_;
1343 :     array_ref( $tree ) && defined( $names[0] ) || return ();
1344 : golsen 1.1
1345 :     # Allow arg 2 to be an array reference
1346 :    
1347 : golsen 1.24 @names = @{ $names[0] } if array_ref( $names[0] );
1348 : golsen 1.1
1349 : golsen 1.24 return () if @names < 1 || @names > 3;
1350 :    
1351 :     # Just one name:
1352 :    
1353 :     return path_to_named_node( $tree, $names[0] ) if ( @names == 1 );
1354 :    
1355 :     my @paths = values %{ paths_to_named_nodes( $tree, \@names ) };
1356 :    
1357 :     # Were all node names found?
1358 :    
1359 :     return () if @paths != @names;
1360 :    
1361 :     my @path12 = &common_prefix( @paths[0,1] );
1362 :     return () if ! @path12;
1363 :     return @path12 if @paths == 2;
1364 : golsen 1.1
1365 : golsen 1.24 my @path13 = &common_prefix( @paths[0,2] );
1366 :     my @path23 = &common_prefix( @paths[1,2] );
1367 : golsen 1.1
1368 :     # Return the longest common prefix of any two paths
1369 : golsen 1.24
1370 :     ( @path12 >= @path13 && @path12 >= @path23 ) ? @path12 :
1371 :     ( @path13 >= @path23 ) ? @path13 :
1372 :     @path23 ;
1373 : golsen 1.1 }
1374 :    
1375 :    
1376 :     #-------------------------------------------------------------------------------
1377 :     # Distance along path.
1378 :     #
1379 :     # $distance = newick_path_length( @path )
1380 : golsen 1.24 #
1381 : golsen 1.1 #-------------------------------------------------------------------------------
1382 : golsen 1.24 sub newick_path_length
1383 :     {
1384 : golsen 1.1 my $node = shift; # Discard the first node
1385 :     array_ref( $node ) || return undef;
1386 :     @_ ? distance_along_path_2( @_ ) : 0;
1387 :     }
1388 :    
1389 :    
1390 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1391 :     # This expects to get path minus root node:
1392 :     #
1393 :     # $distance = distance_along_path_2( @path )
1394 : golsen 1.24 #
1395 : golsen 1.1 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1396 : golsen 1.24 sub distance_along_path_2
1397 :     {
1398 : golsen 1.1 shift; # Discard descendant number
1399 :     my $node = shift;
1400 :     array_ref( $node ) || return undef;
1401 :     my $d1 = newick_x( $node );
1402 : golsen 1.8 my $d2 = @_ ? distance_along_path_2( @_ ) : 0;
1403 : golsen 1.1 defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1404 :     }
1405 :    
1406 :    
1407 :     #-------------------------------------------------------------------------------
1408 :     # Tip-to-tip distance.
1409 :     #
1410 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
1411 : golsen 1.24 #
1412 : golsen 1.1 #-------------------------------------------------------------------------------
1413 : golsen 1.24 sub tip_to_tip_distance
1414 :     {
1415 : golsen 1.1 my ( $node, $tip1, $tip2 ) = @_;
1416 :    
1417 :     array_ref( $node ) && defined( $tip1 )
1418 :     && defined( $tip2 ) || return undef;
1419 :     my @p1 = path_to_tip( $node, $tip1 );
1420 :     my @p2 = path_to_tip( $node, $tip2 );
1421 :     @p1 && @p2 || return undef; # Were they found?
1422 :    
1423 :     # Find the unique suffixes of the two paths
1424 : golsen 1.9 my ( $suf1, $suf2 ) = &unique_suffixes( \@p1, \@p2 ); # Common node is lost
1425 : golsen 1.1 my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
1426 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
1427 :    
1428 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1429 :     }
1430 :    
1431 :    
1432 :     #-------------------------------------------------------------------------------
1433 :     # Node-to-node distance.
1434 :     # Nodes can be: $tipname
1435 :     # [ $tipname ]
1436 :     # [ $tipname1, $tipname2, $tipname3 ]
1437 :     #
1438 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
1439 : golsen 1.24 #
1440 : golsen 1.1 #-------------------------------------------------------------------------------
1441 : golsen 1.24 sub node_to_node_distance
1442 :     {
1443 : golsen 1.1 my ( $node, $node1, $node2 ) = @_;
1444 :    
1445 :     array_ref( $node ) && defined( $node1 )
1446 :     && defined( $node2 ) || return undef;
1447 : golsen 1.8 my @p1 = path_to_node( $node, $node1 ) or return undef;
1448 :     my @p2 = path_to_node( $node, $node2 ) or return undef;
1449 : golsen 1.1
1450 :     # Find the unique suffixes of the two paths
1451 : golsen 1.9 my ( $suf1, $suf2 ) = &unique_suffixes( \@p1, \@p2 ); # Common node is lost
1452 : golsen 1.1 my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
1453 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
1454 :    
1455 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1456 :     }
1457 :    
1458 :    
1459 :     #===============================================================================
1460 :     # Tree manipulations:
1461 :     #===============================================================================
1462 :     # Copy tree.
1463 :     # Lists are copied, except that references to empty lists go to undef.
1464 :     # Only defined fields are added, so tree list may be shorter than 8 fields.
1465 :     #
1466 : overbeek 1.4 # $treecopy = copy_newick_tree( $tree )
1467 : golsen 1.24 #
1468 : golsen 1.1 #-------------------------------------------------------------------------------
1469 : golsen 1.24 sub copy_newick_tree
1470 :     {
1471 : golsen 1.1 my ( $node ) = @_;
1472 :     array_ref( $node ) || return undef;
1473 :    
1474 :     my $nn = []; # Reference to a new node structure
1475 :     # Build a new descendant list, if not empty
1476 :     my @dl = newick_desc_list( $node );
1477 : overbeek 1.4 set_newick_desc_ref( $nn, @dl ? [ map { copy_newick_tree( $_ ) } @dl ]
1478 : golsen 1.1 : undef
1479 :     );
1480 :    
1481 :     # Copy label and x, if defined
1482 :     my ( $l, $x );
1483 :     if ( defined( $l = newick_lbl( $node ) ) ) { set_newick_lbl( $nn, $l ) }
1484 :     if ( defined( $x = newick_x( $node ) ) ) { set_newick_x( $nn, $x ) }
1485 :    
1486 :     # Build new comment lists, when not empty ( does not extend array unless
1487 :     # necessary)
1488 :     my $c;
1489 :     if ( $c = newick_c1( $node ) and @$c ) { set_newick_c1( $nn, [ @$c ] ) }
1490 :     if ( $c = newick_c2( $node ) and @$c ) { set_newick_c2( $nn, [ @$c ] ) }
1491 :     if ( $c = newick_c3( $node ) and @$c ) { set_newick_c3( $nn, [ @$c ] ) }
1492 :     if ( $c = newick_c4( $node ) and @$c ) { set_newick_c4( $nn, [ @$c ] ) }
1493 :     if ( $c = newick_c5( $node ) and @$c ) { set_newick_c5( $nn, [ @$c ] ) }
1494 :    
1495 :     $nn;
1496 :     }
1497 :    
1498 :    
1499 :     #-------------------------------------------------------------------------------
1500 :     # Use a hash to relabel the nodes in a newick tree.
1501 :     #
1502 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
1503 : golsen 1.24 #
1504 : golsen 1.1 #-------------------------------------------------------------------------------
1505 : golsen 1.24 sub newick_relabel_nodes
1506 :     {
1507 : golsen 1.1 my ( $node, $new_name ) = @_;
1508 :    
1509 : golsen 1.24 my ( $new );
1510 :     if ( node_has_lbl( $node ) && defined( $new = $new_name->{ newick_lbl( $node ) } ) ) {
1511 : golsen 1.1 set_newick_lbl( $node, $new );
1512 :     }
1513 :    
1514 :     foreach ( newick_desc_list( $node ) ) {
1515 :     newick_relabel_nodes( $_, $new_name );
1516 :     }
1517 :    
1518 :     $node;
1519 :     }
1520 :    
1521 :    
1522 :     #-------------------------------------------------------------------------------
1523 :     # Use a hash to relabel the nodes in a newick tree (case insensitive).
1524 :     #
1525 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
1526 : golsen 1.24 #
1527 : golsen 1.1 #-------------------------------------------------------------------------------
1528 : golsen 1.24 sub newick_relabel_nodes_i
1529 :     {
1530 : golsen 1.1 my ( $node, $new_name ) = @_;
1531 :    
1532 :     # Add any necessary lowercase keys to the hash:
1533 :    
1534 :     my $lc_lbl;
1535 :     foreach ( keys %$new_name ) {
1536 :     $lc_lbl = lc $_;
1537 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
1538 :     }
1539 :    
1540 :     newick_relabel_nodes_i2( $node, $new_name );
1541 :     }
1542 :    
1543 :    
1544 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1545 :     # Do the actual relabeling
1546 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1547 : golsen 1.24 sub newick_relabel_nodes_i2
1548 :     {
1549 : golsen 1.1 my ( $node, $new_name ) = @_;
1550 :    
1551 : golsen 1.24 my ( $new );
1552 :     if ( node_has_lbl( $node ) && defined( $new = $new_name->{ lc newick_lbl( $node ) } ) ) {
1553 : golsen 1.1 set_newick_lbl( $node, $new );
1554 :     }
1555 :    
1556 :     foreach ( newick_desc_list( $node ) ) {
1557 :     newick_relabel_nodes_i2( $_, $new_name );
1558 :     }
1559 :    
1560 :     $node;
1561 :     }
1562 :    
1563 :    
1564 :     #-------------------------------------------------------------------------------
1565 :     # Use a hash to relabel the tips in a newick tree.
1566 :     #
1567 :     # $newtree = newick_relabel_tips( $node, \%new_name )
1568 : golsen 1.24 #
1569 : golsen 1.1 #-------------------------------------------------------------------------------
1570 : golsen 1.24 sub newick_relabel_tips
1571 :     {
1572 : golsen 1.1 my ( $node, $new_name ) = @_;
1573 :    
1574 :     my @desc = newick_desc_list( $node );
1575 :    
1576 :     if ( @desc ) {
1577 :     foreach ( @desc ) { newick_relabel_tips( $_, $new_name ) }
1578 :     }
1579 :     else {
1580 : golsen 1.24 my ( $new );
1581 :     if ( node_has_lbl( $node ) && defined( $new = $new_name->{ newick_lbl( $node ) } ) ) {
1582 : golsen 1.1 set_newick_lbl( $node, $new );
1583 :     }
1584 :     }
1585 :    
1586 :     $node;
1587 :     }
1588 :    
1589 :    
1590 :     #-------------------------------------------------------------------------------
1591 :     # Use a hash to relabel the tips in a newick tree (case insensitive).
1592 :     #
1593 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
1594 : golsen 1.24 #
1595 : golsen 1.1 #-------------------------------------------------------------------------------
1596 : golsen 1.24 sub newick_relabel_tips_i
1597 :     {
1598 : golsen 1.1 my ( $node, $new_name ) = @_;
1599 :    
1600 :     # Add any necessary lowercase keys to the hash:
1601 :    
1602 :     my $lc_lbl;
1603 :     foreach ( keys %$new_name ) {
1604 :     $lc_lbl = lc $_;
1605 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
1606 :     }
1607 :    
1608 :     newick_relabel_tips_i2( $node, $new_name );
1609 :     }
1610 :    
1611 :    
1612 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1613 :     # Do the actual relabeling
1614 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1615 : golsen 1.24 sub newick_relabel_tips_i2
1616 :     {
1617 : golsen 1.1 my ( $node, $new_name ) = @_;
1618 :    
1619 :     my @desc = newick_desc_list( $node );
1620 :    
1621 :     if ( @desc ) {
1622 :     foreach ( @desc ) { newick_relabel_tips_i2( $_, $new_name ) }
1623 :     }
1624 :     else {
1625 : golsen 1.24 my ( $new );
1626 :     if ( node_has_lbl( $node ) && defined( $new = $new_name->{ lc newick_lbl( $node ) } ) ) {
1627 : golsen 1.1 set_newick_lbl( $node, $new );
1628 :     }
1629 :     }
1630 :    
1631 :     $node;
1632 :     }
1633 :    
1634 :    
1635 :     #-------------------------------------------------------------------------------
1636 :     # Set undefined branch lenghts (except root) to length x.
1637 :     #
1638 :     # $n_changed = newick_set_undefined_branches( $node, $x )
1639 : golsen 1.24 #
1640 : golsen 1.1 #-------------------------------------------------------------------------------
1641 : golsen 1.24 sub newick_set_undefined_branches
1642 :     {
1643 : golsen 1.1 my ( $node, $x, $not_root ) = @_;
1644 :    
1645 :     my $n = 0;
1646 :     if ( $not_root && ! defined( newick_x( $node ) ) ) {
1647 :     set_newick_x( $node, $x );
1648 :     $n++;
1649 :     }
1650 :    
1651 :     foreach ( newick_desc_list( $node ) ) {
1652 :     $n += newick_set_undefined_branches( $_, $x, 1 );
1653 :     }
1654 :    
1655 :     $n;
1656 :     }
1657 :    
1658 :    
1659 :     #-------------------------------------------------------------------------------
1660 :     # Set all branch lenghts (except root) to length x.
1661 :     #
1662 :     # $n_changed = newick_set_all_branches( $node, $x )
1663 : golsen 1.24 #
1664 : golsen 1.1 #-------------------------------------------------------------------------------
1665 : golsen 1.24 sub newick_set_all_branches
1666 :     {
1667 : golsen 1.1 my ( $node, $x, $not_root ) = @_;
1668 :    
1669 :     my $n = 0;
1670 : overbeek 1.7 if ( $not_root )
1671 :     {
1672 : golsen 1.1 set_newick_x( $node, $x );
1673 :     $n++;
1674 :     }
1675 :    
1676 : overbeek 1.7 foreach ( newick_desc_list( $node ) )
1677 :     {
1678 : golsen 1.1 $n += newick_set_all_branches( $_, $x, 1 );
1679 :     }
1680 :    
1681 :     $n;
1682 :     }
1683 :    
1684 :    
1685 :     #-------------------------------------------------------------------------------
1686 : overbeek 1.7 # Rescale all branch lenghts by factor.
1687 :     #
1688 :     # $node = newick_rescale_branches( $node, $factor )
1689 : golsen 1.24 #
1690 : overbeek 1.7 #-------------------------------------------------------------------------------
1691 : golsen 1.24 sub newick_rescale_branches
1692 :     {
1693 : overbeek 1.7 my ( $node, $factor ) = @_;
1694 :    
1695 :     my $x = newick_x( $node );
1696 :     set_newick_x( $node, $factor * $x ) if $x;
1697 :    
1698 :     foreach ( newick_desc_list( $node ) )
1699 :     {
1700 :     newick_rescale_branches( $_, $factor );
1701 :     }
1702 :    
1703 :     $node;
1704 :     }
1705 :    
1706 :    
1707 :     #-------------------------------------------------------------------------------
1708 : golsen 1.24 # Set all branch lenghts (except root) to random number between x1 and x2.
1709 :     #
1710 :     # $node = newick_random_branch_lengths( $node, $x1, $x2 )
1711 :     #
1712 :     #-------------------------------------------------------------------------------
1713 :     sub newick_random_branch_lengths
1714 :     {
1715 :     my ( $node, $x1, $x2 ) = @_;
1716 :     return undef if ! array_ref( $node );
1717 :     $x1 = 0 if ! defined( $x1 ) || $x1 < 0;
1718 :     $x2 = $x1 + 1 if ! defined( $x2 ) || $x2 < $x1;
1719 :     newick_random_branch_lengths_0( $node, $x1, $x2, 0 );
1720 :     }
1721 :    
1722 :    
1723 :     sub newick_random_branch_lengths_0
1724 :     {
1725 :     my ( $node, $x1, $x2, $not_root ) = @_;
1726 :    
1727 :     set_newick_x( $node, rand($x2-$x1) + $x1 ) if ( $not_root );
1728 :     foreach ( newick_desc_list( $node ) ) { newick_random_branch_lengths_0( $_, $x1, $x2, 1 ) }
1729 :    
1730 :     $node;
1731 :     }
1732 :    
1733 :    
1734 :     #-------------------------------------------------------------------------------
1735 : golsen 1.15 # Modify all branch lengths by a function.
1736 :     #
1737 :     # $node = newick_modify_branches( $node, \&function )
1738 :     # $node = newick_modify_branches( $node, \&function, \@func_parms )
1739 :     #
1740 :     # Function must have form
1741 :     #
1742 :     # $x2 = &$function( $x1 )
1743 :     # $x2 = &$function( $x1, @$func_parms )
1744 :     #
1745 :     #-------------------------------------------------------------------------------
1746 : golsen 1.24 sub newick_modify_branches
1747 :     {
1748 : golsen 1.15 my ( $node, $func, $parm ) = @_;
1749 :    
1750 :     set_newick_x( $node, &$func( newick_x( $node ), ( $parm ? @$parm : () ) ) );
1751 :     foreach ( newick_desc_list( $node ) )
1752 :     {
1753 :     newick_modify_branches( $_, $func, $parm )
1754 :     }
1755 :    
1756 :     $node;
1757 :     }
1758 :    
1759 :    
1760 :     #-------------------------------------------------------------------------------
1761 : golsen 1.5 # Set negative branches to zero. The original tree is modfied.
1762 :     #
1763 :     # $n_changed = newick_fix_negative_branches( $tree )
1764 : golsen 1.24 #
1765 : golsen 1.5 #-------------------------------------------------------------------------------
1766 : golsen 1.24 sub newick_fix_negative_branches
1767 :     {
1768 : golsen 1.5 my ( $tree ) = @_;
1769 :     array_ref( $tree ) or return undef;
1770 :     my $n_changed = 0;
1771 :     my $x = newick_x( $tree );
1772 :     if ( defined( $x ) and $x < 0 )
1773 :     {
1774 :     set_newick_x( $tree, 0 );
1775 :     $n_changed++;
1776 :     }
1777 :    
1778 :     foreach ( newick_desc_list( $tree ) )
1779 :     {
1780 :     $n_changed += newick_fix_negative_branches( $_ );
1781 :     }
1782 :    
1783 :     $n_changed;
1784 :     }
1785 :    
1786 :    
1787 :     #-------------------------------------------------------------------------------
1788 : golsen 1.8 # Remove comments from a newick tree (e.g., before writing for phylip).
1789 :     #
1790 :     # $node = newick_strip_comments( $node )
1791 : golsen 1.24 #
1792 : golsen 1.8 #-------------------------------------------------------------------------------
1793 : golsen 1.24 sub newick_strip_comments
1794 :     {
1795 : golsen 1.8 my ( $node ) = @_;
1796 :    
1797 :     @$node = @$node[ 0 .. 2 ];
1798 :     foreach ( newick_desc_list( $node ) ) { newick_strip_comments( $_ ) }
1799 :     $node;
1800 :     }
1801 :    
1802 :    
1803 :     #-------------------------------------------------------------------------------
1804 : golsen 1.1 # Normalize tree order (in place).
1805 :     #
1806 :     # ( $tree, $label1 ) = normalize_newick_tree( $tree )
1807 : golsen 1.24 #
1808 : golsen 1.1 #-------------------------------------------------------------------------------
1809 : golsen 1.24 sub normalize_newick_tree
1810 :     {
1811 : golsen 1.1 my ( $node ) = @_;
1812 :    
1813 :     my @descends = newick_desc_list( $node );
1814 :     if ( @descends == 0 ) { return ( $node, lc newick_lbl( $node ) ) }
1815 :    
1816 : golsen 1.9 my %hash = map { ( normalize_newick_tree($_) )[1] => $_ } @descends;
1817 : golsen 1.1 my @keylist = sort { $a cmp $b } keys %hash;
1818 :     set_newick_desc_list( $node, map { $hash{$_} } @keylist );
1819 :    
1820 :     ( $node, $keylist[0] );
1821 :     }
1822 :    
1823 :    
1824 :     #-------------------------------------------------------------------------------
1825 :     # Reverse tree order (in place).
1826 :     #
1827 :     # $tree = reverse_newick_tree( $tree )
1828 : golsen 1.24 #
1829 : golsen 1.1 #-------------------------------------------------------------------------------
1830 : golsen 1.24 sub reverse_newick_tree
1831 :     {
1832 : golsen 1.1 my ( $node ) = @_;
1833 :    
1834 :     my @descends = newick_desc_list( $node );
1835 :     if ( @descends ) {
1836 :     set_newick_desc_list( $node, reverse @descends );
1837 :     foreach ( @descends ) { reverse_newick_tree( $_ ) }
1838 :     }
1839 :     $node;
1840 :     }
1841 :    
1842 :    
1843 :     #-------------------------------------------------------------------------------
1844 :     # Standard unrooted tree (in place).
1845 :     #
1846 :     # $stdtree = std_unrooted_newick( $tree )
1847 : golsen 1.24 #
1848 : golsen 1.1 #-------------------------------------------------------------------------------
1849 : golsen 1.24 sub std_unrooted_newick
1850 :     {
1851 : golsen 1.1 my ( $tree ) = @_;
1852 :    
1853 :     my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
1854 :     ( normalize_newick_tree( reroot_newick_next_to_tip( $tree, $mintip ) ) )[0];
1855 :     }
1856 :    
1857 :    
1858 :     #-------------------------------------------------------------------------------
1859 : golsen 1.20 # Standard name for a Newick tree topology
1860 :     #
1861 :     # $stdname = std_tree_name( $tree )
1862 :     #
1863 :     #-------------------------------------------------------------------------------
1864 :     sub std_tree_name
1865 :     {
1866 :     my ( $tree ) = @_;
1867 :     my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
1868 :     ( std_tree_name_2( reroot_newick_next_to_tip( copy_newick_tree( $tree ), $mintip ) ) )[0];
1869 :     }
1870 :    
1871 :    
1872 :     #
1873 :     # ( $name, $mintip ) = std_tree_name_2( $node )
1874 :     #
1875 :     sub std_tree_name_2
1876 :     {
1877 :     my ( $node ) = @_;
1878 :    
1879 :     my @descends = newick_desc_list( $node );
1880 :     if ( @descends == 0 )
1881 :     {
1882 :     my $lbl = newick_lbl( $node );
1883 :     return ( $lbl, $lbl );
1884 :     }
1885 :    
1886 :     my @list = sort { lc $a->[1] cmp lc $b->[1] || $a->[1] cmp $b->[1] }
1887 :     map { [ std_tree_name_2( $_ ) ] }
1888 :     @descends;
1889 :     my $mintip = $list[0]->[1];
1890 :     my $name = '(' . join( "\t", map { $_->[0] } @list ) . ')';
1891 :    
1892 :     return ( $name, $mintip );
1893 :     }
1894 :    
1895 :    
1896 :     #-------------------------------------------------------------------------------
1897 : golsen 1.1 # Move largest groups to periphery of tree (in place).
1898 :     #
1899 : golsen 1.24 # $tree = aesthetic_newick_tree( $treeref, $dir )
1900 :     #
1901 : golsen 1.1 # dir <= -2 for up-sweeping tree (big groups always first),
1902 :     # = -1 for big group first, balanced tree,
1903 :     # = 0 for balanced tree,
1904 :     # = 1 for small group first, balanced tree, and
1905 :     # >= 2 for down-sweeping tree (small groups always top)
1906 :     #
1907 :     #-------------------------------------------------------------------------------
1908 : golsen 1.24 sub aesthetic_newick_tree
1909 :     {
1910 : golsen 1.1 my ( $tree, $dir ) = @_;
1911 :     my %cnt;
1912 :    
1913 :     $dir = ! $dir ? 0 : # Undefined or zero
1914 :     $dir <= -2 ? -1000000 :
1915 :     $dir < 0 ? -1 :
1916 :     $dir >= 2 ? 1000000 :
1917 :     1 ;
1918 :     build_tip_count_hash( $tree, \%cnt );
1919 :     reorder_by_tip_count( $tree, \%cnt, $dir );
1920 :     }
1921 :    
1922 :    
1923 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1924 :     # Build a hash to look up the number of descendants of each node.
1925 :     # Access count with $cntref->{$noderef}
1926 :     #
1927 :     # $count = build_tip_count_hash( $node, $cnt_hash_ref )
1928 : golsen 1.24 #
1929 : golsen 1.1 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1930 : golsen 1.24 sub build_tip_count_hash
1931 :     {
1932 : golsen 1.1 my ( $node, $cntref ) = @_;
1933 :     my ( $i, $cnt );
1934 :    
1935 :     if ( newick_n_desc( $node ) < 1 ) { $cnt = 1 }
1936 :     else {
1937 :     $cnt = 0;
1938 :     foreach ( newick_desc_list( $node ) ) {
1939 :     $cnt += build_tip_count_hash( $_, $cntref );
1940 :     }
1941 :     }
1942 :    
1943 :     $cntref->{$node} = $cnt;
1944 :     $cnt;
1945 :     }
1946 :    
1947 :    
1948 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1949 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
1950 :     # dir < 0 for upward branch (big group first),
1951 :     # = 0 for no change, and
1952 :     # > 0 for downward branch (small group first).
1953 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1954 : golsen 1.24 sub reorder_by_tip_count
1955 :     {
1956 : golsen 1.1 my ( $node, $cntref, $dir ) = @_;
1957 :    
1958 :     my $nd = newick_n_desc( $node );
1959 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1960 :    
1961 : golsen 1.16 my $dl_ref = newick_desc_ref( $node );
1962 :    
1963 :     # Reorder this subtree (biggest subtrees to outside)
1964 :    
1965 :     if ( $dir )
1966 :     {
1967 :     # Big group first
1968 :     my @dl = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1969 :    
1970 :     my ( @dl1, @dl2 );
1971 :     for ( my $i = 0; $i < $nd; $i++ ) {
1972 :     if ( $i & 1 ) { push @dl2, $dl[$i] } else { push @dl1, $dl[$i] }
1973 :     }
1974 : golsen 1.1
1975 : golsen 1.16 @$dl_ref = ( $dir < 0 ) ? ( @dl1, reverse @dl2 )
1976 :     : ( @dl2, reverse @dl1 );
1977 : golsen 1.1 }
1978 :    
1979 :     # Reorder within descendant subtrees:
1980 :    
1981 :     my $step = 0;
1982 :     if ( abs( $dir ) < 1e5 ) {
1983 :     $dir = 1 - $nd; # Midgroup => as is
1984 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1985 :     $step = 2;
1986 :     }
1987 :    
1988 :     for ( my $i = 0; $i < $nd; $i++ ) {
1989 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1990 :     $dir += $step;
1991 :     }
1992 :    
1993 :     $node;
1994 :     }
1995 :    
1996 :    
1997 :     #-------------------------------------------------------------------------------
1998 :     # Move smallest groups to periphery of tree (in place).
1999 :     #
2000 : golsen 1.24 # $tree = unaesthetic_newick_tree( $treeref, $dir )
2001 :     #
2002 : golsen 1.1 # dir <= -2 for up-sweeping tree (big groups always first),
2003 :     # = -1 for big group first, balanced tree,
2004 :     # = 0 for balanced tree,
2005 :     # = 1 for small group first, balanced tree, and
2006 :     # >= 2 for down-sweeping tree (small groups always top)
2007 :     #
2008 :     #-------------------------------------------------------------------------------
2009 : golsen 1.9 sub unaesthetic_newick_tree
2010 :     {
2011 : golsen 1.1 my ( $tree, $dir ) = @_;
2012 :     my %cnt;
2013 :    
2014 :     $dir = ! $dir ? 0 : # Undefined or zero
2015 :     $dir <= -2 ? -1000000 :
2016 :     $dir < 0 ? -1 :
2017 :     $dir >= 2 ? 1000000 :
2018 :     1 ;
2019 :     build_tip_count_hash( $tree, \%cnt );
2020 :     reorder_against_tip_count( $tree, \%cnt, $dir );
2021 :     }
2022 :    
2023 :    
2024 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2025 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
2026 :     # dir < 0 for upward branch (big group first),
2027 :     # = 0 for no change, and
2028 :     # > 0 for downward branch (small group first).
2029 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2030 : golsen 1.9 sub reorder_against_tip_count
2031 :     {
2032 : golsen 1.1 my ( $node, $cntref, $dir ) = @_;
2033 :    
2034 :     my $nd = newick_n_desc( $node );
2035 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
2036 :    
2037 :     # Reorder this subtree:
2038 :    
2039 :     my $dl_ref = newick_desc_ref( $node );
2040 :     if ( $dir > 0 ) { # Big group first
2041 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
2042 :     }
2043 :     elsif ( $dir < 0 ) { # Small group first
2044 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
2045 :     }
2046 :    
2047 :     # Reorder within descendant subtrees:
2048 :    
2049 :     my $step = 0;
2050 :     if (abs( $dir ) < 1e5) {
2051 :     $dir = 1 - $nd; # Midgroup => as is
2052 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
2053 :     $step = 2;
2054 :     }
2055 :    
2056 :     for ( my $i = 0; $i < $nd; $i++ ) {
2057 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
2058 :     $dir += $step;
2059 :     }
2060 :    
2061 :     $node;
2062 :     }
2063 :    
2064 :    
2065 :     #-------------------------------------------------------------------------------
2066 :     # Randomize descendant order at each node (in place).
2067 :     #
2068 :     # $tree = random_order_newick_tree( $tree )
2069 : golsen 1.24 #
2070 : golsen 1.1 #-------------------------------------------------------------------------------
2071 : golsen 1.9 sub random_order_newick_tree
2072 :     {
2073 : golsen 1.1 my ( $node ) = @_;
2074 :    
2075 :     my $nd = newick_n_desc( $node );
2076 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
2077 :    
2078 :     # Reorder this subtree:
2079 :    
2080 :     my $dl_ref = newick_desc_ref( $node );
2081 : golsen 1.9 @$dl_ref = &random_order( @$dl_ref );
2082 : golsen 1.1
2083 :     # Reorder descendants:
2084 :    
2085 :     foreach ( @$dl_ref ) { random_order_newick_tree( $_ ) }
2086 :    
2087 :     $node;
2088 :     }
2089 :    
2090 :    
2091 :     #-------------------------------------------------------------------------------
2092 : golsen 1.24 # Reroot a tree using method specified by options.
2093 :     #
2094 :     # $newtree = reroot_tree( $tree, \%options )
2095 :     #
2096 :     # Options
2097 :     #
2098 :     # adjacent_to_tip => $tip # root next to named tip (no nodes)
2099 :     # adjacent_to_tip => $bool # root next to tip defined by nodes
2100 :     # distance => $distance # distance on path from node1 to node2
2101 :     # fraction => $fraction # fraction of path from node1 to node2
2102 :     # midpoint => $bool # midpoint root tree (no nodes)
2103 :     # node => $node_spec # just one node spec
2104 :     # nodes => \@node_specs # 0, 1 or 2 node specifiers
2105 :     # tip => $tip # short way to get tip root
2106 :     #
2107 :     # node_spec can be 1, 2 or 3 node labels:
2108 :     #
2109 :     # With 1 label, it is the node with that name (tip or internal)
2110 :     # With 2 labels, it is the most recent common ancestor of the 2 named nodes
2111 :     # With 3 labels, it is the intersection point of the paths to the 3 nodes
2112 :     #
2113 :     #-------------------------------------------------------------------------------
2114 :     sub reroot_tree
2115 :     {
2116 :     my ( $tree, $opts ) = @_;
2117 :     return undef if ! array_ref( $tree );
2118 :     $opts ||= {};
2119 :    
2120 :     return reroot_newick_to_midpoint_w( $tree ) if $opts->{ midpoint };
2121 :    
2122 :     # All other options require 1 or 2 node specifiers
2123 :    
2124 :     my @nodes = array_ref( $opts->{ nodes } ) ? @{ $opts->{ nodes } } : ();
2125 :     push @nodes, $opts->{ node } if array_ref( $opts->{ node } );
2126 :    
2127 :     foreach ( @nodes )
2128 :     {
2129 :     next if ( array_ref( $_ ) && ( @$_ > 0 ) && ( @$_ <= 3 ) );
2130 :     print STDERR "Bad node specifier passed to gjonewicklib::reroot_tree().\n";
2131 :     return $tree;
2132 :     }
2133 :    
2134 :     my $adj_to_tip = $opts->{ adjacent_to_tip };
2135 :     my $distance = $opts->{ distance };
2136 :     my $fraction = $opts->{ fraction };
2137 :     my $tip = $opts->{ tip };
2138 :    
2139 :     if ( defined( $distance ) )
2140 :     {
2141 :     return $tree if @nodes != 2;
2142 :     $distance = 0 if $distance < 0;
2143 :     $tree = reroot_newick_at_dist_between_nodes( $tree, @nodes, $distance )
2144 :     }
2145 :     elsif ( @nodes == 2 )
2146 :     {
2147 :     $fraction = 0.5 if ! defined( $fraction );
2148 :     $fraction = 0 if $fraction < 0;
2149 :     $fraction = 1 if $fraction > 1;
2150 :     $tree = reroot_newick_between_nodes( $tree, @nodes, $fraction )
2151 :     }
2152 :     elsif ( $adj_to_tip )
2153 :     {
2154 :     $adj_to_tip = $nodes[0]->[0] if @nodes == 1 && @{$nodes[0]} == 1;
2155 :     $tree = reroot_newick_next_to_tip( $tree, $adj_to_tip );
2156 :     }
2157 :     elsif ( @nodes == 1 )
2158 :     {
2159 :     # Root at node:
2160 :     $tree = reroot_newick_to_node( $tree, $nodes[0] );
2161 :     }
2162 :     elsif ( defined( $tip ) && $tip ne '' )
2163 :     {
2164 :     # Root at tip:
2165 :     $tree = reroot_newick_to_tip( $tree, $tip );
2166 :     }
2167 :    
2168 :     return $tree;
2169 :     }
2170 :    
2171 :    
2172 :     #-------------------------------------------------------------------------------
2173 : golsen 1.1 # Reroot a tree to the node that lies at the end of a path.
2174 :     #
2175 :     # $newtree = reroot_newick_by_path( @path )
2176 : golsen 1.24 #
2177 : golsen 1.1 #-------------------------------------------------------------------------------
2178 : golsen 1.9 sub reroot_newick_by_path
2179 :     {
2180 : golsen 1.1 my ( $node1, $path1, @rest ) = @_;
2181 :     array_ref( $node1 ) || return undef; # Always expect a node
2182 :    
2183 :     defined( $path1 ) && @rest || return $node1; # If no path, we're done
2184 :    
2185 :     my $node2 = $rest[0]; # Next element in path is node 2
2186 :     newick_desc_i( $node1, $path1 ) eq $node2 || return undef; # Check link
2187 :    
2188 :     # Remove node 2 from node 1 descendant list. Could use a simple splice:
2189 :     #
2190 :     # splice( @$dl1, $path1-1, 1 );
2191 :     #
2192 : golsen 1.8 # But the following maintains the cyclic order of the nodes:
2193 : golsen 1.1
2194 :     my $dl1 = newick_desc_ref( $node1 );
2195 :     my $nd1 = @$dl1;
2196 :     if ( $path1 == 1 ) { shift @$dl1 }
2197 :     elsif ( $path1 == $nd1 ) { pop @$dl1 }
2198 :     else { @$dl1 = ( @$dl1[ $path1 .. $nd1-1 ]
2199 :     , @$dl1[ 0 .. $path1-2 ]
2200 :     )
2201 : golsen 1.8 }
2202 : golsen 1.1
2203 :     # Append node 1 to node 2 descendant list (does not alter numbering):
2204 :    
2205 :     my $dl2 = newick_desc_ref( $node2 );
2206 :     if ( array_ref( $dl2 ) ) { push @$dl2, $node1 }
2207 : golsen 1.8 else { set_newick_desc_list( $node2, $node1 ) }
2208 : golsen 1.1
2209 :     # Move c1 comments from node 1 to node 2:
2210 :    
2211 :     my $C11 = newick_c1( $node1 );
2212 :     my $C12 = newick_c1( $node2 );
2213 :     ! defined( $C11 ) || set_newick_c1( $node1, undef ); # Remove them from node 1
2214 : golsen 1.8 if ( $C12 && @$C12 ) { # If node 2 comments and
2215 :     if ( $C11 && @$C11 ) { unshift @$C12, @$C11 } # Node 1, prefix 1 to 2
2216 : golsen 1.1 }
2217 : golsen 1.8 elsif ( $C11 && @$C11 ) { set_newick_c1( $node2, $C11 ) } # Otherwise move node 1 link
2218 : golsen 1.1
2219 :     # Swap branch lengths and comments for reversal of link direction:
2220 :    
2221 :     my $x1 = newick_x( $node1 );
2222 :     my $x2 = newick_x( $node2 );
2223 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node1, $x2 );
2224 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node2, $x1 );
2225 :    
2226 :     my $c41 = newick_c4( $node1 );
2227 :     my $c42 = newick_c4( $node2 );
2228 :     ! defined( $c42 ) || ! @$c42 || set_newick_c4( $node1, $c42 );
2229 :     ! defined( $c41 ) || ! @$c41 || set_newick_c4( $node2, $c41 );
2230 :    
2231 :     my $c51 = newick_c5( $node1 );
2232 :     my $c52 = newick_c5( $node2 );
2233 :     ! defined( $c52 ) || ! @$c52 || set_newick_c5( $node1, $c52 );
2234 :     ! defined( $c51 ) || ! @$c51 || set_newick_c5( $node2, $c51 );
2235 :    
2236 :     reroot_newick_by_path( @rest ); # Node 2 is first element of rest
2237 :     }
2238 :    
2239 :    
2240 :     #-------------------------------------------------------------------------------
2241 :     # Move root of tree to named tip.
2242 :     #
2243 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
2244 : golsen 1.24 #
2245 : golsen 1.1 #-------------------------------------------------------------------------------
2246 : golsen 1.24 sub reroot_newick_to_tip
2247 :     {
2248 : golsen 1.1 my ( $tree, $tipname ) = @_;
2249 :     reroot_newick_by_path( path_to_tip( $tree, $tipname ) );
2250 :     }
2251 :    
2252 :    
2253 :     #-------------------------------------------------------------------------------
2254 :     # Move root of tree to be node adjacent to a named tip.
2255 :     #
2256 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
2257 : golsen 1.24 #
2258 : golsen 1.1 #-------------------------------------------------------------------------------
2259 : golsen 1.24 sub reroot_newick_next_to_tip
2260 :     {
2261 : golsen 1.1 my ( $tree, $tipname ) = @_;
2262 :     my @path = path_to_tip( $tree, $tipname );
2263 :     @path || return undef;
2264 :     @path == 1 ? reroot_newick_by_path( $tree, 1, newick_desc_i( $tree, 1 ) )
2265 : golsen 1.24 : reroot_newick_by_path( @path[ 0 .. @path-3 ] );
2266 : golsen 1.1 }
2267 :    
2268 :    
2269 :     #-------------------------------------------------------------------------------
2270 :     # Move root of tree to a node, defined by 1 or 3 tip names.
2271 :     #
2272 :     # $newtree = reroot_newick_to_node( $tree, @node )
2273 : golsen 1.24 #
2274 : golsen 1.1 #-------------------------------------------------------------------------------
2275 : golsen 1.24 sub reroot_newick_to_node
2276 :     {
2277 : golsen 1.1 reroot_newick_by_path( path_to_node( @_ ) );
2278 :     }
2279 :    
2280 :    
2281 :     #-------------------------------------------------------------------------------
2282 :     # Move root of tree to a node, defined by reference.
2283 :     #
2284 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
2285 : golsen 1.24 #
2286 : golsen 1.1 #-------------------------------------------------------------------------------
2287 : golsen 1.24 sub reroot_newick_to_node_ref
2288 :     {
2289 : golsen 1.1 my ( $tree, $node ) = @_;
2290 :     reroot_newick_by_path( path_to_node_ref( $tree, $node ) );
2291 :     }
2292 :    
2293 :    
2294 :     #-------------------------------------------------------------------------------
2295 : golsen 1.9 # Reroot a newick tree along the path between 2 nodes:
2296 :     #
2297 :     # $tree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
2298 : golsen 1.24 #
2299 : golsen 1.9 #-------------------------------------------------------------------------------
2300 :     sub reroot_newick_between_nodes
2301 :     {
2302 :     my ( $tree, $node1, $node2, $fraction ) = @_;
2303 :     array_ref( $tree ) or return undef;
2304 :    
2305 :     # Find the paths to the nodes:
2306 :    
2307 : golsen 1.24 my @path1 = path_to_node( $tree, $node1 ) or return $tree;
2308 :     my @path2 = path_to_node( $tree, $node2 ) or return $tree;
2309 : golsen 1.9
2310 : golsen 1.24 reroot_newick_between_nodes_by_path( \@path1, \@path2, $fraction )
2311 : golsen 1.12 }
2312 :    
2313 :    
2314 :     #-------------------------------------------------------------------------------
2315 :     # Reroot a newick tree along the path between 2 nodes:
2316 :     #
2317 :     # $tree = reroot_newick_between_node_refs( $tree, $node1, $node2, $fraction )
2318 : golsen 1.24 #
2319 : golsen 1.12 #-------------------------------------------------------------------------------
2320 :     sub reroot_newick_between_node_refs
2321 :     {
2322 :     my ( $tree, $node1, $node2, $fraction ) = @_;
2323 :     array_ref( $tree ) or return undef;
2324 :    
2325 :     # Find the paths to the nodes:
2326 :    
2327 : golsen 1.24 my @path1 = path_to_node_ref( $tree, $node1 ) or return $tree;
2328 :     my @path2 = path_to_node_ref( $tree, $node2 ) or return $tree;
2329 : golsen 1.12
2330 : golsen 1.24 reroot_newick_between_nodes_by_path( \@path1, \@path2, $fraction )
2331 : golsen 1.12 }
2332 :    
2333 :    
2334 :     #-------------------------------------------------------------------------------
2335 :     # Reroot a newick tree along the path between 2 nodes defined by paths:
2336 :     #
2337 : golsen 1.24 # $tree = reroot_newick_between_nodes_by_path( $path1, $path2, $fraction )
2338 :     #
2339 : golsen 1.12 #-------------------------------------------------------------------------------
2340 :     sub reroot_newick_between_nodes_by_path
2341 :     {
2342 : golsen 1.24 my ( $path1, $path2, $fraction ) = @_;
2343 :     array_ref( $path1 ) && array_ref( $path2 ) or return undef;
2344 :    
2345 :     $fraction = 0 if ( ! defined( $fraction ) ) || ( $fraction < 0 );
2346 :     $fraction = 1 if ( $fraction > 1 );
2347 :    
2348 :     my $prefix;
2349 :     ( $prefix, $path1, $path2 ) = common_and_unique_paths( $path1, $path2 );
2350 :    
2351 :     my $dist1 = ( @$path1 >= 3 ) ? newick_path_length( @$path1 ) : 0;
2352 :     my $dist2 = ( @$path2 >= 3 ) ? newick_path_length( @$path2 ) : 0;
2353 :    
2354 :     # Case where there is no length (possibly same node):
2355 :    
2356 :     return reroot_newick_by_path( @$prefix, $path1->[0] ) if $dist1 + $dist2 <= 0;
2357 :    
2358 :     my $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
2359 :     my $path = ( $dist <= 0 ) ? $path1 : $path2;
2360 :     $dist = abs( $dist );
2361 :    
2362 :     # Descend tree until we reach the insertion branch:
2363 :    
2364 :     reroot_newick_at_dist_along_path( $prefix, $path, $dist );
2365 :     }
2366 :    
2367 :    
2368 :     #-------------------------------------------------------------------------------
2369 :     # Reroot a newick tree along the path between 2 nodes:
2370 :     #
2371 :     # $tree = reroot_newick_at_dist_between_nodes( $tree, $node1, $node2, $distance )
2372 :     #
2373 :     #-------------------------------------------------------------------------------
2374 :     sub reroot_newick_at_dist_between_nodes
2375 :     {
2376 :     my ( $tree, $node1, $node2, $distance ) = @_;
2377 :     array_ref( $tree ) or return undef;
2378 :    
2379 :     # Find the paths to the nodes:
2380 :    
2381 :     my @path1 = path_to_node( $tree, $node1 ) or return $tree;
2382 :     my @path2 = path_to_node( $tree, $node2 ) or return $tree;
2383 :    
2384 :     reroot_newick_at_dist_between_nodes_by_path( \@path1, \@path2, $distance );
2385 :     }
2386 :    
2387 :    
2388 :     #-------------------------------------------------------------------------------
2389 :     # Reroot a newick tree along the path between 2 nodes identified by ref:
2390 :     #
2391 :     # $tree = reroot_newick_at_dist_between_node_refs( $tree, $node1, $node2, $distance )
2392 :     #
2393 :     #-------------------------------------------------------------------------------
2394 :     sub reroot_newick_at_dist_between_node_refs
2395 :     {
2396 :     my ( $tree, $node1, $node2, $distance ) = @_;
2397 :     array_ref( $tree ) or return undef;
2398 :    
2399 :     # Find the paths to the nodes:
2400 :    
2401 :     my @path1 = path_to_node_ref( $tree, $node1 ) or return $tree;
2402 :     my @path2 = path_to_node_ref( $tree, $node2 ) or return $tree;
2403 :    
2404 :     reroot_newick_at_dist_between_nodes_by_path( \@path1, \@path2, $distance );
2405 :     }
2406 :    
2407 :    
2408 :     #-------------------------------------------------------------------------------
2409 :     # Reroot a newick tree along the path between 2 nodes defined by paths:
2410 :     #
2411 :     # $tree = reroot_newick_at_dist_between_nodes_by_path( $path1, $path2, $distance )
2412 :     #
2413 :     #-------------------------------------------------------------------------------
2414 :     sub reroot_newick_at_dist_between_nodes_by_path
2415 :     {
2416 :     my ( $path1, $path2, $distance ) = @_;
2417 :     array_ref( $path1 ) && array_ref( $path2 ) or return undef;
2418 :     $distance = 0 if ( ! defined( $distance ) ) || ( $distance < 0 );
2419 :    
2420 :     my $prefix;
2421 :     ( $prefix, $path1, $path2 ) = common_and_unique_paths( $path1, $path2 );
2422 : golsen 1.12
2423 : golsen 1.24 my $dist1 = ( @$path1 >= 3 ) ? newick_path_length( @$path1 ) : 0;
2424 :     my $dist2 = ( @$path2 >= 3 ) ? newick_path_length( @$path2 ) : 0;
2425 : golsen 1.12
2426 : golsen 1.24 # Case where there is no length (possibly same node):
2427 : golsen 1.9
2428 : golsen 1.24 return reroot_newick_by_path( @$prefix, $path1->[0] ) if $dist1 + $dist2 <= 0;
2429 : golsen 1.9
2430 : golsen 1.24 my ( $path, $dist );
2431 :     if ( $distance < $dist1 )
2432 : golsen 1.9 {
2433 : golsen 1.24 $path = $path1;
2434 :     $dist = $dist1 - $distance;
2435 : golsen 1.9 }
2436 :     else
2437 :     {
2438 : golsen 1.24 $path = $path2;
2439 :     $dist = $distance - $dist1;
2440 : golsen 1.9 }
2441 :    
2442 :     # Descend tree until we reach the insertion branch:
2443 :    
2444 : golsen 1.24 reroot_newick_at_dist_along_path( $prefix, $path, $dist );
2445 :     }
2446 :    
2447 :    
2448 :     #-------------------------------------------------------------------------------
2449 :     # Reroot a newick tree along the path between 2 nodes defined by paths:
2450 :     #
2451 :     # ( \@common, \@unique1, \@unique2 ) = common_and_unique_paths( \@path1, \@path2 )
2452 :     #
2453 :     #-------------------------------------------------------------------------------
2454 :     sub common_and_unique_paths
2455 :     {
2456 :     my ( $path1, $path2 ) = @_;
2457 :    
2458 :     my @path1 = @$path1;
2459 :     my @path2 = @$path2;
2460 :    
2461 :     # Trim the common prefix, saving it:
2462 :    
2463 :     my $i = 1;
2464 :     my $imax = min( scalar @path1, scalar @path2 );
2465 :     while ( ( $i < $imax ) && ( $path1[$i] == $path2[$i] ) ) { $i += 2 }
2466 :    
2467 :     my @prefix = ();
2468 :     if ( $i > 1 ) { @prefix = splice( @path1, 0, $i-1 ); splice( @path2, 0, $i-1 ) }
2469 :    
2470 :     ( \@prefix, \@path1, \@path2 );
2471 :     }
2472 :    
2473 :    
2474 :     #-------------------------------------------------------------------------------
2475 :     # Reroot a newick tree at a distance from the most ancestral node along a path:
2476 :     #
2477 :     # $tree = reroot_newick_at_dist_along_path( \@prefix, \@path, $distance )
2478 :     #
2479 :     # - n1 n1
2480 :     # | / \ / \
2481 :     # | \ x2 \ x2
2482 :     # | \ \
2483 :     # | dist n2 n2
2484 :     # | / \ / \ x23 = dist - x2
2485 :     # | \ \
2486 :     # ----------- \ x3 -------- n23
2487 :     # \ / \ x3' = x3 - x23
2488 :     # n3 n3
2489 :     # / \ / \
2490 :     #
2491 :     #-------------------------------------------------------------------------------
2492 :     sub reroot_newick_at_dist_along_path
2493 :     {
2494 :     my ( $prefix, $path, $dist ) = @_;
2495 :     array_ref( $prefix ) or return undef;
2496 :     array_ref( $path ) or return $prefix->[0];
2497 :     defined( $dist ) or $dist = 0;
2498 :    
2499 :     my @prefix = @$prefix;
2500 :     my @path = @$path;
2501 :    
2502 :     # Descend tree until we reach the insertion branch:
2503 :    
2504 :     my $x = ( @path > 2 ) ? newick_x( $path[2] ) : 0;
2505 :     while ( ( @path > 4 ) && ( $dist > $x ) )
2506 : golsen 1.9 {
2507 :     $dist -= $x;
2508 :     push @prefix, splice( @path, 0, 2 );
2509 : golsen 1.24 $x = newick_x( $path[2] );
2510 : golsen 1.9 }
2511 : golsen 1.24 $dist = $x if ( $dist > $x );
2512 : golsen 1.9
2513 :     # Insert the new node:
2514 :    
2515 :     my $newnode = [ [ $path[2] ], undef, $dist ];
2516 :     set_newick_desc_i( $path[0], $path[1], $newnode );
2517 : golsen 1.24 set_newick_x( $path[2], $x - $dist );
2518 : golsen 1.9
2519 :     # We can now build the path from root to the new node
2520 :    
2521 :     reroot_newick_by_path( @prefix, @path[0,1], $newnode );
2522 :     }
2523 :    
2524 :    
2525 :     #-------------------------------------------------------------------------------
2526 : golsen 1.1 # Move root of tree to an approximate midpoint.
2527 :     #
2528 :     # $newtree = reroot_newick_to_approx_midpoint( $tree )
2529 : golsen 1.24 #
2530 : golsen 1.1 #-------------------------------------------------------------------------------
2531 : golsen 1.24 sub reroot_newick_to_approx_midpoint
2532 :     {
2533 : golsen 1.1 my ( $tree ) = @_;
2534 : golsen 1.5
2535 : golsen 1.1 # Compile average tip to node distances assending
2536 :    
2537 :     my $dists1 = average_to_tips_1( $tree );
2538 :    
2539 : golsen 1.12 # Compile average tip to node distances descending, returning midpoint
2540 :     # cadidates as a list of [ $node1, $node2, $fraction ]
2541 :    
2542 :     my @mids = average_to_tips_2( $dists1, undef, undef );
2543 :    
2544 :     # Reroot to first midpoint candidate
2545 :    
2546 :     return $tree if ! @mids;
2547 :     my ( $node1, $node2, $fraction ) = @{ $mids[0] };
2548 :     reroot_newick_to_node_ref( $tree, $fraction >= 0.5 ? $node2 : $node1 );
2549 :     }
2550 :    
2551 :    
2552 :     #-------------------------------------------------------------------------------
2553 :     # Move root of tree to a midpoint.
2554 :     #
2555 :     # $newtree = reroot_newick_to_midpoint( $tree )
2556 : golsen 1.24 #
2557 : golsen 1.12 #-------------------------------------------------------------------------------
2558 : golsen 1.24 sub reroot_newick_to_midpoint
2559 :     {
2560 : golsen 1.12 my ( $tree ) = @_;
2561 :    
2562 :     # Compile average tip to node distances assending
2563 :    
2564 :     my $dists1 = average_to_tips_1( $tree );
2565 : golsen 1.1
2566 : golsen 1.12 # Compile average tip to node distances descending, returning midpoint
2567 :     # [ $node1, $node2, $fraction ]
2568 : golsen 1.1
2569 : golsen 1.12 my @mids = average_to_tips_2( $dists1, undef, undef );
2570 : golsen 1.1
2571 : golsen 1.12 @mids ? reroot_newick_between_node_refs( $tree, @{ $mids[0] } ) : $tree;
2572 : golsen 1.1 }
2573 :    
2574 :    
2575 : golsen 1.12 #-------------------------------------------------------------------------------
2576 :     # Compile average tip to node distances assending
2577 :     #-------------------------------------------------------------------------------
2578 : golsen 1.24 sub average_to_tips_1
2579 :     {
2580 : golsen 1.1 my ( $node ) = @_;
2581 :    
2582 :     my @desc_dists = map { average_to_tips_1( $_ ) } newick_desc_list( $node );
2583 :     my $x_below = 0;
2584 :     if ( @desc_dists )
2585 :     {
2586 :     foreach ( @desc_dists ) { $x_below += $_->[0] }
2587 :     $x_below /= @desc_dists;
2588 :     }
2589 : golsen 1.12
2590 : golsen 1.1 my $x = newick_x( $node ) || 0;
2591 :     my $x_net = $x_below + $x;
2592 :    
2593 :     [ $x_net, $x, $x_below, [ @desc_dists ], $node ]
2594 :     }
2595 :    
2596 : golsen 1.9
2597 : golsen 1.12 #-------------------------------------------------------------------------------
2598 :     # Compile average tip to node distances descending, returning midpoint as
2599 :     # [ $node1, $node2, $fraction_of_dist_between ]
2600 :     #-------------------------------------------------------------------------------
2601 : golsen 1.24 sub average_to_tips_2
2602 :     {
2603 : golsen 1.1 my ( $dists1, $x_above, $anc_node ) = @_;
2604 :     my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;
2605 :    
2606 :     # Are we done? Root is in this node's branch, or "above"?
2607 :    
2608 : golsen 1.12 my @mids = ();
2609 : golsen 1.1 if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2610 :     {
2611 :     # At this point the root can only be in this node's branch,
2612 :     # or "above" it in the current rooting of the tree (which
2613 :     # would mean that the midpoint is actually down a different
2614 :     # path from the root of the current tree).
2615 :     #
2616 :     # Is the root in the current branch?
2617 :    
2618 :     if ( ( $x_below + $x ) >= $x_above )
2619 :     {
2620 : golsen 1.12 # We will need to make a new node for the root, $fract of
2621 :     # the way from $node to $anc_node:
2622 :     my $fract = ( $x > 0 ) ? 0.5 * ( ( $x_above - $x_below ) / $x + 1 )
2623 :     : 0.5;
2624 :     push @mids, [ $node, $anc_node, $fract ];
2625 : golsen 1.1 }
2626 :     }
2627 :    
2628 : golsen 1.12 # The root might be somewhere below this node:
2629 : golsen 1.1
2630 : golsen 1.5 my $n_1 = @$desc_list - ( $anc_node ? 0 : 1 );
2631 : golsen 1.1 my $ttl_dist = ( @$desc_list * $x_below ) + ( defined( $x_above ) ? ( $x_above + $x ) : 0 );
2632 :    
2633 :     foreach ( @$desc_list )
2634 :     {
2635 :     # If input tree is tip_rooted, $n-1 can be 0, so:
2636 :    
2637 :     my $above2 = $n_1 ? ( ( $ttl_dist - $_->[0] ) / $n_1 ) : 0;
2638 : golsen 1.12 push @mids, average_to_tips_2( $_, $above2, $node );
2639 : golsen 1.1 }
2640 :    
2641 : golsen 1.12 return @mids;
2642 : golsen 1.1 }
2643 :    
2644 : golsen 1.9
2645 : golsen 1.1 #-------------------------------------------------------------------------------
2646 : golsen 1.5 # Move root of tree to an approximate midpoint. Weight by tips.
2647 :     #
2648 :     # $newtree = reroot_newick_to_approx_midpoint_w( $tree )
2649 : golsen 1.24 #
2650 : golsen 1.5 #-------------------------------------------------------------------------------
2651 : golsen 1.24 sub reroot_newick_to_approx_midpoint_w
2652 :     {
2653 : golsen 1.5 my ( $tree ) = @_;
2654 : golsen 1.21 array_ref( $tree ) or return undef;
2655 : golsen 1.5
2656 : golsen 1.12 # Compile average tip to node distances assending from tips
2657 :    
2658 :     my $dists1 = average_to_tips_1_w( $tree );
2659 :    
2660 :     # Compile average tip to node distances descending, returning midpoints
2661 :    
2662 :     my @mids = average_to_tips_2_w( $dists1, undef, undef, undef );
2663 :    
2664 :     # Reroot to first midpoint candidate
2665 :    
2666 :     return $tree if ! @mids;
2667 :     my ( $node1, $node2, $fraction ) = @{ $mids[0] };
2668 :     reroot_newick_to_node_ref( $tree, $fraction >= 0.5 ? $node2 : $node1 );
2669 :     }
2670 :    
2671 :    
2672 :     #-------------------------------------------------------------------------------
2673 :     # Move root of tree to an approximate midpoint. Weight by tips.
2674 :     #
2675 :     # $newtree = reroot_newick_to_midpoint_w( $tree )
2676 : golsen 1.24 #
2677 : golsen 1.12 #-------------------------------------------------------------------------------
2678 : golsen 1.24 sub reroot_newick_to_midpoint_w
2679 :     {
2680 : golsen 1.12 my ( $tree ) = @_;
2681 : golsen 1.21 array_ref( $tree ) or return ();
2682 : golsen 1.12
2683 : golsen 1.5 # Compile average tip to node distances assending
2684 :    
2685 :     my $dists1 = average_to_tips_1_w( $tree );
2686 :    
2687 :     # Compile average tip to node distances descending, returning midpoint node
2688 :    
2689 : golsen 1.12 my @mids = average_to_tips_2_w( $dists1, undef, undef, undef );
2690 : golsen 1.5
2691 : golsen 1.12 # Reroot at first candidate midpoint
2692 : golsen 1.5
2693 : golsen 1.12 @mids ? reroot_newick_between_node_refs( $tree, @{ $mids[0] } ) : $tree;
2694 : golsen 1.5 }
2695 :    
2696 :    
2697 : golsen 1.21 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2698 : golsen 1.24 sub average_to_tips_1_w
2699 :     {
2700 : golsen 1.5 my ( $node ) = @_;
2701 :    
2702 :     my @desc_dists = map { average_to_tips_1_w( $_ ) } newick_desc_list( $node );
2703 :     my $x_below = 0;
2704 :     my $n_below = 1;
2705 :     if ( @desc_dists )
2706 :     {
2707 :     $n_below = 0;
2708 :     my $n;
2709 :     foreach ( @desc_dists )
2710 :     {
2711 :     $n_below += $n = $_->[1];
2712 :     $x_below += $n * $_->[0];
2713 :     }
2714 :     $x_below /= $n_below;
2715 :     }
2716 : golsen 1.12
2717 : golsen 1.5 my $x = newick_x( $node ) || 0;
2718 :     my $x_net = $x_below + $x;
2719 :    
2720 :     [ $x_net, $n_below, $x, $x_below, [ @desc_dists ], $node ]
2721 :     }
2722 :    
2723 :    
2724 : golsen 1.21 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2725 : golsen 1.24 sub average_to_tips_2_w
2726 :     {
2727 : golsen 1.5 my ( $dists1, $x_above, $n_above, $anc_node ) = @_;
2728 :     my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;
2729 :    
2730 :     # Are we done? Root is in this node's branch, or "above"?
2731 :    
2732 : golsen 1.12 my @mids = ();
2733 : golsen 1.5 if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2734 :     {
2735 :     # At this point the root can only be in this node's branch,
2736 :     # or "above" it in the current rooting of the tree (which
2737 :     # would mean that the midpoint is actually down a different
2738 :     # path from the root of the current tree).
2739 :     #
2740 : golsen 1.12 # Is their a root in the current branch?
2741 : golsen 1.5
2742 :     if ( ( $x_below + $x ) >= $x_above )
2743 :     {
2744 : golsen 1.12 # We will need to make a new node for the root, $fract of
2745 :     # the way from $node to $anc_node:
2746 :     my $fract = ( $x > 0 ) ? 0.5 * ( ( $x_above - $x_below ) / $x + 1 )
2747 :     : 0.5;
2748 :     push @mids, [ $node, $anc_node, $fract ];
2749 : golsen 1.5 }
2750 :     }
2751 :    
2752 :     # The root must be some where below this node:
2753 :    
2754 :     $n_above ||= 0;
2755 :     my $n = $n_above + $n_below;
2756 :     my $ttl_w_dist = ( $n_below * $x_below )
2757 :     + ( defined( $x_above ) ? $n_above * ( $x_above + $x ) : 0 );
2758 :    
2759 :     foreach ( @$desc_list )
2760 :     {
2761 :     my $n_2 = $_->[1]; # n in subtree
2762 :     my $n_above2 = $n - $n_2; # tip rooted has 1 above
2763 :    
2764 :     # If input tree is tip_rooted, $n_above2 can be 0, so:
2765 :    
2766 :     my $x_above2 = $n_above2 ? ( ( $ttl_w_dist - $n_2 * $_->[0] ) / $n_above2 )
2767 :     : 0;
2768 : golsen 1.12 push @mids, average_to_tips_2_w( $_, $x_above2, $n_above2 || 1, $node );
2769 : golsen 1.5 }
2770 :    
2771 : golsen 1.12 return @mids;
2772 : golsen 1.5 }
2773 :    
2774 : golsen 1.9
2775 : golsen 1.5 #-------------------------------------------------------------------------------
2776 : golsen 1.1 # Move root of tree from tip to adjacent node.
2777 :     #
2778 :     # $newtree = uproot_tip_rooted_newick( $tree )
2779 : golsen 1.24 #
2780 : golsen 1.1 #-------------------------------------------------------------------------------
2781 : golsen 1.24 sub uproot_tip_rooted_newick
2782 :     {
2783 : golsen 1.1 my ( $node ) = @_;
2784 :     newick_is_tip_rooted( $node ) || return $node;
2785 :    
2786 :     # Path to the sole descendant:
2787 :    
2788 :     reroot_newick_by_path( $node, 1, newick_desc_i( $node, 1 ) );
2789 :     }
2790 :    
2791 :    
2792 :     #-------------------------------------------------------------------------------
2793 :     # Remove root bifurcation.
2794 :     #
2795 :     # Root node label, label comment and descendant list comment are discarded.
2796 :     #
2797 :     # $newtree = uproot_newick( $tree )
2798 : golsen 1.24 #
2799 : golsen 1.1 #-------------------------------------------------------------------------------
2800 : golsen 1.24 sub uproot_newick
2801 :     {
2802 : golsen 1.1 my ( $node0 ) = @_;
2803 :     newick_is_rooted( $node0 ) || return $node0;
2804 :    
2805 :     my ( $node1, $node2 ) = newick_desc_list( $node0 );
2806 :    
2807 :     # Ensure that node1 has at least 1 descendant
2808 :    
2809 :     if ( newick_n_desc( $node1 ) ) {
2810 :     push @{ newick_desc_ref( $node1 ) }, $node2; # Add node2 to descend list
2811 :     }
2812 :    
2813 :     # Or node2 has at least 1 descendant
2814 :    
2815 :     elsif ( newick_n_desc( $node2 ) ) {
2816 :     unshift @{ newick_desc_ref( $node2 ) }, $node1; # Add node1 to descend list
2817 :     ( $node1, $node2 ) = ( $node2, $node1 ); # And reverse labels
2818 :     }
2819 :    
2820 :     # We could make this into a tip rooted tree, but for now:
2821 :    
2822 :     else { return $node0 }
2823 :    
2824 :     # Prefix node1 branch to that of node2:
2825 :    
2826 :     add_to_newick_branch( $node2, $node1 );
2827 :     set_newick_x( $node1, undef );
2828 :    
2829 :     # Tree prefix comment lists (as references):
2830 :    
2831 :     my $C10 = newick_c1( $node0 );
2832 :     my $C11 = newick_c1( $node1 );
2833 : golsen 1.9 if ( $C11 && @$C11 ) {
2834 : golsen 1.1 if ( $C10 && @$C10 ) { unshift @$C11, @$C10 } # Prefix to node1 comments
2835 :     }
2836 :     elsif ( $C10 && @$C10 ) {
2837 :     set_newick_c1( $node1, $C10 ) # Or move node0 comments to node1
2838 :     }
2839 :    
2840 :     $node1;
2841 :     }
2842 :    
2843 :    
2844 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2845 :     # Prefix branch of node2 to that of node1:
2846 :     #
2847 :     # $node1 = add_to_newick_branch( $node1, $node2 )
2848 : golsen 1.24 #
2849 : golsen 1.1 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2850 : golsen 1.24 sub add_to_newick_branch
2851 :     {
2852 : golsen 1.1 my ( $node1, $node2 ) = @_;
2853 :     array_ref( $node1 ) || die "add_to_newick_branch: arg 1 not array ref\n";
2854 :     array_ref( $node2 ) || die "add_to_newick_branch: arg 2 not array ref\n";
2855 :    
2856 :     # Node structure template:
2857 :     # my ( $DL, $L, $X, $C1, $C2, $C3, $C4, $C5 ) = @$node;
2858 :    
2859 :     # Fix branch lengths for joining of two branches:
2860 :    
2861 :     set_newick_x( $node1, newick_x( $node1 ) + newick_x( $node2 ) );
2862 :    
2863 :     # Merge branch length comments:
2864 :    
2865 :     my $C41 = newick_c4( $node1 ); # Ref to node1 C4
2866 :     my $C42 = newick_c4( $node2 ); # Ref to node2 C4
2867 :     if ( $C41 && @$C41 ) {
2868 :     if ( $C42 && @$C42 ) { unshift @$C41, @$C42 } # Add node2 comment
2869 :     }
2870 :     elsif ( $C42 && @$C42 ) { set_newick_c4( $node1, $C42 ) } # Or move node1 comment
2871 :    
2872 :     my $C51 = newick_c5( $node1 ); # Ref to node1 C5
2873 :     my $C52 = newick_c5( $node2 ); # Ref to node2 C5
2874 :     if ( $C51 && @$C51 ) {
2875 :     if ( $C52 && @$C52 ) { unshift @$C51, @$C52 } # Add node2 comment
2876 :     }
2877 :     elsif ( $C52 && @$C52 ) { set_newick_c5( $node1, $C52 ) } # Or move node1 comment
2878 :    
2879 :     $node1;
2880 :     }
2881 :    
2882 :    
2883 :     #-------------------------------------------------------------------------------
2884 : golsen 1.5 # Collapse zero-length branches to make multifurcation. The original tree
2885 :     # is modified.
2886 :     #
2887 :     # $tree = collapse_zero_length_branches( $tree )
2888 :     # $tree = collapse_zero_length_branches( $tree, $not_root )
2889 : golsen 1.24 #
2890 : golsen 1.5 #-------------------------------------------------------------------------------
2891 : golsen 1.24 sub collapse_zero_length_branches
2892 :     {
2893 : golsen 1.5 my ( $tree, $not_root ) = @_;
2894 :     array_ref( $tree ) || return undef;
2895 :    
2896 :     my @desc = newick_desc_list( $tree );
2897 :     @desc or return ( $tree ); # Cannot collapse terminal branch
2898 :    
2899 :     # Analyze descendants:
2900 :    
2901 :     $not_root ||= 0;
2902 :     my @new_desc = ();
2903 :     my $changed = 0;
2904 :     foreach ( @desc )
2905 :     {
2906 :     my ( undef, @to_add ) = collapse_zero_length_branches( $_, $not_root+1 );
2907 :     if ( @to_add )
2908 :     {
2909 :     push @new_desc, @to_add;
2910 :     $changed = 1;
2911 :     }
2912 :     else
2913 :     {
2914 :     push @new_desc, $_;
2915 :     }
2916 :     }
2917 :     set_newick_desc_ref( $tree, [ @new_desc ] ) if $changed;
2918 :    
2919 :     # Collapse if not root, not tip and zero (or negative) branch:
2920 :    
2921 :     my $collapse = $not_root && @new_desc && ( newick_x( $tree ) <= 0 ) ? 1 : 0;
2922 :     ( $tree, ( $collapse ? @new_desc : () ) );
2923 :     }
2924 :    
2925 : golsen 1.8 #-------------------------------------------------------------------------------
2926 :     # Add a subtree to a newick tree node:
2927 :     #
2928 :     # $node = newick_insert_at_node( $node, $subtree )
2929 : golsen 1.24 #
2930 : golsen 1.8 #-------------------------------------------------------------------------------
2931 :     sub newick_insert_at_node
2932 :     {
2933 :     my ( $node, $subtree ) = @_;
2934 :     array_ref( $node ) && array_ref( $subtree ) or return undef;
2935 :    
2936 :     # We could check validity of trees, but ....
2937 :    
2938 :     my $dl = newick_desc_ref( $node );
2939 :     if ( array_ref( $dl ) )
2940 :     {
2941 :     push @$dl, $subtree;
2942 :     }
2943 :     else
2944 :     {
2945 :     set_newick_desc_ref( $node, [ $subtree ] );
2946 :     }
2947 :     return $node;
2948 :     }
2949 :    
2950 :    
2951 :     #-------------------------------------------------------------------------------
2952 :     # Insert a subtree into a newick tree along the path between 2 nodes:
2953 :     #
2954 :     # $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
2955 : golsen 1.24 #
2956 : golsen 1.8 #-------------------------------------------------------------------------------
2957 :     sub newick_insert_between_nodes
2958 :     {
2959 :     my ( $tree, $subtree, $node1, $node2, $fraction ) = @_;
2960 :     array_ref( $tree ) && array_ref( $subtree ) or return undef;
2961 :     $fraction >= 0 && $fraction <= 1 or return undef;
2962 :    
2963 :     # Find the paths to the nodes:
2964 :    
2965 :     my @path1 = path_to_node( $tree, $node1 ) or return undef;
2966 :     my @path2 = path_to_node( $tree, $node2 ) or return undef;
2967 :    
2968 :     # Trim the common prefix:
2969 :    
2970 :     while ( $path1[1] == $path2[1] )
2971 :     {
2972 :     splice( @path1, 0, 2 );
2973 :     splice( @path2, 0, 2 );
2974 :     }
2975 :    
2976 :     my ( @path, $dist );
2977 :     if ( @path1 < 3 )
2978 :     {
2979 :     @path2 >= 3 or return undef; # node1 = node2
2980 : golsen 1.9 $dist = $fraction * newick_path_length( @path2 );
2981 : golsen 1.8 @path = @path2;
2982 :     }
2983 :     elsif ( @path2 < 3 )
2984 :     {
2985 :     $dist = ( 1 - $fraction ) * newick_path_length( @path1 );
2986 :     @path = @path1;
2987 :     }
2988 :     else
2989 :     {
2990 :     my $dist1 = newick_path_length( @path1 );
2991 :     my $dist2 = newick_path_length( @path2 );
2992 :     $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
2993 :     @path = ( $dist <= 0 ) ? @path1 : @path2;
2994 :     $dist = abs( $dist );
2995 :     }
2996 :    
2997 :     # Descend tree until we reach the insertion branch:
2998 :    
2999 :     my $x;
3000 :     while ( ( $dist > ( $x = newick_x( $path[2] ) ) ) && ( @path > 3 ) )
3001 :     {
3002 :     $dist -= $x;
3003 :     splice( @path, 0, 2 );
3004 :     }
3005 :    
3006 :     # Insert the new node:
3007 :    
3008 :     set_newick_desc_i( $path[0], $path[1], [ [ $path[2], $subtree ], undef, $dist ] );
3009 :     set_newick_x( $path[2], ( ( $x > $dist ) ? ( $x - $dist ) : 0 ) );
3010 :    
3011 :     return $tree;
3012 :     }
3013 :    
3014 : golsen 1.5
3015 :     #-------------------------------------------------------------------------------
3016 : golsen 1.1 # Prune one or more tips from a tree:
3017 :     # Caveat: if one tip is listed, the original tree is modified.
3018 : golsen 1.5 # if more than one tip is listed, a copy of the tree is returned
3019 : golsen 1.1 # (even if it is just listing the same tip twice!).
3020 :     #
3021 :     # $newtree = prune_from_newick( $tree, $tip )
3022 :     # $newtree = prune_from_newick( $tree, @tips )
3023 :     # $newtree = prune_from_newick( $tree, \@tips )
3024 : golsen 1.24 #
3025 : golsen 1.1 #-------------------------------------------------------------------------------
3026 : golsen 1.24 sub prune_from_newick
3027 :     {
3028 : golsen 1.1 my ( $tr, @tips ) = @_;
3029 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3030 : golsen 1.9
3031 : golsen 1.1 if ( @tips == 0 ) { return $tr }
3032 :     if ( @tips == 1 ) { return prune_1_from_newick( $tr, @tips ) }
3033 :    
3034 :     my %del = map { ( $_, 1 ) } @tips;
3035 :     my @keep = grep { ! $del{ $_ } } newick_tip_list( $tr );
3036 :     newick_subtree( $tr, @keep );
3037 :     }
3038 :    
3039 :    
3040 :     #-------------------------------------------------------------------------------
3041 :     # Prune a tip from a tree:
3042 :     #
3043 :     # $newtree = prune_1_from_newick( $tree, $tip )
3044 : golsen 1.24 #
3045 : golsen 1.1 #-------------------------------------------------------------------------------
3046 : golsen 1.24 sub prune_1_from_newick
3047 :     {
3048 : golsen 1.1 my ( $tr, $tip ) = @_;
3049 :     my @path = path_to_tip( $tr, $tip );
3050 :     if ( @path < 3 ) { return $tr }
3051 :    
3052 :     my $node = $path[-1]; # Node with the tip
3053 :     my $i1 = $path[-2]; # Descendant number of node in ancestor desc list
3054 :     my $anc1 = $path[-3]; # Ancestor of node
3055 :     my $nd1 = newick_n_desc( $anc1 ); # Number of descendants of ancestor
3056 :     my $anc2 = ( @path >= 5 ) ? $path[-5] : undef; # Ancestor of anc1
3057 :    
3058 :     # dump_tree( $node );
3059 :     # print STDERR "i1 = $i1\n";
3060 :     # dump_tree( $anc1 );
3061 :     # print STDERR "nd1 = $nd1\n";
3062 :     # defined( $anc2 ) && dump_tree( $anc2 );
3063 :    
3064 :     if ( $nd1 > 3 || ( $anc2 && $nd1 > 2 ) ) { # Tip joins at multifurcation
3065 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant
3066 :     }
3067 :    
3068 :     elsif ( $anc2 ) { # Tip joins at internal bifurcation
3069 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
3070 :     add_to_newick_branch( $sis, $anc1 ); # combine internal branches
3071 :     set_newick_desc_i( $anc2, $path[-4], $sis ); # remove $anc1
3072 :     }
3073 :    
3074 :     elsif ( $nd1 == 2) { # Tip joins bifurcating root node
3075 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
3076 :     $sis->[1] = $anc1->[1] if ! $sis->[1] && $anc1->[1]; # root label
3077 :     $sis->[2] = undef; # root branch len
3078 :     $sis->[3] = $anc1->[3] if ! $sis->[3] && $anc1->[3]; # tree comment
3079 :     $sis->[4] = $anc1->[4] if ! $sis->[4] && $anc1->[4]; # desc list comment
3080 : golsen 1.9 $sis->[5] = $anc1->[5] if ! $sis->[5] && $anc1->[5]; # label comment
3081 : golsen 1.1 $sis->[6] = undef if $sis->[6]; # root branch comment
3082 :     $sis->[7] = undef if $sis->[7]; # root branch comment
3083 :     $tr = $sis; # sister is new root
3084 :     }
3085 :    
3086 :     elsif ( $nd1 == 3 ) { # Tip joins trifurcating root:
3087 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant, and
3088 :     $tr = uproot_newick( $tr ); # fix the rooting
3089 :     }
3090 :    
3091 :     else {
3092 :     return undef;
3093 :     }
3094 :    
3095 :     return $tr;
3096 :     }
3097 :    
3098 :    
3099 :     #-------------------------------------------------------------------------------
3100 : golsen 1.12 # Produce a potentially rooted subtree with the desired tips:
3101 :     #
3102 :     # Except for (some) tip nodes, the tree produced is a copy.
3103 :     # There is no check that requested tips exist.
3104 :     #
3105 :     # $newtree = rooted_newick_subtree( $tree, @tips )
3106 :     # $newtree = rooted_newick_subtree( $tree, \@tips )
3107 : golsen 1.24 #
3108 : golsen 1.12 #-------------------------------------------------------------------------------
3109 : golsen 1.24 sub rooted_newick_subtree
3110 :     {
3111 : golsen 1.12 my ( $tr, @tips ) = @_;
3112 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3113 :    
3114 :     if ( @tips < 2 ) { return undef }
3115 :     my $keephash = { map { ( $_, 1 ) } @tips };
3116 :     my $tr2 = subtree1( $tr, $keephash );
3117 :     $tr2->[2] = undef if $tr2; # undef root branch length
3118 :     $tr2;
3119 :     }
3120 :    
3121 :    
3122 :     #-------------------------------------------------------------------------------
3123 : golsen 1.1 # Produce a subtree with the desired tips:
3124 :     #
3125 :     # Except for (some) tip nodes, the tree produced is a copy.
3126 :     # There is no check that requested tips exist.
3127 :     #
3128 :     # $newtree = newick_subtree( $tree, @tips )
3129 :     # $newtree = newick_subtree( $tree, \@tips )
3130 : golsen 1.24 #
3131 : golsen 1.1 #-------------------------------------------------------------------------------
3132 : golsen 1.24 sub newick_subtree
3133 :     {
3134 : golsen 1.1 my ( $tr, @tips ) = @_;
3135 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3136 :    
3137 :     if ( @tips < 2 ) { return undef }
3138 :     my $was_rooted = newick_is_rooted( $tr );
3139 :     my $keephash = { map { ( $_, 1 ) } @tips };
3140 :     my $tr2 = subtree1( $tr, $keephash );
3141 :     $tr2 = uproot_newick( $tr2 ) if ! $was_rooted && newick_is_rooted( $tr2 );
3142 :     $tr2->[2] = undef if $tr2; # undef root branch length
3143 :     $tr2;
3144 :     }
3145 :    
3146 :    
3147 : golsen 1.24 sub subtree1
3148 :     {
3149 : golsen 1.1 my ( $tr, $keep ) = @_;
3150 :     my @desc1 = newick_desc_list( $tr );
3151 :    
3152 :     # Is this a tip, and is it in the keep list?
3153 :    
3154 :     if ( @desc1 < 1 ) {
3155 :     return ( $keep->{ newick_lbl( $tr ) } ) ? $tr : undef;
3156 :     }
3157 :    
3158 :     # Internal node: analyze the descendants:
3159 :    
3160 :     my @desc2 = ();
3161 :     foreach ( @desc1 ) {
3162 :     my $desc = subtree1( $_, $keep );
3163 :     if ( $desc && @$desc ) { push @desc2, $desc }
3164 :     }
3165 :    
3166 :     if ( @desc2 == 0 ) { return undef }
3167 :     if ( @desc2 > 1 ) { return [ \@desc2, @$tr[ 1 .. @$tr - 1 ] ] }
3168 :    
3169 :     # Exactly 1 descendant
3170 :    
3171 :     my $desc = $desc2[ 0 ];
3172 :     my @nn = ( $desc->[0],
3173 :     $desc->[1] ? $desc->[1] : $tr->[1],
3174 :     defined( $tr->[2] ) ? $desc->[2] + $tr->[2] : undef
3175 :     );
3176 :    
3177 :     # Merge comments (only recreating the ones that existed):
3178 :    
3179 :     if ( $tr->[3] && @{$tr->[3]} || $desc->[3] && @{$desc->[3]} ) {
3180 :     $nn[3] = [ $tr->[3] ? @{$tr->[3]} : (), $desc->[3] ? @{$desc->[3]} : () ];
3181 :     }
3182 :     if ( $tr->[4] && @{$tr->[4]} || $desc->[4] && @{$desc->[4]} ) {
3183 :     $nn[4] = [ $tr->[4] ? @{$tr->[4]} : (), $desc->[4] ? @{$desc->[4]} : () ];
3184 :     }
3185 :     if ( $tr->[5] && @{$tr->[5]} || $desc->[5] && @{$desc->[5]} ) {
3186 :     $nn[5] = [ $tr->[5] ? @{$tr->[5]} : (), $desc->[5] ? @{$desc->[5]} : () ];
3187 :     }
3188 :     if ( $tr->[6] && @{$tr->[6]} || $desc->[6] && @{$desc->[6]} ) {
3189 :     $nn[6] = [ $tr->[6] ? @{$tr->[6]} : (), $desc->[6] ? @{$desc->[6]} : () ];
3190 :     }
3191 :     if ( $tr->[7] && @{$tr->[7]} || $desc->[7] && @{$desc->[7]} ) {
3192 :     $nn[7] = [ $tr->[7] ? @{$tr->[7]} : (), $desc->[7] ? @{$desc->[7]} : () ];
3193 :     }
3194 :    
3195 :     return \@nn;
3196 :     }
3197 :    
3198 :    
3199 : golsen 1.12 #-------------------------------------------------------------------------------
3200 :     # The smallest subtree of rooted tree that includes @tips:
3201 :     #
3202 :     # $node = newick_covering_subtree( $tree, @tips )
3203 :     # $node = newick_covering_subtree( $tree, \@tips )
3204 : golsen 1.24 #
3205 : golsen 1.12 #-------------------------------------------------------------------------------
3206 :    
3207 : golsen 1.24 sub newick_covering_subtree
3208 :     {
3209 : golsen 1.12 my $tree = shift;
3210 :     my %tips = map { $_ => 1 } ( ( ref( $_[0] ) eq 'ARRAY' ) ? @{ $_[0] } : @_ );
3211 :    
3212 :     # Return smallest covering node, if any:
3213 :    
3214 :     ( newick_covering_subtree( $tree, \%tips ) )[ 0 ];
3215 :     }
3216 :    
3217 :    
3218 : golsen 1.24 sub newick_covering_subtree_1
3219 :     {
3220 : golsen 1.12 my ( $node, $tips ) = @_;
3221 :     my $n_cover = 0;
3222 :     my @desc = newick_desc_list( $node );
3223 :     if ( @desc )
3224 :     {
3225 :     foreach ( @desc )
3226 :     {
3227 :     my ( $subtree, $n ) = newick_covering_subtree_1( $_, $tips );
3228 :     return ( $subtree, $n ) if $subtree;
3229 :     $n_cover += $n;
3230 :     }
3231 :     }
3232 :     elsif ( $tips->{ newick_lbl( $node ) } )
3233 :     {
3234 :     $n_cover++;
3235 :     }
3236 :    
3237 :     # If all tips are covered, return node
3238 :    
3239 :     ( $n_cover == keys %$tips ) ? ( $node, $n_cover ) : ( undef, $n_cover );
3240 :     }
3241 :    
3242 :    
3243 : golsen 1.1 #===============================================================================
3244 :     #
3245 : golsen 1.9 # Representative subtrees
3246 :     #
3247 :     #===============================================================================
3248 :     # Find subtree of size n representating vicinity of the root:
3249 :     #
3250 :     # $subtree = root_neighborhood_representative_tree( $tree, $n, \%tip_priority )
3251 :     # $subtree = root_neighborhood_representative_tree( $tree, $n )
3252 :     #
3253 :     # Note that if $tree is rooted, then the subtree will also be. This can have
3254 :     # consequences on downstream programs.
3255 :     #-------------------------------------------------------------------------------
3256 :     sub root_neighborhood_representative_tree
3257 :     {
3258 :     my ( $tree, $n, $tip_priority ) = @_;
3259 :     array_ref( $tree ) && ( $n >= 2 ) or return undef;
3260 :     if ( newick_tip_count( $tree ) <= $n ) { return $tree }
3261 :    
3262 :     $tip_priority ||= default_tip_priority( $tree );
3263 :     my @tips = map { representative_tip_of_newick_node( $_, $tip_priority ) }
3264 :     root_proximal_newick_subtrees( $tree, $n );
3265 :    
3266 :     newick_subtree( copy_newick_tree( $tree ), \@tips );
3267 :     }
3268 :    
3269 :    
3270 :     #-------------------------------------------------------------------------------
3271 :     # Find n tips to represent tree lineages in vicinity of another tip.
3272 :     # Default tip priority is short total branch length.
3273 :     #
3274 :     # \@tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
3275 :     # @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
3276 :     # \@tips = root_neighborhood_representative_tips( $tree, $n )
3277 :     # @tips = root_neighborhood_representative_tips( $tree, $n )
3278 : golsen 1.24 #
3279 : golsen 1.9 #-------------------------------------------------------------------------------
3280 :     sub root_neighborhood_representative_tips
3281 :     {
3282 :     my ( $tree, $n, $tip_priority ) = @_;
3283 :     array_ref( $tree ) && ( $n >= 2 ) or return undef;
3284 :    
3285 :     my @tips;
3286 :     if ( newick_tip_count( $tree ) <= $n )
3287 :     {
3288 :     @tips = newick_tip_list( $tree );
3289 :     }
3290 :     else
3291 :     {
3292 :     $tip_priority ||= default_tip_priority( $tree );
3293 :     @tips = map { representative_tip_of_newick_node( $_, $tip_priority ) }
3294 :     root_proximal_newick_subtrees( $tree, $n );
3295 :     }
3296 :    
3297 :     wantarray ? @tips : \@tips;
3298 :     }
3299 :    
3300 :    
3301 :     #-------------------------------------------------------------------------------
3302 :     # Find subtree of size n representating vicinity of a tip:
3303 :     #
3304 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )
3305 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )
3306 : golsen 1.24 #
3307 : golsen 1.9 #-------------------------------------------------------------------------------
3308 :     sub tip_neighborhood_representative_tree
3309 :     {
3310 :     my ( $tree, $tip, $n, $tip_priority ) = @_;
3311 :     array_ref( $tree ) && $tip && ( $n >= 2 ) or return undef;
3312 :     newick_tip_in_tree( $tree, $tip ) or return undef;
3313 :    
3314 :     my $tree1 = copy_newick_tree( $tree );
3315 :     if ( newick_tip_count( $tree1 ) - 1 <= $n )
3316 :     {
3317 :     return prune_from_newick( $tree1, $tip )
3318 :     }
3319 :    
3320 :     $tree1 = reroot_newick_to_tip( $tree1, $tip );
3321 :     $tree1 = newick_desc_i( $tree1, 1 ); # Node immediately below tip
3322 :     my @tips = root_neighborhood_representative_tips( $tree1, $n, $tip_priority );
3323 :     newick_subtree( copy_newick_tree( $tree ), \@tips );
3324 :     }
3325 :    
3326 :    
3327 :     #-------------------------------------------------------------------------------
3328 :     # Find n tips to represent tree lineages in vicinity of another tip.
3329 :     # Default tip priority is short total branch length.
3330 :     #
3331 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
3332 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
3333 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
3334 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
3335 : golsen 1.24 #
3336 : golsen 1.9 #-------------------------------------------------------------------------------
3337 :     sub tip_neighborhood_representative_tips
3338 :     {
3339 :     my ( $tree, $tip, $n, $tip_priority ) = @_;
3340 :     array_ref( $tree ) && $tip && ( $n >= 2 ) or return undef;
3341 :     newick_tip_in_tree( $tree, $tip ) or return undef;
3342 :    
3343 :     my @tips = newick_tip_list( $tree );
3344 :     if ( newick_tip_count( $tree ) - 1 <= $n )
3345 :     {
3346 :     @tips = grep { $_ ne $tip } @tips;
3347 :     }
3348 :     else
3349 :     {
3350 :     my $tree1 = copy_newick_tree( $tree );
3351 :     $tree1 = reroot_newick_to_tip( $tree1, $tip );
3352 :     $tree1 = newick_desc_i( $tree1, 1 ); # Node immediately below tip
3353 :     @tips = root_neighborhood_representative_tips( $tree1, $n, $tip_priority );
3354 :     }
3355 :    
3356 :     wantarray ? @tips : \@tips;
3357 :     }
3358 :    
3359 :    
3360 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3361 :     # Anonymous hash of the negative distance from root to each tip:
3362 :     #
3363 :     # \%tip_priority = default_tip_priority( $tree )
3364 : golsen 1.24 #
3365 : golsen 1.9 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3366 :     sub default_tip_priority
3367 :     {
3368 :     my ( $tree ) = @_;
3369 :     my $tip_distances = newick_tip_distances( $tree ) || {};
3370 :     return { map { $_ => -$tip_distances->{$_} } keys %$tip_distances };
3371 :     }
3372 :    
3373 :    
3374 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3375 :     # Select a tip from a subtree base on a priority value:
3376 :     #
3377 :     # $tip = representative_tip_of_newick_node( $node, \%tip_priority )
3378 : golsen 1.24 #
3379 : golsen 1.9 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3380 :     sub representative_tip_of_newick_node
3381 :     {
3382 :     my ( $node, $tip_priority ) = @_;
3383 :     my ( $tip ) = sort { $b->[1] <=> $a->[1] } # The best
3384 :     map { [ $_, $tip_priority->{ $_ } ] }
3385 :     newick_tip_list( $node );
3386 :     $tip->[0]; # Label from label-priority pair
3387 :     }
3388 :    
3389 :    
3390 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3391 :     # Find n subtrees focused around the root of a tree. Typically each will
3392 :     # then be reduced to a single tip to make a representative tree:
3393 :     #
3394 :     # @subtrees = root_proximal_newick_subtrees( $tree, $n )
3395 : golsen 1.24 #
3396 : golsen 1.9 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3397 :     sub root_proximal_newick_subtrees
3398 :     {
3399 :     my ( $tree, $n ) = @_;
3400 :     my $node_start_end = newick_branch_intervals( $tree );
3401 :     n_representative_branches( $n, $node_start_end );
3402 :     }
3403 :    
3404 :    
3405 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3406 :     # @node_start_end = newick_branch_intervals( $tree )
3407 :     # \@node_start_end = newick_branch_intervals( $tree )
3408 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3409 :     sub newick_branch_intervals
3410 :     {
3411 :     my ( $node, $parent_x ) = @_;
3412 :     $parent_x ||= 0;
3413 :     my ( $desc, undef, $dx ) = @$node;
3414 :     my $x = $parent_x + $dx;
3415 :     my $interval = [ $node, $parent_x, $desc && @$desc ? $x : 1e100 ];
3416 :     my @intervals = ( $interval,
3417 :     map { &newick_branch_intervals( $_, $x ) } @$desc
3418 :     );
3419 :     return wantarray ? @intervals : \@intervals;
3420 :     }
3421 :    
3422 :    
3423 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3424 :     # @ids = n_representative_branches( $n, @id_start_end )
3425 :     # @ids = n_representative_branches( $n, \@id_start_end )
3426 :     # \@ids = n_representative_branches( $n, @id_start_end )
3427 :     # \@ids = n_representative_branches( $n, \@id_start_end )
3428 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3429 :     sub n_representative_branches
3430 :     {
3431 :     my $n = shift;
3432 :     # Sort intervals by start point:
3433 :     my @unprocessed = sort { $a->[1] <=> $b->[1] }
3434 :     ( @_ == 1 ) ? @{ $_[0] } : @_;
3435 :     my @active = ();
3436 :     my ( $interval, $current_point );
3437 :     foreach $interval ( @unprocessed )
3438 :     {
3439 :     $current_point = $interval->[1];
3440 :     # Filter out intervals that have ended. This is N**2 in the number
3441 :     # of representatives. Fixing this would require maintaining a sorted
3442 :     # active list.
3443 :     @active = grep { $_->[2] > $current_point } @active;
3444 :     push @active, $interval;
3445 :     last if ( @active >= $n );
3446 :     }
3447 :    
3448 :     my @ids = map { $_->[0] } @active;
3449 :     return wantarray() ? @ids : \@ids;
3450 :     }
3451 :    
3452 :    
3453 :     #===============================================================================
3454 : golsen 1.22 # Random trees
3455 :     #===============================================================================
3456 :     #
3457 :     # $tree = random_equibranch_tree( @tips, \%options )
3458 :     # $tree = random_equibranch_tree( \@tips, \%options )
3459 :     # $tree = random_equibranch_tree( @tips )
3460 :     # $tree = random_equibranch_tree( \@tips )
3461 :     #
3462 :     # Options:
3463 :     #
3464 :     # length => $branch_length # D = 1
3465 :     #
3466 :     #-------------------------------------------------------------------------------
3467 :     sub random_equibranch_tree
3468 :     {
3469 :     my $opts = $_[ 0] && ref $_[ 0] eq 'HASH' ? shift
3470 :     : $_[-1] && ref $_[-1] eq 'HASH' ? pop
3471 :     : {};
3472 :     return undef if ! defined $_[0];
3473 :    
3474 :     my @tips = ref $_[0] ? @{ $_[0] } : @_;
3475 :     return undef if @tips < 2;
3476 :    
3477 :     my $len = $opts->{ length } ||= 1;
3478 :    
3479 :     if ( @tips == 2 )
3480 :     {
3481 :     return [ [ map { [ [], $_, $len ] } @tips ], undef, 0 ];
3482 :     }
3483 :    
3484 :     my $tree = [ [ ], undef, 0 ];
3485 :    
3486 :     my @links; # \$anc_dl[i], i.e. a reference to an element in a descendent list
3487 :    
3488 :     my $anc_dl = $tree->[0];
3489 :     foreach my $tip ( splice( @tips, 0, 3 ) )
3490 :     {
3491 :     my $node = [ [], $tip, $len ];
3492 :     push @$anc_dl, $node;
3493 :     push @links, \$anc_dl->[-1]; # Ref to the just added descendent list entry
3494 :     }
3495 :    
3496 :     foreach my $tip ( @tips )
3497 :     {
3498 :     my $link = $links[ int( rand( scalar @links ) ) ];
3499 :     my $newtip = [ [], $tip, $len ];
3500 :     my $new_dl = [ $$link, $newtip ];
3501 :     my $newnode = [ $new_dl, undef, $len ];
3502 :     $$link = $newnode;
3503 :     push @links, \$new_dl->[0], \$new_dl->[1]
3504 :     }
3505 :    
3506 :     return $tree;
3507 :     }
3508 :    
3509 :    
3510 :     #-------------------------------------------------------------------------------
3511 :     #
3512 :     # $tree = random_ultrametric_tree( @tips, \%options )
3513 :     # $tree = random_ultrametric_tree( \@tips, \%options )
3514 :     # $tree = random_ultrametric_tree( @tips )
3515 :     # $tree = random_ultrametric_tree( \@tips )
3516 :     #
3517 :     # Options:
3518 :     #
3519 :     # depth => $root_to_tip_dist # D = 1
3520 :     #
3521 :     #-------------------------------------------------------------------------------
3522 :     sub random_ultrametric_tree
3523 :     {
3524 :     my $opts = $_[ 0] && ref $_[ 0] eq 'HASH' ? shift
3525 :     : $_[-1] && ref $_[-1] eq 'HASH' ? pop
3526 :     : {};
3527 :     return undef if ! defined $_[0];
3528 :    
3529 :     my @tips = ref $_[0] ? @{ $_[0] } : @_;
3530 :     return undef if @tips < 2;
3531 :    
3532 :     my $d2tip = $opts->{ depth } ||= 1;
3533 :    
3534 :     # Random tip addition order (for rooted tree it matters):
3535 :    
3536 :     @tips = sort { rand() <=> 0.5 } @tips;
3537 :     my $tree = [ [ ], undef, 0 ];
3538 :    
3539 :     my $subtree_size = { $tree => 0 }; # total branch length of each subtree
3540 :    
3541 :     # We start with root bifurcation:
3542 :    
3543 :     foreach my $tip ( splice( @tips, 0, 2 ) )
3544 :     {
3545 :     my $node = [ [], $tip, $d2tip ];
3546 :     push @{ $tree->[0] }, $node;
3547 :     $subtree_size->{ $node } = $d2tip;
3548 :     $subtree_size->{ $tree } += $d2tip;
3549 :     }
3550 :    
3551 :     # Add each remaining tip at $pos, measured along the contour length
3552 :     # of the tree (with no retracing along branches).
3553 :    
3554 :     foreach my $tip ( @tips )
3555 :     {
3556 :     my $pos = rand( $subtree_size->{ $tree } );
3557 :     random_add_to_ultrametric_tree( $tree, $tip, $subtree_size, $pos, $d2tip );
3558 :     }
3559 :    
3560 :     return $tree;
3561 :     }
3562 :    
3563 :    
3564 :     sub random_add_to_ultrametric_tree
3565 :     {
3566 :     my ( $node, $tip, $subtree_size, $pos, $d2tip ) = @_;
3567 :     $node && $node->[0] && ref $node->[0] eq 'ARRAY' or die "Bad tree node passed to random_add_to_ultrametric_tree().\n";
3568 :    
3569 :     # Find the descendent line that it goes in:
3570 :    
3571 :     my $i;
3572 :     my $dl = $node->[0];
3573 :     my $size0 = $subtree_size->{ $dl->[0] };
3574 :     if ( $size0 > $pos ) { $i = 0 } else { $i = 1; $pos -= $size0 }
3575 :     my $desc = $dl->[$i];
3576 :    
3577 :     # Does it go within the subtree, or the branch to the subtree?
3578 :    
3579 :     my $len;
3580 :     my $added;
3581 :     if ( ( $len = $desc->[2] ) <= $pos )
3582 :     {
3583 :     $added = random_add_to_ultrametric_tree( $desc, $tip, $subtree_size, $pos - $len, $d2tip - $len );
3584 :     }
3585 :     else
3586 :     {
3587 :     # If not in subtree, then it goes in the branch to the descendent node
3588 :     #
3589 :     # ----- node ------------ node
3590 :     # ^ / \ ^ / \
3591 :     # | \ | pos \l1
3592 :     # | \ v \
3593 :     # | len\ ---------- newnode
3594 :     # | \ / \ l2
3595 :     # d2tip | \ / \
3596 :     # | desc / desc
3597 :     # | / \ l3/ / \
3598 :     # | . . / . .
3599 :     # v . . / . .
3600 :     # ----- . . newtip . .
3601 :    
3602 :     my $l1 = $pos;
3603 :     my $l2 = $len - $pos;
3604 :     my $l3 = $d2tip - $pos;
3605 :     my $newtip = [ [], $tip, $l3 ];
3606 :     my $newnode = [ [ $desc, $newtip ], undef, $l1 ];
3607 :     $dl->[$i] = $newnode;
3608 :     $subtree_size->{ $newtip } = $l3;
3609 :     $subtree_size->{ $newnode } = $subtree_size->{ $desc } + $l3;
3610 :     $desc->[2] = $l2;
3611 :     $subtree_size->{ $desc } -= $l1;
3612 :     $added = $l3;
3613 :     }
3614 :    
3615 :     # New branch was inserted below this point:
3616 :    
3617 :     $subtree_size->{ $node } += $added;
3618 :     return $added;
3619 :     }
3620 :    
3621 :    
3622 :    
3623 :     #===============================================================================
3624 : golsen 1.9 #
3625 : golsen 1.1 # Tree writing and reading
3626 :     #
3627 :     #===============================================================================
3628 : golsen 1.24 #
3629 : overbeek 1.7 # writeNewickTree( $tree )
3630 :     # writeNewickTree( $tree, $file )
3631 :     # writeNewickTree( $tree, \*FH )
3632 : golsen 1.24 #
3633 : golsen 1.1 #-------------------------------------------------------------------------------
3634 : golsen 1.24 sub writeNewickTree
3635 :     {
3636 : golsen 1.1 my ( $tree, $file ) = @_;
3637 : overbeek 1.7 my ( $fh, $close ) = open_output( $file );
3638 :     $fh or return;
3639 :     print $fh ( strNewickTree( $tree ), "\n" );
3640 :     close $fh if $close;
3641 : golsen 1.1 }
3642 :    
3643 :    
3644 :     #-------------------------------------------------------------------------------
3645 :     # fwriteNewickTree( $file, $tree ) # Args reversed to writeNewickTree
3646 :     #-------------------------------------------------------------------------------
3647 :     sub fwriteNewickTree { writeNewickTree( $_[1], $_[0] ) }
3648 :    
3649 :    
3650 :     #-------------------------------------------------------------------------------
3651 :     # $treestring = strNewickTree( $tree )
3652 :     #-------------------------------------------------------------------------------
3653 : golsen 1.24 sub strNewickTree
3654 :     {
3655 : golsen 1.1 my $node = shift @_;
3656 :     strNewickSubtree( $node, "" ) . ";";
3657 :     }
3658 :    
3659 :    
3660 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3661 :     # $string = strNewickSubtree( $node, $prefix )
3662 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3663 : golsen 1.24 sub strNewickSubtree
3664 :     {
3665 : golsen 1.1 my ( $node, $prefix ) = @_;
3666 :     my $s;
3667 :    
3668 :     $s = strNewickComments( newick_c1( $node ), $prefix );
3669 :     if ( $s ) { $prefix = " " }
3670 :    
3671 :     my $ndesc;
3672 :     if ( $ndesc = newick_n_desc( $node ) ) {
3673 :     for (my $d = 1; $d <= $ndesc; $d++) {
3674 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : "," )
3675 :     . strNewickSubtree( newick_desc_i( $node, $d ), " " );
3676 :     }
3677 :    
3678 :     $s .= ")" . strNewickComments( newick_c2( $node ), " " );
3679 :     $prefix = " ";
3680 :     }
3681 :    
3682 : golsen 1.24 if ( node_has_lbl( $node ) ) {
3683 : golsen 1.1 $s .= $prefix
3684 :     . q_newick_lbl( $node )
3685 :     . strNewickComments( newick_c3( $node ), " " );
3686 :     }
3687 :    
3688 :     if ( defined( newick_x( $node ) ) ) {
3689 :     $s .= ":"
3690 :     . strNewickComments( newick_c4( $node ), " " )
3691 :     . sprintf( " %.6f", newick_x( $node ) )
3692 :     . strNewickComments( newick_c5( $node ), " " );
3693 :     }
3694 :    
3695 :     $s;
3696 :     }
3697 :    
3698 :    
3699 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3700 :     # $string = strNewickComments( $clist, $prefix )
3701 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3702 : golsen 1.24 sub strNewickComments
3703 :     {
3704 : golsen 1.1 my ( $clist, $prefix ) = @_;
3705 :     array_ref( $clist ) && ( @$clist > 0 ) || return "";
3706 :     $prefix . "[" . join( "] [", @$clist ) . "]";
3707 :     }
3708 :    
3709 :    
3710 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3711 :     # $quoted_label = q_newick_lbl( $label )
3712 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3713 : golsen 1.24 sub q_newick_lbl
3714 :     {
3715 :     node_has_lbl( $_[0] ) || return undef;
3716 :    
3717 : golsen 1.1 my $lbl = newick_lbl( $_[0] );
3718 :     if ( $lbl =~ m/^[^][()_:;,]+$/ # Anything but []()_:;,
3719 :     && $lbl !~ m/^'/ ) { # and does not start with '
3720 :     $lbl =~ s/ /_/g; # Recode blanks as _
3721 :     return $lbl;
3722 :     }
3723 :    
3724 :     else {
3725 :     $lbl =~ s/'/''/g; # Double existing single quote marks
3726 :     return q(') . $lbl . q('); # Wrap in single quote marks
3727 :     }
3728 :     }
3729 :    
3730 :    
3731 :     #===============================================================================
3732 : golsen 1.24 #
3733 : golsen 1.1 # $treestring = formatNewickTree( $tree )
3734 : golsen 1.24 #
3735 : golsen 1.1 #===============================================================================
3736 : golsen 1.24 sub formatNewickTree
3737 :     {
3738 : golsen 1.1 formatNewickSubtree( $_[0], "", "" ) . ";";
3739 :     }
3740 :    
3741 :    
3742 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3743 :     # $string = formatNewickSubtree( $node, $prefix, $indent )
3744 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3745 : golsen 1.24 sub formatNewickSubtree
3746 :     {
3747 : golsen 1.1 my ( $node, $prefix, $indent ) = @_;
3748 :     my $s;
3749 :    
3750 :     $s = formatNewickComments( newick_c1( $node ), $prefix, $indent );
3751 :     if ( $s ) { $prefix = "\n$indent" }
3752 :    
3753 :     if ( my $ndesc = newick_n_desc( $node ) ) {
3754 :     for (my $d = 1; $d <= $ndesc; $d++) {
3755 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : ",\n$indent " )
3756 :     . formatNewickSubtree( newick_desc_i( $node, $d ), " ", $indent . " " );
3757 :     }
3758 :    
3759 :     $s .= "\n$indent)" . formatNewickComments( newick_c2( $node ), " ", $indent );
3760 :     $prefix = " ";
3761 :     }
3762 :    
3763 : golsen 1.24 if ( node_has_lbl( $node ) ) {
3764 : golsen 1.1 $s .= $prefix
3765 :     . q_newick_lbl( $node )
3766 :     . formatNewickComments( newick_c3( $node ), " ", $indent );
3767 :     }
3768 :    
3769 :     if ( defined( newick_x( $node ) ) ) {
3770 :     $s .= ":"
3771 :     . formatNewickComments( newick_c4( $node ), " ", $indent )
3772 :     . sprintf(" %.6f", newick_x( $node ) )
3773 :     . formatNewickComments( newick_c5( $node ), " ", $indent );
3774 :     }
3775 :    
3776 :     $s;
3777 :     }
3778 :    
3779 :    
3780 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3781 :     # $string = formatNewickComments( $clist, $prefix, $indent )
3782 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3783 : golsen 1.24 sub formatNewickComments
3784 :     {
3785 : golsen 1.1 my ( $clist, $prefix, $indent ) = @_;
3786 :     array_ref( $clist ) && @$clist || return "";
3787 :     $prefix . "[" . join( "] [", @$clist ) . "]";
3788 :     }
3789 :    
3790 :    
3791 :     #===============================================================================
3792 : golsen 1.23 #
3793 : golsen 1.24 # $tree = read_newick_tree( $file ) # reads to a semicolon
3794 :     # @trees = read_newick_trees( $file ) # reads to end of file
3795 :     #
3796 : overbeek 1.7 #===============================================================================
3797 :    
3798 :     sub read_newick_tree
3799 :     {
3800 :     my $file = shift;
3801 :     my ( $fh, $close ) = open_input( $file );
3802 :     my $tree;
3803 :     my @lines = ();
3804 : golsen 1.9 foreach ( <$fh> )
3805 : overbeek 1.7 {
3806 :     chomp;
3807 :     push @lines, $_;
3808 :     if ( /;/ )
3809 :     {
3810 :     $tree = parse_newick_tree_str( join( ' ', @lines ) );
3811 :     last;
3812 :     }
3813 :     }
3814 :     close $fh if $close;
3815 :    
3816 :     $tree;
3817 :     }
3818 :    
3819 :    
3820 :     sub read_newick_trees
3821 :     {
3822 :     my $file = shift;
3823 :     my ( $fh, $close ) = open_input( $file );
3824 :     my @trees = ();
3825 :     my @lines = ();
3826 : golsen 1.9 foreach ( <$fh> )
3827 : overbeek 1.7 {
3828 :     chomp;
3829 :     push @lines, $_;
3830 :     if ( /;/ )
3831 :     {
3832 :     push @trees, parse_newick_tree_str( join( ' ', @lines ) );
3833 :     @lines = ()
3834 :     }
3835 :     }
3836 :     close $fh if $close;
3837 :    
3838 :     @trees;
3839 :     }
3840 :    
3841 :    
3842 :     #===============================================================================
3843 : golsen 1.1 # Tree reader adapted from the C language reader in fastDNAml
3844 :     #
3845 :     # $tree = parse_newick_tree_str( $string )
3846 : golsen 1.24 #
3847 : golsen 1.1 #===============================================================================
3848 : golsen 1.24 sub parse_newick_tree_str
3849 :     {
3850 : golsen 1.1 my $s = shift @_;
3851 :    
3852 :     my ( $ind, $rootnode ) = parse_newick_subtree( $s, 0 );
3853 :     if ( substr( $s, $ind, 1 ) ne ";") { warn "warning: tree missing ';'\n" }
3854 :     $rootnode;
3855 :     }
3856 :    
3857 :    
3858 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3859 :     # Read a subtrees recursively (everything of tree but a semicolon)
3860 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3861 : golsen 1.24 sub parse_newick_subtree
3862 :     {
3863 : golsen 1.1 my ( $s, $ind ) = @_;
3864 :    
3865 :     my $newnode = [];
3866 :     my @dlist = ();
3867 :     my ( $lbl, $x, $c1, $c2, $c3, $c4, $c5 );
3868 : golsen 1.9
3869 : golsen 1.1 ( $ind, $c1 ) = getNextTreeChar( $s, $ind ); # Comment 1
3870 :     if ( ! defined( $ind ) ) { treeParseError( "missing subtree" ) }
3871 :     if ( $c1 && @$c1 ) { set_newick_c1( $newnode, $c1 ) }
3872 :    
3873 :     if ( substr( $s, $ind, 1 ) eq "(" ) { # New internal node
3874 :     while ( ! @dlist || ( substr( $s, $ind, 1 ) eq "," ) ) {
3875 :     my $desc;
3876 :     ( $ind, $desc ) = parse_newick_subtree( $s, $ind+1 );
3877 :     if (! $ind) { return () }
3878 :     push @dlist, $desc;
3879 :     }
3880 :     if ( substr( $s, $ind, 1 ) ne ")" ) { treeParseError( "missing ')'" ) }
3881 :    
3882 :     ( $ind, $c2 ) = getNextTreeChar( $s, $ind+1 ); # Comment 2
3883 :     if ( $c2 && @$c2 ) { set_newick_c2( $newnode, $c2 ) }
3884 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Node label
3885 :     }
3886 :    
3887 :     elsif ( substr( $s, $ind, 1 ) =~ /[^][(,):;]/ ) { # New tip
3888 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Tip label
3889 :     if (! $ind) { return () }
3890 :     }
3891 :    
3892 :     @dlist || $lbl || treeParseError( "no descendant list or label" );
3893 :    
3894 :     if ( @dlist ) { set_newick_desc_ref( $newnode, \@dlist ) }
3895 :     if ( $lbl ) { set_newick_lbl( $newnode, $lbl ) }
3896 :    
3897 :     ( $ind, $c3 ) = getNextTreeChar( $s, $ind ); # Comment 3
3898 :     if ( $c3 && @$c3 ) { set_newick_c3( $newnode, $c3 ) }
3899 :    
3900 :     if (substr( $s, $ind, 1 ) eq ":") { # Branch length
3901 :     ( $ind, $c4 ) = getNextTreeChar( $s, $ind+1 ); # Comment 4
3902 :     if ( $c4 && @$c4 ) { set_newick_c4( $newnode, $c4 ) }
3903 :     ( $ind, $x ) = parseBranchLength( $s, $ind );
3904 :     if ( defined( $x ) ) { set_newick_x( $newnode, $x ) }
3905 :     ( $ind, $c5 ) = getNextTreeChar( $s, $ind ); # Comment 5
3906 :     if ( $c5 && @$c5 ) { set_newick_c5( $newnode, $c5 ) }
3907 :     }
3908 :    
3909 :     ( $ind, $newnode );
3910 :     }
3911 :    
3912 :    
3913 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3914 :     # Read a Newick tree label
3915 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3916 : golsen 1.24 sub parseTreeNodeLabel
3917 :     { # Empty string is permitted
3918 : golsen 1.1 my ( $s, $ind ) = @_;
3919 :     my ( $lbl, $c );
3920 :    
3921 :     if ( substr( $s, $ind, 1 ) eq "'") {
3922 :     my $ind1 = ++$ind;
3923 :    
3924 :     while ( ) {
3925 :     if ( ! defined( $c = substr( $s, $ind, 1 ) ) || $c eq "" ) {
3926 :     treeParseError( "missing close quote on label '" . substr( $s, $ind1 ) . "'" )
3927 :     }
3928 :     elsif ( $c ne "'" ) { $ind++ }
3929 :     elsif ( substr( $s, $ind, 2 ) eq "''" ) { $ind += 2 }
3930 :     else { last }
3931 :     }
3932 :    
3933 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
3934 :     $lbl =~ s/''/'/g;
3935 :     $ind++;
3936 :     }
3937 :    
3938 :     else {
3939 :     my $ind1 = $ind;
3940 :     while ( defined( $c = substr($s, $ind, 1) ) && $c ne "" && $c !~ /[][\s(,):;]/ ) { $ind++ }
3941 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
3942 :     $lbl =~ s/_/ /g;
3943 :     }
3944 :    
3945 :     ( $ind, $lbl );
3946 :     }
3947 :    
3948 :    
3949 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3950 :     # Read a Newick tree branch length
3951 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3952 : golsen 1.24 sub parseBranchLength
3953 :     {
3954 : golsen 1.1 my ( $s, $ind ) = @_;
3955 :    
3956 :     my $c = substr( $s, $ind, 1 );
3957 :    
3958 :     my $sign = ( $c ne "-" ) ? 1 : -1; # Sign
3959 :     if ( $c =~ /[-+]/ ) { $c = substr( $s, ++$ind, 1 ) }
3960 :    
3961 :     if ( $c !~ /^[.0-9]$/ ) { # Allows starting with decimal
3962 :     treeParseError( "invalid branch length character '$c'" )
3963 :     }
3964 :    
3965 :     my $v = 0;
3966 :     while ( $c =~ /[0-9]/ ) { # Whole number
3967 :     $v = 10 * $v + $c;
3968 :     $c = substr( $s, ++$ind, 1 );
3969 :     }
3970 :    
3971 :     if ( $c eq "." ) { # Fraction
3972 :     my $f = 0.1;
3973 :     $c = substr( $s, ++$ind, 1 );
3974 :     while ( $c =~ /[0-9]/ ) {
3975 :     $v += $f * $c;
3976 :     $f *= 0.1;
3977 :     $c = substr( $s, ++$ind, 1 );
3978 :     }
3979 :     }
3980 :    
3981 :     $v *= $sign;
3982 :    
3983 :     if ( $c =~ /[dDeEgG]/ ) { # Exponent
3984 :     $c = substr( $s, ++$ind, 1 );
3985 :     my $esign = ( $c ne "-" ) ? 1 : -1;
3986 :     if ( $c =~ /^[-+]$/ ) { $c = substr( $s, ++$ind, 1 ) }
3987 :     if ( $c !~ /^[0-9]$/ ) {
3988 :     treeParseError( "missing branch length exponent '$c'" )
3989 :     }
3990 :    
3991 :     my $e = 0;
3992 :     while ( $c =~ /[0-9]/ ) {
3993 :     $e = 10 * $e + $c;
3994 :     $c = substr( $s, ++$ind, 1 );
3995 :     }
3996 :     $e *= $esign;
3997 :     $v *= 10**$e;
3998 :     }
3999 :    
4000 :     ( $ind, $v );
4001 :     }
4002 :    
4003 :    
4004 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4005 :     # ( $index, /@commentlist ) = getNextTreeChar( $string, $index )
4006 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4007 : golsen 1.24 sub getNextTreeChar
4008 :     { # Move to next nonblank, noncomment character
4009 : golsen 1.1 my ( $s, $ind ) = @_;
4010 :    
4011 :     my @clist = ();
4012 :    
4013 :     # Skip white space
4014 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
4015 :    
4016 :     # Loop while it is a comment:
4017 :     while ( substr( $s, $ind, 1 ) eq "[" ) {
4018 :     $ind++;
4019 : golsen 1.11 my $depth = 1;
4020 :     my $ind2 = $ind;
4021 : golsen 1.1
4022 :     # Find end
4023 : golsen 1.11 while ( $depth > 0 )
4024 :     {
4025 :     if ( substr( $s, $ind2 ) =~ /^([^][]*\[)/ ) # nested [ ... ]
4026 :     {
4027 :     $ind2 += length( $1 ); # Points at char just past [
4028 :     $depth++; # If nested comments are allowed
4029 :     }
4030 :     elsif ( substr( $s, $ind2 ) =~ /^([^][]*\])/ ) # close bracket
4031 :     {
4032 :     $ind2 += length( $1 ); # Points at char just past ]
4033 :     $depth--;
4034 :     }
4035 :     else
4036 :     {
4037 :     treeParseError( "comment missing closing bracket '["
4038 :     . substr( $s, $ind ) . "'" )
4039 :     }
4040 : golsen 1.1 }
4041 :    
4042 : golsen 1.11 my $comment = substr( $s, $ind, $ind2-$ind-1 );
4043 : golsen 1.1 if ( $comment =~ m/\S/ ) { push @clist, $comment }
4044 :    
4045 : golsen 1.11 $ind = $ind2;
4046 : golsen 1.1
4047 :     # Skip white space
4048 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
4049 :     }
4050 :    
4051 :     ( $ind, @clist ? \@clist : undef )
4052 :     }
4053 :    
4054 :    
4055 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4056 :     # treeParseError( $message )
4057 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4058 :     sub treeParseError { die "Error: parse_newick_subtree: " . $_[0] . "\n" }
4059 :    
4060 :    
4061 :     #===============================================================================
4062 :     # Make a printer plot of a tree:
4063 :     #
4064 : golsen 1.13 # printer_plot_newick( $node, $file, $width, $min_dx, $dy )
4065 :     # printer_plot_newick( $node, $file, \%options )
4066 :     #
4067 :     # $node # newick tree root node
4068 :     # $file # undef = \*STDOUT, \*FH, or a file name.
4069 :     # $width # the approximate characters for the tree without labels (D = 68)
4070 :     # $min_dx # the minimum horizontal branch length (D = 2)
4071 :     # $dy # the vertical space per taxon (D = 1, most compressed)
4072 :     #
4073 :     # Options:
4074 :     #
4075 :     # dy => nat_number # the vertical space per taxon
4076 :     # chars => key # line drawing character set:
4077 :     # # html_unicode
4078 :     # # text (default)
4079 :     # min_dx => whole_number # the minimum horizontal branch length
4080 :     # width => whole_number # approximate tree width without labels
4081 : golsen 1.1 #
4082 : golsen 1.19 #===============================================================================
4083 : golsen 1.13 sub printer_plot_newick
4084 :     {
4085 :     my ( $node, $file, @opts ) = @_;
4086 : golsen 1.1
4087 : overbeek 1.7 my ( $fh, $close ) = open_output( $file );
4088 :     $fh or return;
4089 : golsen 1.1
4090 : golsen 1.13 my $html = $opts[0] && ref($opts[0]) eq 'HASH'
4091 :     && $opts[0]->{ chars }
4092 :     && $opts[0]->{ chars } =~ /html/;
4093 :     print $fh '<PRE>' if $html;
4094 :     print $fh join( "\n", text_plot_newick( $node, @opts ) ), "\n";
4095 :     print $fh "</PRE>\n" if $html;
4096 :    
4097 : golsen 1.1 if ( $close ) { close $fh }
4098 :     }
4099 :    
4100 :    
4101 : golsen 1.14 #===============================================================================
4102 :     # Character sets for printer plot trees:
4103 : golsen 1.13 #-------------------------------------------------------------------------------
4104 : golsen 1.14
4105 : golsen 1.13 my %char_set =
4106 :     ( text1 => { space => ' ',
4107 :     horiz => '-',
4108 :     vert => '|',
4109 :     el_d_r => '/',
4110 :     el_u_r => '\\',
4111 :     el_d_l => '\\',
4112 :     el_u_l => '/',
4113 :     tee_l => '+',
4114 :     tee_r => '+',
4115 :     tee_u => '+',
4116 :     tee_d => '+',
4117 :     half_l => '-',
4118 :     half_r => '-',
4119 :     half_u => '|',
4120 :     half_d => '|',
4121 :     cross => '+',
4122 :     },
4123 :     text2 => { space => ' ',
4124 :     horiz => '-',
4125 :     vert => '|',
4126 :     el_d_r => '+',
4127 :     el_u_r => '+',
4128 :     el_d_l => '+',
4129 :     el_u_l => '+',
4130 :     tee_l => '+',
4131 :     tee_r => '+',
4132 :     tee_u => '+',
4133 :     tee_d => '+',
4134 :     half_l => '-',
4135 :     half_r => '-',
4136 :     half_u => '|',
4137 :     half_d => '|',
4138 :     cross => '+',
4139 :     },
4140 : golsen 1.14 html_box => { space => '&nbsp;',
4141 :     horiz => '&#9472;',
4142 :     vert => '&#9474;',
4143 :     el_d_r => '&#9484;',
4144 :     el_u_r => '&#9492;',
4145 :     el_d_l => '&#9488;',
4146 :     el_u_l => '&#9496;',
4147 :     tee_l => '&#9508;',
4148 :     tee_r => '&#9500;',
4149 :     tee_u => '&#9524;',
4150 :     tee_d => '&#9516;',
4151 :     half_l => '&#9588;',
4152 :     half_r => '&#9590;',
4153 :     half_u => '&#9589;',
4154 :     half_d => '&#9591;',
4155 :     cross => '&#9532;',
4156 : golsen 1.13 },
4157 : golsen 1.14 utf8_box => { space => ' ',
4158 : golsen 1.13 horiz => chr(226) . chr(148) . chr(128),
4159 :     vert => chr(226) . chr(148) . chr(130),
4160 :     el_d_r => chr(226) . chr(148) . chr(140),
4161 :     el_u_r => chr(226) . chr(148) . chr(148),
4162 :     el_d_l => chr(226) . chr(148) . chr(144),
4163 :     el_u_l => chr(226) . chr(148) . chr(152),
4164 :     tee_l => chr(226) . chr(148) . chr(164),
4165 :     tee_r => chr(226) . chr(148) . chr(156),
4166 :     tee_u => chr(226) . chr(148) . chr(180),
4167 :     tee_d => chr(226) . chr(148) . chr(172),
4168 :     half_l => chr(226) . chr(149) . chr(180),
4169 :     half_r => chr(226) . chr(149) . chr(182),
4170 :     half_u => chr(226) . chr(149) . chr(181),
4171 :     half_d => chr(226) . chr(149) . chr(183),
4172 :     cross => chr(226) . chr(148) . chr(188),
4173 :     },
4174 :     );
4175 :    
4176 : golsen 1.14 %{ $char_set{ html1 } } = %{ $char_set{ text1 } };
4177 :     $char_set{ html1 }->{ space } = '&nbsp;';
4178 :    
4179 :     %{ $char_set{ html2 } } = %{ $char_set{ text2 } };
4180 :     $char_set{ html2 }->{ space } = '&nbsp;';
4181 :    
4182 : golsen 1.13 # Define some synonyms
4183 : golsen 1.14
4184 :     $char_set{ html } = $char_set{ html_box };
4185 :     $char_set{ line } = $char_set{ utf8_box };
4186 :     $char_set{ symb } = $char_set{ utf8_box };
4187 : golsen 1.13 $char_set{ text } = $char_set{ text1 };
4188 : golsen 1.14 $char_set{ utf8 } = $char_set{ utf8_box };
4189 : golsen 1.13
4190 : golsen 1.14 # Define tree formats and synonyms
4191 :    
4192 :     my %tree_format =
4193 :     ( text => 'text',
4194 :     tree_tab_lbl => 'tree_tab_lbl',
4195 :     tree_lbl => 'tree_lbl',
4196 :     chrlist_lbl => 'chrlist_lbl',
4197 :     raw => 'chrlist_lbl',
4198 :     );
4199 : golsen 1.13
4200 : golsen 1.1 #===============================================================================
4201 :     # Make a text plot of a tree:
4202 :     #
4203 : golsen 1.13 # @lines = text_plot_newick( $node, $width, $min_dx, $dy )
4204 :     # @lines = text_plot_newick( $node, \%options )
4205 :     #
4206 :     # $node # newick tree root node
4207 :     # $width # the approximate characters for the tree without labels (D = 68)
4208 :     # $min_dx # the minimum horizontal branch length (D = 2)
4209 :     # $dy # the vertical space per taxon (D = 1, most compressed)
4210 :     #
4211 :     # Options:
4212 :     #
4213 : golsen 1.14 # chars => keyword # the output character set for the tree
4214 : golsen 1.13 # dy => nat_number # the vertical space per taxon
4215 : golsen 1.14 # format => keyword # output format of each line
4216 : golsen 1.13 # min_dx => whole_number # the minimum horizontal branch length
4217 :     # width => whole_number # approximate tree width without labels
4218 : golsen 1.1 #
4219 : golsen 1.14 # Character sets:
4220 :     #
4221 :     # html # synonym of html1
4222 :     # html_box # html encoding of unicode box drawing characters
4223 :     # html1 # text1 with nonbreaking spaces
4224 :     # html2 # text2 with nonbreaking spaces
4225 :     # line # synonym of utf8_box
4226 :     # raw # pass out the internal representation
4227 :     # symb # synonym of utf8_box
4228 :     # text # synonym of text1 (Default)
4229 :     # text1 # ascii characters: - + | / \ and space
4230 :     # text2 # ascii characters: - + | + + and space
4231 :     # utf8 # synonym of utf8_box
4232 :     # utf8_box # utf8 encoding of unicode box drawing characters
4233 :     #
4234 :     # Formats for row lines:
4235 :     #
4236 :     # text # $textstring # Default
4237 :     # tree_tab_lbl # $treestr \t $labelstr
4238 :     # tree_lbl # [ $treestr, $labelstr ]
4239 :     # chrlist_lbl # [ \@treechar, $labelstr ] # Forced with raw chars
4240 :     # raw # synonym of chrlist_lbl
4241 :     #
4242 : golsen 1.1 #===============================================================================
4243 : golsen 1.13 sub text_plot_newick
4244 :     {
4245 :     my $node = shift @_;
4246 : golsen 1.1 array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
4247 : golsen 1.13
4248 : golsen 1.14 my ( $opts, $width, $min_dx, $dy, $chars, $fmt );
4249 : golsen 1.13 if ( $_[0] && ref $_[0] eq 'HASH' )
4250 :     {
4251 :     $opts = shift;
4252 :     }
4253 :     else
4254 :     {
4255 : golsen 1.14 ( $width, $min_dx, $dy ) = @_;
4256 : golsen 1.13 $opts = {};
4257 :     }
4258 :    
4259 : golsen 1.14 $chars = $opts->{ chars } || '';
4260 :     my $charH;
4261 :     $charH = $char_set{ $chars } || $char_set{ 'text1' } if ( $chars ne 'raw' );
4262 :     my $is_box = $charH eq $char_set{ html_box }
4263 :     || $charH eq $char_set{ utf8_box }
4264 :     || $chars eq 'raw';
4265 :    
4266 :     $fmt = ( $chars eq 'raw' ) ? 'chrlist_lbl' : $opts->{ format };
4267 :     $fmt = $tree_format{ $fmt || '' } || 'text';
4268 :    
4269 :     $dy ||= $opts->{ dy } || 1;
4270 :     $width ||= $opts->{ width } || 68;
4271 :     $min_dx = $opts->{ min_dx } if ( ! defined $min_dx || $min_dx < 0 );
4272 :     $min_dx = $is_box ? 1 : 2 if ( ! defined $min_dx || $min_dx < 0 );
4273 :    
4274 :     # Layout the tree:
4275 : golsen 1.1
4276 :     $min_dx = int( $min_dx );
4277 :     $dy = int( $dy );
4278 : golsen 1.5 my $x_scale = $width / ( newick_max_X( $node ) || 1 ); # Div by zero caught by RAE
4279 : golsen 1.1
4280 :     my $hash = {};
4281 :     layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );
4282 :    
4283 : golsen 1.14 # Generate the lines of the tree-one by-one:
4284 : golsen 1.1
4285 :     my ( $y1, $y2 ) = @{ $hash->{ $node } };
4286 : golsen 1.14 my @lines;
4287 :     foreach ( ( $y1 .. $y2 ) )
4288 : golsen 1.13 {
4289 : golsen 1.16 my $line = text_tree_row( $node, $hash, $_, [], 'tee_l', $dy >= 2 );
4290 : golsen 1.14 my $lbl = '';
4291 :     if ( @$line )
4292 : golsen 1.13 {
4293 : golsen 1.14 if ( $line->[-1] eq '' ) { pop @$line; $lbl = pop @$line }
4294 :     # Translate tree characters
4295 :     @$line = map { $charH->{ $_ } } @$line if $chars ne 'raw';
4296 : golsen 1.13 }
4297 :    
4298 : golsen 1.14 # Convert to requested output format:
4299 :    
4300 :     push @lines, $fmt eq 'text' ? join( '', @$line, ( $lbl ? " $lbl" : () ) )
4301 :     : $fmt eq 'text_tab_lbl' ? join( '', @$line, "\t", $lbl )
4302 :     : $fmt eq 'tree_lbl' ? [ join( '', @$line ), $lbl ]
4303 :     : $fmt eq 'chrlist_lbl' ? [ $line, $lbl ]
4304 :     : ();
4305 :     }
4306 :    
4307 :     # if ( $cells )
4308 :     # {
4309 :     # my $nmax = 0;
4310 :     # foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
4311 :     # foreach ( @lines )
4312 :     # {
4313 :     # @$_ = map { "<TD>$_</TD>" } @$_;
4314 :     # my $span = $nmax - @$_ + 1;
4315 :     # $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
4316 :     # }
4317 :     # }
4318 :     # elsif ( $tables )
4319 :     # {
4320 :     # my $nmax = 0;
4321 :     # foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
4322 :     # foreach ( @lines )
4323 :     # {
4324 :     # @$_ = map { "<TD>$_</TD>" } @$_;
4325 :     # my $span = $nmax - @$_ + 1;
4326 :     # $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
4327 :     # }
4328 :     # }
4329 :    
4330 :     wantarray ? @lines : \@lines;
4331 : golsen 1.1 }
4332 :    
4333 : golsen 1.14
4334 : golsen 1.1 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4335 : golsen 1.14 # ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd )
4336 : golsen 1.1 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4337 : golsen 1.13 sub layout_printer_plot
4338 :     {
4339 : golsen 1.14 my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd ) = @_;
4340 : golsen 1.1 array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
4341 :     hash_ref( $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
4342 :    
4343 :     my $dx = newick_x( $node );
4344 :     if ( defined( $dx ) ) {
4345 :     $dx *= $x_scale;
4346 : golsen 1.14 $dx = $min_dx if $dx < $min_dx;
4347 : golsen 1.1 }
4348 :     else {
4349 :     $dx = ( $x0 > 0 ) ? $min_dx : 0;
4350 :     }
4351 :     $dx = int( $dx + 0.4999 );
4352 :    
4353 :     my ( $x, $xmax, $y, $ymax, $y1, $y2, $yn1, $yn2 );
4354 :    
4355 :     $x = $x0 + $dx;
4356 :     $y1 = int( $y0 + 0.5 * $dy + 0.4999 );
4357 :     my @dl = newick_desc_list( $node );
4358 :    
4359 :     if ( ! @dl ) { # A tip
4360 :     $xmax = $x;
4361 :     $y = $yn1 = $yn2 = $y2 = $y1;
4362 :     $ymax = $y + 0.5 * $dy;
4363 :     }
4364 :    
4365 :     else { # A subtree
4366 :     $xmax = -1;
4367 :     my $xmaxi;
4368 :     my $yi;
4369 :     my @ylist = ();
4370 :     $ymax = $y0;
4371 :    
4372 :     foreach ( @dl ) {
4373 : golsen 1.14 ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy,
4374 :     ( 2*@ylist < @dl ? 0.5001 : 0.4999 )
4375 :     );
4376 : golsen 1.1 push @ylist, $yi;
4377 :     if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
4378 :     }
4379 :    
4380 :     # Use of y-list is overkill for saving first and last values,