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

Annotation of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.2 #
2 : golsen 1.8 # Copyright (c) 2003-2007 University of Chicago and Fellowship
3 : olson 1.2 # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 : golsen 1.9 #
7 : olson 1.2 # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 : golsen 1.9 # Public License.
10 : olson 1.2 #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 : golsen 1.1 package gjonewicklib;
19 :    
20 :     #===============================================================================
21 :     # perl functions for dealing with trees
22 :     #
23 :     # Usage:
24 :     # use gjonewicklib
25 :     #
26 :     #
27 :     #===============================================================================
28 :     # Tree data structures:
29 :     #===============================================================================
30 :     #
31 :     # Elements in newick text file are:
32 :     #
33 :     # [c1] ( desc_1, desc_2, ... ) [c2] label [c3] : [c4] x [c5]
34 :     #
35 :     # Note that:
36 : 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 :     # $bool = newick_is_tip( $noderef )
103 :     #
104 :     # set_newick_desc_ref( $noderef, $listref )
105 :     # set_newick_lbl( $noderef, $label )
106 :     # set_newick_x( $noderef, $x )
107 :     # set_newick_c1( $noderef, $listref )
108 :     # set_newick_c2( $noderef, $listref )
109 :     # set_newick_c3( $noderef, $listref )
110 :     # set_newick_c4( $noderef, $listref )
111 :     # set_newick_c5( $noderef, $listref )
112 :     # set_newick_desc_list( $noderef, @desclist )
113 : golsen 1.9 # set_newick_desc_i( $noderef1, $i, $noderef2 ) # 1-based numbering
114 : golsen 1.8 #
115 :     # $bool = newick_is_valid( $noderef ) # verify that tree is valid
116 : golsen 1.1 #
117 :     # $bool = newick_is_rooted( $noderef ) # 2 branches from root
118 :     # $bool = newick_is_unrooted( $noderef ) # 3 or more branches from root
119 :     # $bool = newick_is_tip_rooted( $noderef ) # 1 branch from root
120 :     # $bool = newick_is_bifurcating( $noderef )
121 :     #
122 :     # $n = newick_tip_count( $noderef )
123 :     # @tiprefs = newick_tip_ref_list( $noderef )
124 : golsen 1.9 # \@tiprefs = newick_tip_ref_list( $noderef )
125 : golsen 1.1 # @tips = newick_tip_list( $noderef )
126 : golsen 1.9 # \@tips = newick_tip_list( $noderef )
127 :     #
128 : golsen 1.1 # $tipref = newick_first_tip_ref( $noderef )
129 :     # $tip = newick_first_tip( $noderef )
130 : golsen 1.9 #
131 : golsen 1.1 # @tips = newick_duplicated_tips( $noderef )
132 : golsen 1.9 # \@tips = newick_duplicated_tips( $noderef )
133 :     #
134 : golsen 1.1 # $bool = newick_tip_in_tree( $noderef, $tipname )
135 : golsen 1.9 #
136 : golsen 1.1 # @tips = newick_shared_tips( $tree1, $tree2 )
137 : golsen 1.9 # \@tips = newick_shared_tips( $tree1, $tree2 )
138 : golsen 1.1 #
139 :     # $length = newick_tree_length( $noderef )
140 : golsen 1.9 #
141 :     # %tip_distances = newick_tip_distances( $noderef )
142 :     # \%tip_distances = newick_tip_distances( $noderef )
143 :     #
144 : golsen 1.1 # $xmax = newick_max_X( $noderef )
145 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $noderef )
146 : golsen 1.9 # ( $tipname, $xmax ) = newick_most_distant_tip_name( $noderef )
147 : golsen 1.1 #
148 : golsen 1.8 # Tree tip insertion point (tip is on branch of length x that
149 :     # is inserted into branch connecting node1 and node2, a distance
150 :     # x1 from node1 and x2 from node2):
151 :     #
152 : golsen 1.9 # [ $node1, $x1, $node2, $x2, $x ] = newick_tip_insertion_point( $tree, $tip )
153 : golsen 1.8 #
154 :     # Standardized label for a node in terms of intersection of 3 lowest sorting
155 :     # tips (sort is lower case):
156 :     #
157 : golsen 1.9 # @TipOrTips = std_node_name( $tree, $node )
158 : golsen 1.8 #
159 : golsen 1.1 #-------------------------------------------------------------------------------
160 :     # Paths from root of tree:
161 :     #-------------------------------------------------------------------------------
162 :     #
163 :     # Path descriptions are of form:
164 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN )
165 :     # () is returned upon failure
166 :     #
167 :     # @path = path_to_tip( $treenode, $tipname )
168 :     # @path = path_to_named_node( $treenode, $nodename )
169 :     # @path = path_to_node_ref( $treenode, $noderef )
170 :     #
171 :     # @path = path_to_node( $node, $tip1, $tip2, $tip3 ) # 3 tip names
172 :     # @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] ) # Array of tips
173 :     # @path = path_to_node( $node, $tip1 ) # Use path_to_tip
174 :     # @path = path_to_node( $node, [ $tip1 ] ) # Use path_to_tip
175 :     #
176 :     # $distance = newick_path_length( @path )
177 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
178 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
179 :     #
180 :     #
181 :     #===============================================================================
182 :     # Tree manipulations:
183 :     #===============================================================================
184 :     #
185 : overbeek 1.4 # $treecopy = copy_newick_tree( $tree )
186 : golsen 1.1 #
187 :     #-------------------------------------------------------------------------------
188 : golsen 1.8 # The following modify the existing tree, and possibly any components of that
189 : golsen 1.1 # tree that are reached by reference. If the old version is still needed, copy
190 :     # before modifying.
191 :     #-------------------------------------------------------------------------------
192 :     #
193 :     # Modify labels:
194 :     #
195 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
196 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
197 :     # $newtree = newick_relabel_tips( $node, \%new_name )
198 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
199 :     #
200 :     # Modify branches:
201 :     #
202 :     # $n_changed = newick_set_undefined_branches( $node, $x )
203 :     # $n_changed = newick_set_all_branches( $node, $x )
204 : golsen 1.5 # $n_changed = newick_fix_negative_branches( $tree )
205 : overbeek 1.7 # $node = newick_rescale_branches( $node, $factor )
206 : golsen 1.1 #
207 : golsen 1.8 # Modify comments:
208 :     #
209 :     # $node = newick_strip_comments( $node )
210 :     #
211 : golsen 1.1 # Modify rooting and/or order:
212 :     #
213 :     # $nrmtree = normalize_newick_tree( $tree )
214 :     # $revtree = reverse_newick_tree( $tree )
215 :     # $stdtree = std_unrooted_newick( $tree )
216 :     # $newtree = aesthetic_newick_tree( $tree, $direction )
217 :     # $rndtree = random_order_newick_tree( $tree )
218 :     # $newtree = reroot_newick_by_path( @path )
219 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
220 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
221 :     # $newtree = reroot_newick_to_node( $tree, @node )
222 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
223 : golsen 1.9 # $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
224 : golsen 1.5 # $newtree = reroot_newick_to_approx_midpoint( $tree ) # unweighted
225 :     # $newtree = reroot_newick_to_approx_midpoint_w( $tree ) # weight by tips
226 : golsen 1.1 # $newtree = uproot_tip_rooted_newick( $tree )
227 :     # $newtree = uproot_newick( $tree )
228 :     #
229 :     # $newtree = prune_from_newick( $tree, $tip )
230 :     # $newtree = newick_subtree( $tree, @tips )
231 :     # $newtree = newick_subtree( $tree, \@tips )
232 :     #
233 : golsen 1.5 # $newtree = collapse_zero_length_branches( $tree )
234 :     #
235 : golsen 1.8 # $node = newick_insert_at_node( $node, $subtree )
236 :     # $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
237 :     #
238 : golsen 1.1 #===============================================================================
239 : golsen 1.9 # Tree neighborhood: subtree of n tips to represent a larger tree.
240 :     #===============================================================================
241 :     #
242 :     # Focus around root:
243 :     #
244 :     # $subtree = root_neighborhood_representative_tree( $tree, $n, \%tip_priority )
245 :     # $subtree = root_neighborhood_representative_tree( $tree, $n )
246 :     # @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
247 :     # @tips = root_neighborhood_representative_tips( $tree, $n )
248 :     # \@tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
249 :     # \@tips = root_neighborhood_representative_tips( $tree, $n )
250 :     #
251 :     # Focus around a tip insertion point (the tip is not in the subtree):
252 :     #
253 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )
254 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )
255 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
256 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
257 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
258 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
259 :     #
260 :     #===============================================================================
261 : golsen 1.1 # Tree reading and writing:
262 :     #===============================================================================
263 : golsen 1.9 # Write machine-readable trees:
264 : golsen 1.1 #
265 :     # writeNewickTree( $tree )
266 :     # writeNewickTree( $tree, $file )
267 : overbeek 1.7 # writeNewickTree( $tree, \*FH )
268 :     # fwriteNewickTree( $file, $tree ) # Matches the C arg list for f... I/O
269 : golsen 1.1 # $treestring = swriteNewickTree( $tree )
270 :     # $treestring = formatNewickTree( $tree )
271 : golsen 1.9 #
272 :     # Write human-readable trees:
273 :     #
274 : golsen 1.1 # @textlines = text_plot_newick( $node, $width, $min_dx, $dy )
275 :     # printer_plot_newick( $node, $file, $width, $min_dx, $dy )
276 :     #
277 : golsen 1.9 # Read trees:
278 :     #
279 : overbeek 1.7 # $tree = read_newick_tree( $file ) # reads to a semicolon
280 :     # @trees = read_newick_trees( $file ) # reads to end of file
281 :     # $tree = parse_newick_tree_str( $string )
282 : golsen 1.1 #
283 :     #===============================================================================
284 :    
285 :    
286 : golsen 1.8 use Carp;
287 :     use Data::Dumper;
288 : golsen 1.9 use strict;
289 : golsen 1.8
290 : golsen 1.1 require Exporter;
291 :    
292 :     our @ISA = qw(Exporter);
293 :     our @EXPORT = qw(
294 : golsen 1.9 is_overbeek_tree
295 :     is_gjonewick_tree
296 : overbeek 1.7 overbeek_to_gjonewick
297 :     gjonewick_to_overbeek
298 : golsen 1.8 newick_is_valid
299 : golsen 1.1 newick_is_rooted
300 :     newick_is_unrooted
301 :     tree_rooted_on_tip
302 :     newick_is_bifurcating
303 :     newick_tip_count
304 : golsen 1.9 newick_tip_ref_list
305 : golsen 1.1 newick_tip_list
306 : golsen 1.9
307 : golsen 1.1 newick_first_tip
308 :     newick_duplicated_tips
309 :     newick_tip_in_tree
310 :     newick_shared_tips
311 :    
312 :     newick_tree_length
313 : golsen 1.9 newick_tip_distances
314 : golsen 1.1 newick_max_X
315 :     newick_most_distant_tip_ref
316 :     newick_most_distant_tip_name
317 : golsen 1.9
318 :     newick_tip_insertion_point
319 :    
320 : golsen 1.1 std_newick_name
321 :    
322 :     path_to_tip
323 :     path_to_named_node
324 :     path_to_node_ref
325 :     path_to_node
326 :    
327 :     newick_path_length
328 :     tip_to_tip_distance
329 :     node_to_node_distance
330 :    
331 : overbeek 1.4 copy_newick_tree
332 : golsen 1.1
333 :     newick_relabel_nodes
334 :     newick_relabel_nodes_i
335 :     newick_relabel_tips
336 :     newick_relabel_tips_i
337 :    
338 :     newick_set_undefined_branches
339 :     newick_set_all_branches
340 : golsen 1.5 newick_fix_negative_branches
341 : overbeek 1.7 newick_rescale_branches
342 : golsen 1.1
343 : golsen 1.8 newick_strip_comments
344 :    
345 : golsen 1.1 normalize_newick_tree
346 :     reverse_newick_tree
347 :     std_unrooted_newick
348 :     aesthetic_newick_tree
349 :     unaesthetic_newick_tree
350 :     random_order_newick_tree
351 :    
352 :     reroot_newick_by_path
353 :     reroot_newick_to_tip
354 :     reroot_newick_next_to_tip
355 :     reroot_newick_to_node
356 :     reroot_newick_to_node_ref
357 : golsen 1.9 reroot_newick_between_nodes
358 : golsen 1.1 reroot_newick_to_approx_midpoint
359 : golsen 1.5 reroot_newick_to_approx_midpoint_w
360 : golsen 1.1 uproot_tip_rooted_newick
361 :     uproot_newick
362 :    
363 :     prune_from_newick
364 :     newick_subtree
365 : golsen 1.5 collapse_zero_length_branches
366 : golsen 1.1
367 : golsen 1.8 newick_insert_at_node
368 :     newick_insert_between_nodes
369 :    
370 : golsen 1.9 root_neighborhood_representative_tree
371 :     root_neighborhood_representative_tips
372 :     tip_neighborhood_representative_tree
373 :     tip_neighborhood_representative_tips
374 :    
375 : golsen 1.1 writeNewickTree
376 :     fwriteNewickTree
377 :     strNewickTree
378 :     formatNewickTree
379 : overbeek 1.7
380 :     read_newick_tree
381 :     read_newick_trees
382 : golsen 1.1 parse_newick_tree_str
383 :    
384 :     printer_plot_newick
385 :     text_plot_newick
386 :     );
387 :    
388 :     our @EXPORT_OK = qw(
389 :     newick_desc_ref
390 :     newick_lbl
391 :     newick_x
392 :     newick_c1
393 :     newick_c2
394 :     newick_c3
395 :     newick_c4
396 :     newick_c5
397 :     newick_desc_list
398 :     newick_n_desc
399 :     newick_desc_i
400 :     newick_is_tip
401 :     newick_is_valid
402 :    
403 :     set_newick_desc_ref
404 :     set_newick_lbl
405 :     set_newick_x
406 :     set_newick_c1
407 :     set_newick_c2
408 :     set_newick_c3
409 :     set_newick_c4
410 :     set_newick_c5
411 :    
412 :     set_newick_desc_list
413 :     set_newick_desc_i
414 :    
415 :     add_to_newick_branch
416 :     dump_tree
417 :     );
418 :    
419 :    
420 :     #-------------------------------------------------------------------------------
421 :     # Internally used definitions
422 :     #-------------------------------------------------------------------------------
423 :    
424 :     sub array_ref { ref( $_[0] ) eq "ARRAY" }
425 :     sub hash_ref { ref( $_[0] ) eq "HASH" }
426 :    
427 :    
428 :     #===============================================================================
429 : golsen 1.9 # Interconvert overbeek and gjonewick trees:
430 : overbeek 1.7 #===============================================================================
431 :    
432 : golsen 1.9 sub is_overbeek_tree { array_ref( $_[0] ) && array_ref( $_[0]->[2] ) }
433 :    
434 :     sub is_gjonewick_tree { array_ref( $_[0] ) && array_ref( $_[0]->[0] ) }
435 :    
436 : overbeek 1.7 sub overbeek_to_gjonewick
437 :     {
438 :     return () unless ref( $_[0] ) eq 'ARRAY';
439 :     my ( $lbl, $x, $desc ) = @{ $_[0] };
440 :     my ( undef, @desc ) = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
441 :     [ [ map { overbeek_to_gjonewick( $_ ) } @desc ], $lbl, $x ]
442 :     }
443 :    
444 :     sub gjonewick_to_overbeek
445 :     {
446 :     return () unless ref( $_[0] ) eq 'ARRAY';
447 :     my ( $desc, $lbl, $x ) = @{ $_[0] };
448 :     my @desc = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
449 :     my $parent = $_[1];
450 :     my $node = [ $lbl, $x, undef, [] ];
451 :     $node->[2] = [ $parent, map { gjonewick_to_overbeek( $_, $node ) } @desc ];
452 :     return $node;
453 :     }
454 :    
455 : golsen 1.9
456 : overbeek 1.7 #===============================================================================
457 : golsen 1.1 # Extract tree structure values:
458 :     #===============================================================================
459 :     #
460 :     # $listref = newick_desc_ref( $noderef )
461 :     # $string = newick_lbl( $noderef )
462 :     # $real = newick_x( $noderef )
463 :     # $listref = newick_c1( $noderef )
464 :     # $listref = newick_c2( $noderef )
465 :     # $listref = newick_c3( $noderef )
466 :     # $listref = newick_c4( $noderef )
467 :     # $listref = newick_c5( $noderef )
468 :     # @list = newick_desc_list( $noderef )
469 :     # $int = newick_n_desc( $noderef )
470 :     # $listref = newick_desc_i( $noderef )
471 :     # $bool = node_is_tip( $noderef )
472 :     # $bool = node_is_valid( $noderef )
473 :     #
474 :     #-------------------------------------------------------------------------------
475 :    
476 :     sub newick_desc_ref { $_[0]->[0] } # = ${$_[0]}[0]
477 : golsen 1.8 sub newick_lbl { ref($_[0]) ? $_[0]->[1] : Carp::confess() }
478 : golsen 1.1 sub newick_x { $_[0]->[2] }
479 :     sub newick_c1 { $_[0]->[3] }
480 :     sub newick_c2 { $_[0]->[4] }
481 :     sub newick_c3 { $_[0]->[5] }
482 :     sub newick_c4 { $_[0]->[6] }
483 :     sub newick_c5 { $_[0]->[7] }
484 :    
485 :     sub newick_desc_list {
486 :     my $node = $_[0];
487 :     ! array_ref( $node ) ? undef :
488 :     array_ref( $node->[0] ) ? @{ $node->[0] } :
489 :     () ;
490 :     }
491 :    
492 :     sub newick_n_desc {
493 :     my $node = $_[0];
494 :     ! array_ref( $node ) ? undef :
495 :     array_ref( $node->[0] ) ? scalar @{ $node->[0] } :
496 :     0 ;
497 :     }
498 :    
499 :     sub newick_desc_i {
500 :     my ( $node, $i ) = @_;
501 :     ! array_ref( $node ) ? undef :
502 :     array_ref( $node->[0] ) ? $node->[0]->[$i-1] :
503 :     undef ;
504 :     }
505 :    
506 :     sub node_is_tip {
507 :     my $node = $_[0];
508 :     ! array_ref( $node ) ? undef : # Not a node ref
509 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 0 : # Empty descend list?
510 :     1 ; # No descend list
511 :     }
512 :    
513 :     sub node_is_valid { # An array ref with nonempty descend list or a label
514 :     my $node = $_[0];
515 :     array_ref( $node ) && ( array_ref( $node->[0] ) && @{ $node->[0] }
516 :     || defined( $node->[1] )
517 :     )
518 :     }
519 :    
520 :    
521 :     #-------------------------------------------------------------------------------
522 :     # Set tree structure values
523 :     #-------------------------------------------------------------------------------
524 :    
525 :     sub set_newick_desc_ref { $_[0]->[0] = $_[1] }
526 :     sub set_newick_lbl { $_[0]->[1] = $_[1] }
527 :     sub set_newick_x { $_[0]->[2] = $_[1] }
528 :     sub set_newick_c1 { $_[0]->[3] = $_[1] }
529 :     sub set_newick_c2 { $_[0]->[4] = $_[1] }
530 :     sub set_newick_c3 { $_[0]->[5] = $_[1] }
531 :     sub set_newick_c4 { $_[0]->[6] = $_[1] }
532 :     sub set_newick_c5 { $_[0]->[7] = $_[1] }
533 :    
534 :     sub set_newick_desc_list {
535 :     my $node = shift;
536 :     array_ref( $node ) || return;
537 :     if ( array_ref( $node->[0] ) ) { @{ $node->[0] } = @_ }
538 :     else { $node->[0] = [ @_ ] }
539 :     }
540 :    
541 :     sub set_newick_desc_i {
542 :     my ( $node1, $i, $node2 ) = @_;
543 :     array_ref( $node1 ) && array_ref( $node2 ) || return;
544 :     if ( array_ref( $node1->[0] ) ) { $node1->[0]->[$i-1] = $node2 }
545 :     else { $node1->[0] = [ $node2 ] }
546 :     }
547 :    
548 :    
549 :     #===============================================================================
550 :     # Some tree property tests:
551 :     #===============================================================================
552 : golsen 1.8 # Tree is valid?
553 :     #
554 :     # $bool = newick_is_valid( $node, $verbose )
555 :     #-------------------------------------------------------------------------------
556 :     sub newick_is_valid
557 :     {
558 :     my $node = shift;
559 :    
560 :     if ( ! array_ref( $node ) )
561 :     {
562 :     print STDERR "Node is not array reference\n" if $_[0];
563 :     return 0;
564 :     }
565 :    
566 :     my @node = @$node;
567 :     if ( ! @node )
568 :     {
569 :     print STDERR "Node is empty array reference\n" if $_[0];
570 :     return 0;
571 :     }
572 :    
573 :     # Must have descendant or label:
574 :    
575 :     if ( ! ( array_ref( $node[0] ) && @{ $node[0] } ) && ! $node[2] )
576 :     {
577 :     print STDERR "Node has neither descendant nor label\n" if $_[0];
578 :     return 0;
579 :     }
580 :    
581 :     # If comments are present, they must be array references
582 :    
583 :     foreach ( ( @node > 3 ) ? @node[ 3 .. $#node ] : () )
584 :     {
585 :     if ( defined( $_ ) && ! array_ref( $_ ) )
586 :     {
587 :     print STDERR "Node has neither descendant or label\n" if $_[0];
588 :     return 0;
589 :     }
590 :     }
591 :    
592 :     # Inspect the descendants:
593 :    
594 :     foreach ( array_ref( $node[0] ) ? @{ $node[0] } : () )
595 :     {
596 :     newick_is_valid( $_, @_ ) || return 0
597 :     }
598 :    
599 :     return 1;
600 :     }
601 :    
602 :    
603 :     #-------------------------------------------------------------------------------
604 : golsen 1.1 # Tree is rooted (2 branches at root node)?
605 :     #
606 :     # $bool = newick_is_rooted( $node )
607 :     #-------------------------------------------------------------------------------
608 :     sub newick_is_rooted {
609 :     my $node = $_[0];
610 :     ! array_ref( $node ) ? undef : # Not a node ref
611 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 2 : # 2 branches
612 :     0 ; # No descend list
613 :     }
614 :    
615 :    
616 :     #-------------------------------------------------------------------------------
617 :     # Tree is unrooted (> 2 branches at root node)?
618 :     #
619 :     # $bool = newick_is_unrooted( $node )
620 :     #-------------------------------------------------------------------------------
621 :     sub newick_is_unrooted {
622 :     my $node = $_[0];
623 :     ! array_ref( $node ) ? undef : # Not a node ref
624 :     array_ref( $node->[0] ) ? @{ $node->[0] } >= 3 : # Over 2 branches
625 :     0 ; # No descend list
626 :     }
627 :    
628 :    
629 :     #-------------------------------------------------------------------------------
630 :     # Tree is rooted on a tip (1 branch at root node)?
631 :     #
632 :     # $bool = newick_is_tip_rooted( $node )
633 :     #-------------------------------------------------------------------------------
634 :     sub newick_is_tip_rooted {
635 :     my $node = $_[0];
636 :     ! array_ref( $node ) ? undef : # Not a node ref
637 :     array_ref( $node->[0] ) ? @{ $node->[0] } == 1 : # 1 branch
638 :     0 ; # No descend list
639 :     }
640 :    
641 :     #===============================================================================
642 :     # Everything below this point refers to parts of the tree structure using
643 :     # only the routines above.
644 :     #===============================================================================
645 :     # Tree is bifurcating? If so, return number of descendents of root node.
646 :     #
647 :     # $n_desc = newick_is_bifurcating( $node )
648 :     #-------------------------------------------------------------------------------
649 :     sub newick_is_bifurcating {
650 :     my ( $node, $not_root ) = @_;
651 :     if ( ! array_ref( $node ) ) { return undef } # Bad arg
652 :    
653 :     my $n = newick_n_desc( $node );
654 :     $n == 0 && ! $not_root ? 0 :
655 :     $n == 1 && $not_root ? 0 :
656 :     $n == 3 && $not_root ? 0 :
657 :     $n > 3 ? 0 :
658 :     $n > 2 && ! newick_is_bifurcating( newick_desc_i( $node, 3, 1 ) ) ? 0 :
659 :     $n > 1 && ! newick_is_bifurcating( newick_desc_i( $node, 2, 1 ) ) ? 0 :
660 :     $n > 0 && ! newick_is_bifurcating( newick_desc_i( $node, 1, 1 ) ) ? 0 :
661 :     $n
662 :     }
663 :    
664 :    
665 :     #-------------------------------------------------------------------------------
666 :     # Number of tips:
667 :     #
668 :     # $n = newick_tip_count( $node )
669 :     #-------------------------------------------------------------------------------
670 :     sub newick_tip_count {
671 :     my ( $node, $not_root ) = @_;
672 :    
673 :     my $imax = newick_n_desc( $node );
674 :     if ( $imax < 1 ) { return 1 }
675 :    
676 :     # Special case for tree rooted on tip
677 :    
678 :     my $n = ( $imax == 1 && ( ! $not_root ) ) ? 1 : 0;
679 :    
680 :     foreach ( newick_desc_list( $node ) ) { $n += newick_tip_count( $_, 1 ) }
681 :    
682 :     $n;
683 :     }
684 :    
685 :    
686 :     #-------------------------------------------------------------------------------
687 :     # List of tip nodes:
688 :     #
689 : golsen 1.9 # @tips = newick_tip_ref_list( $noderef )
690 :     # \@tips = newick_tip_ref_list( $noderef )
691 : golsen 1.1 #-------------------------------------------------------------------------------
692 :     sub newick_tip_ref_list {
693 :     my ( $node, $not_root ) = @_;
694 :    
695 :     my $imax = newick_n_desc( $node );
696 :     if ( $imax < 1 ) { return $node }
697 :    
698 :     my @list = ();
699 :    
700 :     # Tree rooted on tip?
701 :     if ( $imax == 1 && ! $not_root && newick_lbl( $node ) ) { push @list, $node }
702 :    
703 :     foreach ( newick_desc_list( $node ) ) {
704 :     push @list, newick_tip_ref_list( $_, 1 );
705 :     }
706 :    
707 : golsen 1.9 wantarray ? @list : \@list;
708 : golsen 1.1 }
709 :    
710 :    
711 :     #-------------------------------------------------------------------------------
712 :     # List of tips:
713 :     #
714 :     # @tips = newick_tip_list( $node )
715 : golsen 1.9 # \@tips = newick_tip_list( $node )
716 : golsen 1.1 #-------------------------------------------------------------------------------
717 :     sub newick_tip_list {
718 : golsen 1.9 my @tips = map { newick_lbl( $_ ) } newick_tip_ref_list( $_[0] );
719 :     wantarray ? @tips : \@tips;
720 : golsen 1.1 }
721 :    
722 :    
723 :     #-------------------------------------------------------------------------------
724 :     # First tip node in tree:
725 :     #
726 :     # $tipref = newick_first_tip_ref( $node )
727 :     #-------------------------------------------------------------------------------
728 :     sub newick_first_tip_ref {
729 :     my ( $node, $not_root ) = @_;
730 :     valid_node( $node ) || return undef;
731 :    
732 :     # Arrived at tip, or start of a tip-rooted tree?
733 :     my $n = newick_n_desc( $node );
734 :     if ( ( $n < 1 ) || ( $n == 1 && ! $not_root ) ) { return $node }
735 :    
736 :     newick_first_tip_ref( newick_desc_i( $node, 1 ), 1 );
737 :     }
738 :    
739 :    
740 :     #-------------------------------------------------------------------------------
741 :     # First tip name in tree:
742 :     #
743 :     # $tip = newick_first_tip( $node )
744 :     #-------------------------------------------------------------------------------
745 :     sub newick_first_tip {
746 :     my ( $noderef ) = @_;
747 :    
748 :     my $tipref;
749 :     array_ref( $tipref = newick_first_tip_ref( $noderef ) ) ? newick_lbl( $tipref )
750 : golsen 1.9 : undef;
751 : golsen 1.1 }
752 :    
753 :    
754 :     #-------------------------------------------------------------------------------
755 :     # List of duplicated tip labels.
756 :     #
757 :     # @tips = newick_duplicated_tips( $node )
758 : golsen 1.9 # \@tips = newick_duplicated_tips( $node )
759 : golsen 1.1 #-------------------------------------------------------------------------------
760 :     sub newick_duplicated_tips {
761 : golsen 1.9 my @tips = &duplicates( newick_tip_list( $_[0] ) );
762 :     wantarray ? @tips : \@tips;
763 : golsen 1.1 }
764 :    
765 :    
766 :     #-------------------------------------------------------------------------------
767 :     # Tip in tree?
768 :     #
769 :     # $bool = newick_tip_in_tree( $node, $tipname )
770 :     #-------------------------------------------------------------------------------
771 :     sub newick_tip_in_tree {
772 :     my ( $node, $tip, $not_root ) = @_;
773 :    
774 :     my $n = newick_n_desc( $node );
775 :     if ( $n < 1 ) { return ( newick_lbl( $node ) eq $tip) ? 1 : 0 }
776 :    
777 :     # Special case for tree rooted on tip
778 :    
779 :     if ( $n == 1 && ( ! $not_root ) && newick_lbl( $node ) eq $tip ) { return 1 }
780 :    
781 :     foreach ( newick_desc_list( $node ) ) {
782 :     if ( newick_tip_in_tree( $_, $tip, 1 ) ) { return 1 }
783 :     }
784 :    
785 :     0; # Fall through means not found
786 :     }
787 :    
788 :    
789 :     #-------------------------------------------------------------------------------
790 :     # Tips shared between 2 trees.
791 :     #
792 :     # @tips = newick_shared_tips( $tree1, $tree2 )
793 : golsen 1.9 # \@tips = newick_shared_tips( $tree1, $tree2 )
794 : golsen 1.1 #-------------------------------------------------------------------------------
795 :     sub newick_shared_tips {
796 : golsen 1.9 my ( $tree1, $tree2 ) = @_;
797 :     my $tips1 = newick_tip_list( $tree1 );
798 :     my $tips2 = newick_tip_list( $tree2 );
799 :     my @tips = &intersection( $tips1, $tips2 );
800 :     wantarray ? @tips : \@tips;
801 : golsen 1.1 }
802 :    
803 :    
804 :     #-------------------------------------------------------------------------------
805 :     # Tree length.
806 :     #
807 :     # $length = newick_tree_length( $node )
808 :     #-------------------------------------------------------------------------------
809 :     sub newick_tree_length {
810 :     my ( $node, $not_root ) = @_;
811 :    
812 :     my $x = $not_root ? newick_x( $node ) : 0;
813 :     defined( $x ) || ( $x = 1 ); # Convert undefined to 1
814 :    
815 :     foreach ( newick_desc_list( $node ) ) { $x += newick_tree_length( $_, 1 ) }
816 :    
817 :     $x;
818 :     }
819 :    
820 :    
821 :     #-------------------------------------------------------------------------------
822 : golsen 1.9 # Hash of tip nodes and corresponding distances from root:
823 :     #
824 :     # %tip_distances = newick_tip_distances( $node )
825 :     # \%tip_distances = newick_tip_distances( $node )
826 :     #-------------------------------------------------------------------------------
827 :     sub newick_tip_distances
828 :     {
829 :     my ( $node, $x, $hash ) = @_;
830 :     my $root = ! $hash;
831 :     ref( $hash ) eq 'HASH' or $hash = {};
832 :    
833 :     $x ||= 0;
834 :     $x += newick_x( $node ) || 0;
835 :    
836 :     # Is it a tip?
837 :    
838 :     my $n_desc = newick_n_desc( $node );
839 :     if ( ! $n_desc )
840 :     {
841 :     $hash->{ newick_lbl( $node ) } = $x;
842 :     return $hash;
843 :     }
844 :    
845 :     # Tree rooted on tip?
846 :    
847 :     if ( ( $n_desc == 1 ) && $root && ( newick_lbl( $node ) ) )
848 :     {
849 :     $hash->{ newick_lbl( $node ) } = 0; # Distance to root is zero
850 :     }
851 :    
852 :     foreach ( newick_desc_list( $node ) )
853 :     {
854 :     newick_tip_distances( $_, $x, $hash );
855 :     }
856 :    
857 :     wantarray ? %$hash : $hash;
858 :     }
859 :    
860 :    
861 :     #-------------------------------------------------------------------------------
862 : golsen 1.1 # Tree max X.
863 :     #
864 :     # $xmax = newick_max_X( $node )
865 :     #-------------------------------------------------------------------------------
866 :     sub newick_max_X {
867 :     my ( $node, $not_root ) = @_;
868 :    
869 :     my $xmax = 0;
870 :     foreach ( newick_desc_list( $node ) ) {
871 :     my $x = newick_max_X( $_, 1 );
872 :     if ( $x > $xmax ) { $xmax = $x }
873 :     }
874 :    
875 :     my $x = $not_root ? newick_x( $node ) : 0;
876 :     $xmax + ( defined( $x ) ? $x : 1 ); # Convert undefined to 1
877 :     }
878 :    
879 :    
880 :     #-------------------------------------------------------------------------------
881 :     # Most distant tip from root: distance and path.
882 :     #
883 :     # ( $xmax, @path ) = newick_most_distant_tip_path( $tree )
884 :     #-------------------------------------------------------------------------------
885 :     sub newick_most_distant_tip_path {
886 :     my ( $node, $not_root ) = @_;
887 :    
888 :     my $imax = newick_n_desc( $node );
889 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
890 :     my @pmax = ();
891 :     for ( my $i = 1; $i <= $imax; $i++ ) {
892 :     my ( $x, @path ) = newick_most_distant_tip_path( newick_desc_i( $node, $i ), 1 );
893 :     if ( $x > $xmax ) { $xmax = $x; @pmax = ( $i, @path ) }
894 :     }
895 :    
896 :     my $x = $not_root ? newick_x( $node ) : 0;
897 :     $xmax += defined( $x ) ? $x : 0; # Convert undefined to 1
898 :     ( $xmax, $node, @pmax );
899 :     }
900 :    
901 :    
902 :     #-------------------------------------------------------------------------------
903 :     # Most distant tip from root, and its distance.
904 :     #
905 :     # ( $tipref, $xmax ) = newick_most_distant_tip_ref( $tree )
906 :     #-------------------------------------------------------------------------------
907 :     sub newick_most_distant_tip_ref {
908 :     my ( $node, $not_root ) = @_;
909 :    
910 :     my $imax = newick_n_desc( $node );
911 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
912 :     my $tmax = $node;
913 :     foreach ( newick_desc_list( $node ) ) {
914 :     my ( $t, $x ) = newick_most_distant_tip_ref( $_, 1 );
915 :     if ( $x > $xmax ) { $xmax = $x; $tmax = $t }
916 :     }
917 :    
918 :     my $x = $not_root ? newick_x( $node ) : 0;
919 :     $xmax += defined( $x ) ? $x : 1; # Convert undefined to 1
920 :     ( $tmax, $xmax );
921 :     }
922 :    
923 :    
924 :     #-------------------------------------------------------------------------------
925 :     # Name of most distant tip from root, and its distance.
926 :     #
927 :     # ( $tipname, $xmax ) = newick_most_distant_tip_name( $tree )
928 :     #-------------------------------------------------------------------------------
929 :     sub newick_most_distant_tip_name {
930 :     my ( $tipref, $xmax ) = newick_most_distant_tip_ref( $_[0] );
931 :     ( newick_lbl( $tipref ), $xmax )
932 :     }
933 :    
934 :    
935 :     #-------------------------------------------------------------------------------
936 : golsen 1.8 # Tree tip insertion point (with standard node labels):
937 :     #
938 :     # [ $node1, $x1, $node2, $x2, $x ]
939 :     # = newick_tip_insertion_point( $tree, $tip )
940 :     #
941 :     # Which means: tip is on a branch of length x that is inserted into the branch
942 :     # connecting node1 and node2, at distance x1 from node1 and x2 from node2.
943 :     #
944 :     # x1 +------ n1a (lowest sorting tip of this subtree)
945 :     # +--------n1
946 :     # | +------n1b (lowest sorting tip of this subtree)
947 :     # tip-------n
948 :     # x | +------------- n2a (lowest sorting tip of this subtree)
949 :     # +------n2
950 :     # x2 +-------- n2b (lowest sorting tip of this subtree)
951 :     #
952 :     # The designations of 1 vs 2, and a vs b are chosen such that:
953 :     # n1a < n1b, and n2a < n2b, and n1a < n2a
954 :     #
955 :     # Then the statandard description becomes:
956 :     #
957 :     # [ [ $n1a, min(n1b,n2a), max(n1b,n2a) ], x1,
958 :     # [ $n2a, min(n2b,n1a), max(n2b,n1a) ], x2,
959 :     # x
960 :     # ]
961 :     #
962 :     #-------------------------------------------------------------------------------
963 :     sub newick_tip_insertion_point
964 :     {
965 :     my ( $tree, $tip ) = @_;
966 :     $tree && $tip && ref( $tree ) eq 'ARRAY' or return undef;
967 :     $tree = copy_newick_tree( $tree ) or return undef;
968 :     $tree = reroot_newick_to_tip( $tree, $tip ) or return undef;
969 :     my $node = $tree;
970 :    
971 :     my $x = 0; # Distance to node
972 :     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
973 :     $node = $dl->[0]; # Node adjacent to tip
974 :     $dl = newick_desc_ref( $node );
975 :     while ( $dl && ( @$dl == 1 ) ) # Traverse unbranched nodes
976 :     {
977 :     $node = $dl->[0];
978 :     $x += newick_x( $node );
979 :     $dl = newick_desc_ref( $node );
980 :     }
981 :     $x += newick_x( $node );
982 :    
983 :     # We are now at the node that is the insertion point.
984 :     # Is it a tip?
985 :    
986 :     my @description;
987 :    
988 :     if ( ( ! $dl ) || @$dl == 0 )
989 :     {
990 :     @description = ( [ newick_lbl( $node ) ], 0, undef, 0, $x );
991 :     }
992 :    
993 :     # Is it a trifurcation or greater, in which case it does not go
994 :     # away with tip deletion?
995 :    
996 :     elsif ( @$dl > 2 )
997 :     {
998 :     @description = ( [ std_node_name( $node, $node ) ], 0, undef, 0, $x );
999 :     }
1000 :    
1001 :     # The node is bifurcating. We need to describe it.
1002 :    
1003 :     else
1004 :     {
1005 : golsen 1.9 my ( $n1, $x1 ) = describe_descendant( $dl->[0] );
1006 :     my ( $n2, $x2 ) = describe_descendant( $dl->[1] );
1007 : golsen 1.8
1008 :     if ( @$n1 == 2 ) { push @$n1, $n2->[0] }
1009 :     if ( @$n2 == 2 )
1010 :     {
1011 :     @$n2 = sort { lc $a cmp lc $b } ( @$n2, $n1->[0] );
1012 :     }
1013 :     if ( @$n1 == 3 ) { @$n2 = sort { lc $a cmp lc $b } @$n2 }
1014 :     @description = ( $n1, $x1, $n2, $x2, $x );
1015 :     }
1016 :    
1017 :     return wantarray ? @description : \@description;
1018 :     }
1019 :    
1020 :    
1021 : golsen 1.9 sub describe_descendant
1022 : golsen 1.8 {
1023 :     my $node = shift;
1024 :    
1025 :     my $x = 0; # Distance to node
1026 :     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
1027 :     while ( $dl && ( @$dl == 1 ) ) # Traverse unbranched nodes
1028 :     {
1029 :     $node = $dl->[0];
1030 : golsen 1.9 $x += newick_x( $node );
1031 : golsen 1.8 $dl = newick_desc_ref( $node );
1032 :     }
1033 :     $x += newick_x( $node );
1034 :    
1035 :     # Is it a tip? Return list of one tip;
1036 :    
1037 :     if ( ( ! $dl ) || @$dl == 0 )
1038 :     {
1039 :     return ( [ newick_lbl( $node ) ], $x );
1040 :     }
1041 :    
1042 :     # Get tips of each descendent, keeping lowest sorting from each.
1043 :     # Return the two lowest of those (the third will come from the
1044 :     # other side of the original node).
1045 :    
1046 : golsen 1.9 my @rep_tips = sort { lc $a cmp lc $b }
1047 :     map { ( sort { lc $a cmp lc $b } newick_tip_list( $_ ) )[0] }
1048 :     @$dl;
1049 :     return ( [ @rep_tips[0,1] ], $x );
1050 : golsen 1.8 }
1051 :    
1052 :    
1053 :     #-------------------------------------------------------------------------------
1054 : golsen 1.1 # Standard node name:
1055 :     # Tip label if at a tip
1056 :     # Three sorted tip labels intersecting at node, each being smallest
1057 :     # of all the tips of their subtrees
1058 :     #
1059 : golsen 1.9 # @TipOrTips = std_node_name( $tree, $node )
1060 : golsen 1.1 #-------------------------------------------------------------------------------
1061 :     sub std_node_name {
1062 :     my $tree = $_[0];
1063 :    
1064 :     # Node reference is last element of path to node
1065 :    
1066 :     my $noderef = ( path_to_node( @_ ) )[-1];
1067 :     defined( $noderef ) || return ();
1068 :    
1069 :     if ( node_is_tip( $noderef ) || $noderef eq $tree ) { # Is it a tip?
1070 :     return newick_lbl( $noderef );
1071 :     }
1072 :    
1073 :     # Work through lists of tips in descendant subtrees, removing them from
1074 :     # @rest, and keeping the best tip for each subtree.
1075 :    
1076 : golsen 1.8 my @rest = newick_tip_list( $tree );
1077 : golsen 1.9 my @best = map
1078 :     {
1079 : golsen 1.8 my @tips = sort { lc $a cmp lc $b } newick_tip_list( $_ );
1080 : golsen 1.9 @rest = &set_difference( \@rest, \@tips );
1081 : golsen 1.1 $tips[0];
1082 : golsen 1.9 } newick_desc_list( $noderef );
1083 : golsen 1.1
1084 :     # Best of the rest of the tree
1085 :     push @best, ( sort { lc $a cmp lc $b } @rest )[0];
1086 :    
1087 :     # Take the top 3, in order:
1088 :    
1089 :     ( @best >= 3 ) ? ( sort { lc $a cmp lc $b } @best )[0 .. 2] : ();
1090 :     }
1091 :    
1092 :    
1093 :     #===============================================================================
1094 :     # Functions to find paths in trees.
1095 :     #
1096 :     # Path descriptions are of form:
1097 :     # ( $node0, $i0, $node1, $i1, $node2, $i2, ..., $nodeN ) # Always odd
1098 :     # () is returned upon failure
1099 :     #
1100 :     # Numbering of descendants is 1-based.
1101 :     #===============================================================================
1102 :     # Path to tip:
1103 :     #
1104 :     # @path = path_to_tip( $treenode, $tipname )
1105 :     #-------------------------------------------------------------------------------
1106 :     sub path_to_tip {
1107 :     my ( $node, $tip, @path0 ) = @_;
1108 :    
1109 :     push @path0, $node;
1110 :     my $imax = newick_n_desc( $node );
1111 :     if ( $imax < 1 ) { return ( newick_lbl( $node ) eq $tip ) ? @path0 : () }
1112 :    
1113 :     # Special case for tree rooted on tip
1114 :    
1115 :     if ( ( $imax == 1 ) # One descendant
1116 :     && ( @path0 == 1 ) # First step in path
1117 :     && ( newick_lbl( $node ) eq $tip ) # Label matches
1118 :     ) { return @path0 }
1119 :    
1120 :     my @path;
1121 :     for (my $i = 1; $i <= $imax; $i++ ) {
1122 :     @path = path_to_tip( newick_desc_i( $node, $i ), $tip, ( @path0, $i ) );
1123 :     if ( @path ) { return @path }
1124 :     }
1125 :    
1126 :     (); # Not found
1127 :     }
1128 :    
1129 :    
1130 :     #-------------------------------------------------------------------------------
1131 :     # Path to named node.
1132 :     # Like path to tip, but will find named internal nodes as well.
1133 :     #
1134 :     # @path = path_to_named_node( $treenode, $name )
1135 :     #-------------------------------------------------------------------------------
1136 :     sub path_to_named_node {
1137 :     my ( $node, $name, @path0 ) = @_;
1138 :    
1139 :     push @path0, $node;
1140 :     if ( newick_lbl( $node ) eq $name ) { return @path0 }
1141 :    
1142 :     my @path;
1143 :     my $imax = newick_n_desc( $node );
1144 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1145 :     @path = path_to_named_node( newick_desc_i( $node, $i ), $name, ( @path0, $i ) );
1146 :     if ( @path ) { return @path }
1147 :     }
1148 :    
1149 :     (); # Not found
1150 :     }
1151 :    
1152 :    
1153 :     #-------------------------------------------------------------------------------
1154 :     # Path to node reference.
1155 :     #
1156 :     # @path = path_to_node_ref( $treenode, $noderef )
1157 :     #-------------------------------------------------------------------------------
1158 :     sub path_to_node_ref {
1159 :     my ( $node, $noderef, @path0 ) = @_;
1160 :    
1161 :     push @path0, $node;
1162 :     if ( $node eq $noderef ) { return @path0 }
1163 :    
1164 :     my @path;
1165 :     my $imax = newick_n_desc( $node );
1166 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1167 :     @path = path_to_node_ref( newick_desc_i( $node, $i ), $noderef, ( @path0, $i ) );
1168 :     if ( @path ) { return @path }
1169 :     }
1170 :    
1171 :     (); # Not found
1172 :     }
1173 :    
1174 :    
1175 :     #-------------------------------------------------------------------------------
1176 :     # Path to node, as defined by 1 or 3 tips.
1177 :     #
1178 :     # @path = path_to_node( $node, $tip1, $tip2, $tip3 ) # 3 tip names
1179 :     # @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] ) # Allow array ref
1180 :     # @path = path_to_node( $node, $tip1 ) # Use path_to_tip
1181 :     # @path = path_to_node( $node, [ $tip1 ] ) # Use path_to_tip
1182 :     #-------------------------------------------------------------------------------
1183 :     sub path_to_node {
1184 :     my ( $node, $tip1, $tip2, $tip3 ) = @_;
1185 :     array_ref( $node ) && defined( $tip1 ) || return ();
1186 :    
1187 :     # Allow arg 2 to be an array reference
1188 :     if ( array_ref( $tip1 ) ) { ( $tip1, $tip2, $tip3 ) = @$tip1 }
1189 :    
1190 :     my @p1 = path_to_tip( $node, $tip1 ); # Path to first tip
1191 :     @p1 || return (); # Was the tip found?
1192 :     defined( $tip2 ) && defined( $tip3 ) || return @p1; # Two more defined?
1193 :    
1194 :     my @p2 = path_to_tip( $node, $tip2 );
1195 :     my @p3 = path_to_tip( $node, $tip3 );
1196 :     @p2 && @p3 || return (); # Were they found?
1197 :    
1198 :     # Find the common prefix for each pair of paths
1199 : golsen 1.9 my @p12 = &common_prefix( \@p1, \@p2 );
1200 :     my @p13 = &common_prefix( \@p1, \@p3 );
1201 :     my @p23 = &common_prefix( \@p2, \@p3 );
1202 : golsen 1.1
1203 :     # Return the longest common prefix of any two paths
1204 :     ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :
1205 :     ( @p13 >= @p23 ) ? @p13 :
1206 :     @p23 ;
1207 :     }
1208 :    
1209 :    
1210 :     #-------------------------------------------------------------------------------
1211 :     # Distance along path.
1212 :     #
1213 :     # $distance = newick_path_length( @path )
1214 :     #-------------------------------------------------------------------------------
1215 :     sub newick_path_length {
1216 :     my $node = shift; # Discard the first node
1217 :     array_ref( $node ) || return undef;
1218 :     @_ ? distance_along_path_2( @_ ) : 0;
1219 :     }
1220 :    
1221 :    
1222 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1223 :     # This expects to get path minus root node:
1224 :     #
1225 :     # $distance = distance_along_path_2( @path )
1226 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1227 :     sub distance_along_path_2 {
1228 :     shift; # Discard descendant number
1229 :     my $node = shift;
1230 :     array_ref( $node ) || return undef;
1231 :     my $d1 = newick_x( $node );
1232 : golsen 1.8 my $d2 = @_ ? distance_along_path_2( @_ ) : 0;
1233 : golsen 1.1 defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1234 :     }
1235 :    
1236 :    
1237 :     #-------------------------------------------------------------------------------
1238 :     # Tip-to-tip distance.
1239 :     #
1240 :     # $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
1241 :     #-------------------------------------------------------------------------------
1242 :     sub tip_to_tip_distance {
1243 :     my ( $node, $tip1, $tip2 ) = @_;
1244 :    
1245 :     array_ref( $node ) && defined( $tip1 )
1246 :     && defined( $tip2 ) || return undef;
1247 :     my @p1 = path_to_tip( $node, $tip1 );
1248 :     my @p2 = path_to_tip( $node, $tip2 );
1249 :     @p1 && @p2 || return undef; # Were they found?
1250 :    
1251 :     # Find the unique suffixes of the two paths
1252 : golsen 1.9 my ( $suf1, $suf2 ) = &unique_suffixes( \@p1, \@p2 ); # Common node is lost
1253 : golsen 1.1 my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
1254 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
1255 :    
1256 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1257 :     }
1258 :    
1259 :    
1260 :     #-------------------------------------------------------------------------------
1261 :     # Node-to-node distance.
1262 :     # Nodes can be: $tipname
1263 :     # [ $tipname ]
1264 :     # [ $tipname1, $tipname2, $tipname3 ]
1265 :     #
1266 :     # $distance = node_to_node_distance( $tree, $node1, $node2 )
1267 :     #-------------------------------------------------------------------------------
1268 :     sub node_to_node_distance {
1269 :     my ( $node, $node1, $node2 ) = @_;
1270 :    
1271 :     array_ref( $node ) && defined( $node1 )
1272 :     && defined( $node2 ) || return undef;
1273 : golsen 1.8 my @p1 = path_to_node( $node, $node1 ) or return undef;
1274 :     my @p2 = path_to_node( $node, $node2 ) or return undef;
1275 : golsen 1.1
1276 :     # Find the unique suffixes of the two paths
1277 : golsen 1.9 my ( $suf1, $suf2 ) = &unique_suffixes( \@p1, \@p2 ); # Common node is lost
1278 : golsen 1.1 my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
1279 :     my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
1280 :    
1281 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1282 :     }
1283 :    
1284 :    
1285 :     #===============================================================================
1286 :     # Tree manipulations:
1287 :     #===============================================================================
1288 :     # Copy tree.
1289 :     # Lists are copied, except that references to empty lists go to undef.
1290 :     # Only defined fields are added, so tree list may be shorter than 8 fields.
1291 :     #
1292 : overbeek 1.4 # $treecopy = copy_newick_tree( $tree )
1293 : golsen 1.1 #-------------------------------------------------------------------------------
1294 : overbeek 1.4 sub copy_newick_tree {
1295 : golsen 1.1 my ( $node ) = @_;
1296 :     array_ref( $node ) || return undef;
1297 :    
1298 :     my $nn = []; # Reference to a new node structure
1299 :     # Build a new descendant list, if not empty
1300 :     my @dl = newick_desc_list( $node );
1301 : overbeek 1.4 set_newick_desc_ref( $nn, @dl ? [ map { copy_newick_tree( $_ ) } @dl ]
1302 : golsen 1.1 : undef
1303 :     );
1304 :    
1305 :     # Copy label and x, if defined
1306 :     my ( $l, $x );
1307 :     if ( defined( $l = newick_lbl( $node ) ) ) { set_newick_lbl( $nn, $l ) }
1308 :     if ( defined( $x = newick_x( $node ) ) ) { set_newick_x( $nn, $x ) }
1309 :    
1310 :     # Build new comment lists, when not empty ( does not extend array unless
1311 :     # necessary)
1312 :     my $c;
1313 :     if ( $c = newick_c1( $node ) and @$c ) { set_newick_c1( $nn, [ @$c ] ) }
1314 :     if ( $c = newick_c2( $node ) and @$c ) { set_newick_c2( $nn, [ @$c ] ) }
1315 :     if ( $c = newick_c3( $node ) and @$c ) { set_newick_c3( $nn, [ @$c ] ) }
1316 :     if ( $c = newick_c4( $node ) and @$c ) { set_newick_c4( $nn, [ @$c ] ) }
1317 :     if ( $c = newick_c5( $node ) and @$c ) { set_newick_c5( $nn, [ @$c ] ) }
1318 :    
1319 :     $nn;
1320 :     }
1321 :    
1322 :    
1323 :     #-------------------------------------------------------------------------------
1324 :     # Use a hash to relabel the nodes in a newick tree.
1325 :     #
1326 :     # $newtree = newick_relabel_nodes( $node, \%new_name )
1327 :     #-------------------------------------------------------------------------------
1328 :     sub newick_relabel_nodes {
1329 :     my ( $node, $new_name ) = @_;
1330 :    
1331 :     my ( $lbl, $new );
1332 :     if ( defined( $lbl = newick_lbl( $node ) )
1333 :     && ( $lbl ne "" )
1334 :     && defined( $new = $new_name->{ $lbl } )
1335 :     ) {
1336 :     set_newick_lbl( $node, $new );
1337 :     }
1338 :    
1339 :     foreach ( newick_desc_list( $node ) ) {
1340 :     newick_relabel_nodes( $_, $new_name );
1341 :     }
1342 :    
1343 :     $node;
1344 :     }
1345 :    
1346 :    
1347 :     #-------------------------------------------------------------------------------
1348 :     # Use a hash to relabel the nodes in a newick tree (case insensitive).
1349 :     #
1350 :     # $newtree = newick_relabel_nodes_i( $node, \%new_name )
1351 :     #-------------------------------------------------------------------------------
1352 :     sub newick_relabel_nodes_i {
1353 :     my ( $node, $new_name ) = @_;
1354 :    
1355 :     # Add any necessary lowercase keys to the hash:
1356 :    
1357 :     my $lc_lbl;
1358 :     foreach ( keys %$new_name ) {
1359 :     $lc_lbl = lc $_;
1360 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
1361 :     }
1362 :    
1363 :     newick_relabel_nodes_i2( $node, $new_name );
1364 :     }
1365 :    
1366 :    
1367 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1368 :     # Do the actual relabeling
1369 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1370 :     sub newick_relabel_nodes_i2 {
1371 :     my ( $node, $new_name ) = @_;
1372 :    
1373 :     my ( $lbl, $new );
1374 :     if ( defined( $lbl = newick_lbl( $node ) )
1375 :     && ( $lbl ne "" )
1376 :     && defined( $new = $new_name->{ lc $lbl } )
1377 :     ) {
1378 :     set_newick_lbl( $node, $new );
1379 :     }
1380 :    
1381 :     foreach ( newick_desc_list( $node ) ) {
1382 :     newick_relabel_nodes_i2( $_, $new_name );
1383 :     }
1384 :    
1385 :     $node;
1386 :     }
1387 :    
1388 :    
1389 :     #-------------------------------------------------------------------------------
1390 :     # Use a hash to relabel the tips in a newick tree.
1391 :     #
1392 :     # $newtree = newick_relabel_tips( $node, \%new_name )
1393 :     #-------------------------------------------------------------------------------
1394 :     sub newick_relabel_tips {
1395 :     my ( $node, $new_name ) = @_;
1396 :    
1397 :     my @desc = newick_desc_list( $node );
1398 :    
1399 :     if ( @desc ) {
1400 :     foreach ( @desc ) { newick_relabel_tips( $_, $new_name ) }
1401 :     }
1402 :     else {
1403 :     my ( $lbl, $new );
1404 :     if ( defined( $lbl = newick_lbl( $node ) )
1405 :     && ( $lbl ne "" )
1406 :     && defined( $new = $new_name->{ $lbl } )
1407 :     ) {
1408 :     set_newick_lbl( $node, $new );
1409 :     }
1410 :     }
1411 :    
1412 :     $node;
1413 :     }
1414 :    
1415 :    
1416 :     #-------------------------------------------------------------------------------
1417 :     # Use a hash to relabel the tips in a newick tree (case insensitive).
1418 :     #
1419 :     # $newtree = newick_relabel_tips_i( $node, \%new_name )
1420 :     #-------------------------------------------------------------------------------
1421 :     sub newick_relabel_tips_i {
1422 :     my ( $node, $new_name ) = @_;
1423 :    
1424 :     # Add any necessary lowercase keys to the hash:
1425 :    
1426 :     my $lc_lbl;
1427 :     foreach ( keys %$new_name ) {
1428 :     $lc_lbl = lc $_;
1429 :     ( $lc_lbl eq $_ ) or ( $new_name->{ $lc_lbl } = $new_name->{ $_ } );
1430 :     }
1431 :    
1432 :     newick_relabel_tips_i2( $node, $new_name );
1433 :     }
1434 :    
1435 :    
1436 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1437 :     # Do the actual relabeling
1438 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1439 :     sub newick_relabel_tips_i2 {
1440 :     my ( $node, $new_name ) = @_;
1441 :    
1442 :     my @desc = newick_desc_list( $node );
1443 :    
1444 :     if ( @desc ) {
1445 :     foreach ( @desc ) { newick_relabel_tips_i2( $_, $new_name ) }
1446 :     }
1447 :     else {
1448 :     my ( $lbl, $new );
1449 :     if ( defined( $lbl = newick_lbl( $node ) )
1450 :     && ( $lbl ne "" )
1451 :     && defined( $new = $new_name->{ lc $lbl } )
1452 :     ) {
1453 :     set_newick_lbl( $node, $new );
1454 :     }
1455 :     }
1456 :    
1457 :     $node;
1458 :     }
1459 :    
1460 :    
1461 :     #-------------------------------------------------------------------------------
1462 :     # Set undefined branch lenghts (except root) to length x.
1463 :     #
1464 :     # $n_changed = newick_set_undefined_branches( $node, $x )
1465 :     #-------------------------------------------------------------------------------
1466 :     sub newick_set_undefined_branches {
1467 :     my ( $node, $x, $not_root ) = @_;
1468 :    
1469 :     my $n = 0;
1470 :     if ( $not_root && ! defined( newick_x( $node ) ) ) {
1471 :     set_newick_x( $node, $x );
1472 :     $n++;
1473 :     }
1474 :    
1475 :     foreach ( newick_desc_list( $node ) ) {
1476 :     $n += newick_set_undefined_branches( $_, $x, 1 );
1477 :     }
1478 :    
1479 :     $n;
1480 :     }
1481 :    
1482 :    
1483 :     #-------------------------------------------------------------------------------
1484 :     # Set all branch lenghts (except root) to length x.
1485 :     #
1486 :     # $n_changed = newick_set_all_branches( $node, $x )
1487 :     #-------------------------------------------------------------------------------
1488 :     sub newick_set_all_branches {
1489 :     my ( $node, $x, $not_root ) = @_;
1490 :    
1491 :     my $n = 0;
1492 : overbeek 1.7 if ( $not_root )
1493 :     {
1494 : golsen 1.1 set_newick_x( $node, $x );
1495 :     $n++;
1496 :     }
1497 :    
1498 : overbeek 1.7 foreach ( newick_desc_list( $node ) )
1499 :     {
1500 : golsen 1.1 $n += newick_set_all_branches( $_, $x, 1 );
1501 :     }
1502 :    
1503 :     $n;
1504 :     }
1505 :    
1506 :    
1507 :     #-------------------------------------------------------------------------------
1508 : overbeek 1.7 # Rescale all branch lenghts by factor.
1509 :     #
1510 :     # $node = newick_rescale_branches( $node, $factor )
1511 :     #-------------------------------------------------------------------------------
1512 :     sub newick_rescale_branches {
1513 :     my ( $node, $factor ) = @_;
1514 :    
1515 :     my $x = newick_x( $node );
1516 :     set_newick_x( $node, $factor * $x ) if $x;
1517 :    
1518 :     foreach ( newick_desc_list( $node ) )
1519 :     {
1520 :     newick_rescale_branches( $_, $factor );
1521 :     }
1522 :    
1523 :     $node;
1524 :     }
1525 :    
1526 :    
1527 :     #-------------------------------------------------------------------------------
1528 : golsen 1.5 # Set negative branches to zero. The original tree is modfied.
1529 :     #
1530 :     # $n_changed = newick_fix_negative_branches( $tree )
1531 :     #-------------------------------------------------------------------------------
1532 :     sub newick_fix_negative_branches {
1533 :     my ( $tree ) = @_;
1534 :     array_ref( $tree ) or return undef;
1535 :     my $n_changed = 0;
1536 :     my $x = newick_x( $tree );
1537 :     if ( defined( $x ) and $x < 0 )
1538 :     {
1539 :     set_newick_x( $tree, 0 );
1540 :     $n_changed++;
1541 :     }
1542 :    
1543 :     foreach ( newick_desc_list( $tree ) )
1544 :     {
1545 :     $n_changed += newick_fix_negative_branches( $_ );
1546 :     }
1547 :    
1548 :     $n_changed;
1549 :     }
1550 :    
1551 :    
1552 :     #-------------------------------------------------------------------------------
1553 : golsen 1.8 # Remove comments from a newick tree (e.g., before writing for phylip).
1554 :     #
1555 :     # $node = newick_strip_comments( $node )
1556 :     #-------------------------------------------------------------------------------
1557 :     sub newick_strip_comments {
1558 :     my ( $node ) = @_;
1559 :    
1560 :     @$node = @$node[ 0 .. 2 ];
1561 :     foreach ( newick_desc_list( $node ) ) { newick_strip_comments( $_ ) }
1562 :     $node;
1563 :     }
1564 :    
1565 :    
1566 :     #-------------------------------------------------------------------------------
1567 : golsen 1.1 # Normalize tree order (in place).
1568 :     #
1569 :     # ( $tree, $label1 ) = normalize_newick_tree( $tree )
1570 :     #-------------------------------------------------------------------------------
1571 :     sub normalize_newick_tree {
1572 :     my ( $node ) = @_;
1573 :    
1574 :     my @descends = newick_desc_list( $node );
1575 :     if ( @descends == 0 ) { return ( $node, lc newick_lbl( $node ) ) }
1576 :    
1577 : golsen 1.9 my %hash = map { ( normalize_newick_tree($_) )[1] => $_ } @descends;
1578 : golsen 1.1 my @keylist = sort { $a cmp $b } keys %hash;
1579 :     set_newick_desc_list( $node, map { $hash{$_} } @keylist );
1580 :    
1581 :     ( $node, $keylist[0] );
1582 :     }
1583 :    
1584 :    
1585 :     #-------------------------------------------------------------------------------
1586 :     # Reverse tree order (in place).
1587 :     #
1588 :     # $tree = reverse_newick_tree( $tree )
1589 :     #-------------------------------------------------------------------------------
1590 :     sub reverse_newick_tree {
1591 :     my ( $node ) = @_;
1592 :    
1593 :     my @descends = newick_desc_list( $node );
1594 :     if ( @descends ) {
1595 :     set_newick_desc_list( $node, reverse @descends );
1596 :     foreach ( @descends ) { reverse_newick_tree( $_ ) }
1597 :     }
1598 :     $node;
1599 :     }
1600 :    
1601 :    
1602 :     #-------------------------------------------------------------------------------
1603 :     # Standard unrooted tree (in place).
1604 :     #
1605 :     # $stdtree = std_unrooted_newick( $tree )
1606 :     #-------------------------------------------------------------------------------
1607 :     sub std_unrooted_newick {
1608 :     my ( $tree ) = @_;
1609 :    
1610 :     my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
1611 :     ( normalize_newick_tree( reroot_newick_next_to_tip( $tree, $mintip ) ) )[0];
1612 :     }
1613 :    
1614 :    
1615 :     #-------------------------------------------------------------------------------
1616 :     # Move largest groups to periphery of tree (in place).
1617 :     #
1618 :     # dir <= -2 for up-sweeping tree (big groups always first),
1619 :     # = -1 for big group first, balanced tree,
1620 :     # = 0 for balanced tree,
1621 :     # = 1 for small group first, balanced tree, and
1622 :     # >= 2 for down-sweeping tree (small groups always top)
1623 :     #
1624 :     # $tree = aesthetic_newick_tree( $treeref, $dir )
1625 :     #-------------------------------------------------------------------------------
1626 :     sub aesthetic_newick_tree {
1627 :     my ( $tree, $dir ) = @_;
1628 :     my %cnt;
1629 :    
1630 :     $dir = ! $dir ? 0 : # Undefined or zero
1631 :     $dir <= -2 ? -1000000 :
1632 :     $dir < 0 ? -1 :
1633 :     $dir >= 2 ? 1000000 :
1634 :     1 ;
1635 :     build_tip_count_hash( $tree, \%cnt );
1636 :     reorder_by_tip_count( $tree, \%cnt, $dir );
1637 :     }
1638 :    
1639 :    
1640 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1641 :     # Build a hash to look up the number of descendants of each node.
1642 :     # Access count with $cntref->{$noderef}
1643 :     #
1644 :     # $count = build_tip_count_hash( $node, $cnt_hash_ref )
1645 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1646 :     sub build_tip_count_hash {
1647 :     my ( $node, $cntref ) = @_;
1648 :     my ( $i, $cnt );
1649 :    
1650 :     if ( newick_n_desc( $node ) < 1 ) { $cnt = 1 }
1651 :     else {
1652 :     $cnt = 0;
1653 :     foreach ( newick_desc_list( $node ) ) {
1654 :     $cnt += build_tip_count_hash( $_, $cntref );
1655 :     }
1656 :     }
1657 :    
1658 :     $cntref->{$node} = $cnt;
1659 :     $cnt;
1660 :     }
1661 :    
1662 :    
1663 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1664 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
1665 :     # dir < 0 for upward branch (big group first),
1666 :     # = 0 for no change, and
1667 :     # > 0 for downward branch (small group first).
1668 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1669 :     sub reorder_by_tip_count {
1670 :     my ( $node, $cntref, $dir ) = @_;
1671 :    
1672 :     my $nd = newick_n_desc( $node );
1673 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1674 :    
1675 :     # Reorder this subtree:
1676 :    
1677 :     my $dl_ref = newick_desc_ref( $node );
1678 :     if ( $dir < 0 ) { # Big group first
1679 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1680 :     }
1681 :     elsif ( $dir > 0 ) { # Small group first
1682 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1683 :     }
1684 :    
1685 :     # Reorder within descendant subtrees:
1686 :    
1687 :     my $step = 0;
1688 :     if ( abs( $dir ) < 1e5 ) {
1689 :     $dir = 1 - $nd; # Midgroup => as is
1690 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1691 :     $step = 2;
1692 :     }
1693 :    
1694 :     for ( my $i = 0; $i < $nd; $i++ ) {
1695 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1696 :     $dir += $step;
1697 :     }
1698 :    
1699 :     $node;
1700 :     }
1701 :    
1702 :    
1703 :     #-------------------------------------------------------------------------------
1704 :     # Move smallest groups to periphery of tree (in place).
1705 :     #
1706 :     # dir <= -2 for up-sweeping tree (big groups always first),
1707 :     # = -1 for big group first, balanced tree,
1708 :     # = 0 for balanced tree,
1709 :     # = 1 for small group first, balanced tree, and
1710 :     # >= 2 for down-sweeping tree (small groups always top)
1711 :     #
1712 :     # $tree = unaesthetic_newick_tree( $treeref, $dir )
1713 :     #-------------------------------------------------------------------------------
1714 : golsen 1.9 sub unaesthetic_newick_tree
1715 :     {
1716 : golsen 1.1 my ( $tree, $dir ) = @_;
1717 :     my %cnt;
1718 :    
1719 :     $dir = ! $dir ? 0 : # Undefined or zero
1720 :     $dir <= -2 ? -1000000 :
1721 :     $dir < 0 ? -1 :
1722 :     $dir >= 2 ? 1000000 :
1723 :     1 ;
1724 :     build_tip_count_hash( $tree, \%cnt );
1725 :     reorder_against_tip_count( $tree, \%cnt, $dir );
1726 :     }
1727 :    
1728 :    
1729 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1730 :     # $node = reorder_by_tip_count( $node, $cntref, $dir )
1731 :     # dir < 0 for upward branch (big group first),
1732 :     # = 0 for no change, and
1733 :     # > 0 for downward branch (small group first).
1734 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1735 : golsen 1.9 sub reorder_against_tip_count
1736 :     {
1737 : golsen 1.1 my ( $node, $cntref, $dir ) = @_;
1738 :    
1739 :     my $nd = newick_n_desc( $node );
1740 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1741 :    
1742 :     # Reorder this subtree:
1743 :    
1744 :     my $dl_ref = newick_desc_ref( $node );
1745 :     if ( $dir > 0 ) { # Big group first
1746 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1747 :     }
1748 :     elsif ( $dir < 0 ) { # Small group first
1749 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1750 :     }
1751 :    
1752 :     # Reorder within descendant subtrees:
1753 :    
1754 :     my $step = 0;
1755 :     if (abs( $dir ) < 1e5) {
1756 :     $dir = 1 - $nd; # Midgroup => as is
1757 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1758 :     $step = 2;
1759 :     }
1760 :    
1761 :     for ( my $i = 0; $i < $nd; $i++ ) {
1762 :     reorder_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1763 :     $dir += $step;
1764 :     }
1765 :    
1766 :     $node;
1767 :     }
1768 :    
1769 :    
1770 :     #-------------------------------------------------------------------------------
1771 :     # Randomize descendant order at each node (in place).
1772 :     #
1773 :     # $tree = random_order_newick_tree( $tree )
1774 :     #-------------------------------------------------------------------------------
1775 : golsen 1.9 sub random_order_newick_tree
1776 :     {
1777 : golsen 1.1 my ( $node ) = @_;
1778 :    
1779 :     my $nd = newick_n_desc( $node );
1780 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1781 :    
1782 :     # Reorder this subtree:
1783 :    
1784 :     my $dl_ref = newick_desc_ref( $node );
1785 : golsen 1.9 @$dl_ref = &random_order( @$dl_ref );
1786 : golsen 1.1
1787 :     # Reorder descendants:
1788 :    
1789 :     foreach ( @$dl_ref ) { random_order_newick_tree( $_ ) }
1790 :    
1791 :     $node;
1792 :     }
1793 :    
1794 :    
1795 :     #-------------------------------------------------------------------------------
1796 :     # Reroot a tree to the node that lies at the end of a path.
1797 :     #
1798 :     # $newtree = reroot_newick_by_path( @path )
1799 :     #-------------------------------------------------------------------------------
1800 : golsen 1.9 sub reroot_newick_by_path
1801 :     {
1802 : golsen 1.1 my ( $node1, $path1, @rest ) = @_;
1803 :     array_ref( $node1 ) || return undef; # Always expect a node
1804 :    
1805 :     defined( $path1 ) && @rest || return $node1; # If no path, we're done
1806 :    
1807 :     my $node2 = $rest[0]; # Next element in path is node 2
1808 :     newick_desc_i( $node1, $path1 ) eq $node2 || return undef; # Check link
1809 :    
1810 :     # Remove node 2 from node 1 descendant list. Could use a simple splice:
1811 :     #
1812 :     # splice( @$dl1, $path1-1, 1 );
1813 :     #
1814 : golsen 1.8 # But the following maintains the cyclic order of the nodes:
1815 : golsen 1.1
1816 :     my $dl1 = newick_desc_ref( $node1 );
1817 :     my $nd1 = @$dl1;
1818 :     if ( $path1 == 1 ) { shift @$dl1 }
1819 :     elsif ( $path1 == $nd1 ) { pop @$dl1 }
1820 :     else { @$dl1 = ( @$dl1[ $path1 .. $nd1-1 ]
1821 :     , @$dl1[ 0 .. $path1-2 ]
1822 :     )
1823 : golsen 1.8 }
1824 : golsen 1.1
1825 :     # Append node 1 to node 2 descendant list (does not alter numbering):
1826 :    
1827 :     my $dl2 = newick_desc_ref( $node2 );
1828 :     if ( array_ref( $dl2 ) ) { push @$dl2, $node1 }
1829 : golsen 1.8 else { set_newick_desc_list( $node2, $node1 ) }
1830 : golsen 1.1
1831 :     # Move c1 comments from node 1 to node 2:
1832 :    
1833 :     my $C11 = newick_c1( $node1 );
1834 :     my $C12 = newick_c1( $node2 );
1835 :     ! defined( $C11 ) || set_newick_c1( $node1, undef ); # Remove them from node 1
1836 : golsen 1.8 if ( $C12 && @$C12 ) { # If node 2 comments and
1837 :     if ( $C11 && @$C11 ) { unshift @$C12, @$C11 } # Node 1, prefix 1 to 2
1838 : golsen 1.1 }
1839 : golsen 1.8 elsif ( $C11 && @$C11 ) { set_newick_c1( $node2, $C11 ) } # Otherwise move node 1 link
1840 : golsen 1.1
1841 :     # Swap branch lengths and comments for reversal of link direction:
1842 :    
1843 :     my $x1 = newick_x( $node1 );
1844 :     my $x2 = newick_x( $node2 );
1845 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node1, $x2 );
1846 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_newick_x( $node2, $x1 );
1847 :    
1848 :     my $c41 = newick_c4( $node1 );
1849 :     my $c42 = newick_c4( $node2 );
1850 :     ! defined( $c42 ) || ! @$c42 || set_newick_c4( $node1, $c42 );
1851 :     ! defined( $c41 ) || ! @$c41 || set_newick_c4( $node2, $c41 );
1852 :    
1853 :     my $c51 = newick_c5( $node1 );
1854 :     my $c52 = newick_c5( $node2 );
1855 :     ! defined( $c52 ) || ! @$c52 || set_newick_c5( $node1, $c52 );
1856 :     ! defined( $c51 ) || ! @$c51 || set_newick_c5( $node2, $c51 );
1857 :    
1858 :     reroot_newick_by_path( @rest ); # Node 2 is first element of rest
1859 :     }
1860 :    
1861 :    
1862 :     #-------------------------------------------------------------------------------
1863 :     # Move root of tree to named tip.
1864 :     #
1865 :     # $newtree = reroot_newick_to_tip( $tree, $tip )
1866 :     #-------------------------------------------------------------------------------
1867 :     sub reroot_newick_to_tip {
1868 :     my ( $tree, $tipname ) = @_;
1869 :     reroot_newick_by_path( path_to_tip( $tree, $tipname ) );
1870 :     }
1871 :    
1872 :    
1873 :     #-------------------------------------------------------------------------------
1874 :     # Move root of tree to be node adjacent to a named tip.
1875 :     #
1876 :     # $newtree = reroot_newick_next_to_tip( $tree, $tip )
1877 :     #-------------------------------------------------------------------------------
1878 :     sub reroot_newick_next_to_tip {
1879 :     my ( $tree, $tipname ) = @_;
1880 :     my @path = path_to_tip( $tree, $tipname );
1881 :     @path || return undef;
1882 :     @path == 1 ? reroot_newick_by_path( $tree, 1, newick_desc_i( $tree, 1 ) )
1883 :     : reroot_newick_by_path( @path[0 .. @path-3] );
1884 :     }
1885 :    
1886 :    
1887 :     #-------------------------------------------------------------------------------
1888 :     # Move root of tree to a node, defined by 1 or 3 tip names.
1889 :     #
1890 :     # $newtree = reroot_newick_to_node( $tree, @node )
1891 :     #-------------------------------------------------------------------------------
1892 :     sub reroot_newick_to_node {
1893 :     reroot_newick_by_path( path_to_node( @_ ) );
1894 :     }
1895 :    
1896 :    
1897 :     #-------------------------------------------------------------------------------
1898 :     # Move root of tree to a node, defined by reference.
1899 :     #
1900 :     # $newtree = reroot_newick_to_node_ref( $tree, $noderef )
1901 :     #-------------------------------------------------------------------------------
1902 :     sub reroot_newick_to_node_ref {
1903 :     my ( $tree, $node ) = @_;
1904 :     reroot_newick_by_path( path_to_node_ref( $tree, $node ) );
1905 :     }
1906 :    
1907 :    
1908 :     #-------------------------------------------------------------------------------
1909 : golsen 1.9 # Reroot a newick tree along the path between 2 nodes:
1910 :     #
1911 :     # $tree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
1912 :     #-------------------------------------------------------------------------------
1913 :     sub reroot_newick_between_nodes
1914 :     {
1915 :     my ( $tree, $node1, $node2, $fraction ) = @_;
1916 :     array_ref( $tree ) or return undef;
1917 :     $fraction >= 0 && $fraction <= 1 or return undef;
1918 :    
1919 :     # Find the paths to the nodes:
1920 :    
1921 :     my @path1 = path_to_node( $tree, $node1 ) or return undef;
1922 :     my @path2 = path_to_node( $tree, $node2 ) or return undef;
1923 :    
1924 :     # Trim the common prefix, saving it:
1925 :    
1926 :     my @prefix = ();
1927 :     while ( $path1[1] == $path2[1] )
1928 :     {
1929 :     push @prefix, splice( @path1, 0, 2 );
1930 :     splice( @path2, 0, 2 );
1931 :     }
1932 :    
1933 :     my ( @path, $dist );
1934 :     if ( @path1 < 3 )
1935 :     {
1936 :     @path2 >= 3 or return undef; # node1 = node2
1937 :     $dist = $fraction * newick_path_length( @path2 );
1938 :     @path = @path2;
1939 :     }
1940 :     elsif ( @path2 < 3 )
1941 :     {
1942 :     $dist = ( 1 - $fraction ) * newick_path_length( @path1 );
1943 :     @path = @path1;
1944 :     }
1945 :     else
1946 :     {
1947 :     my $dist1 = newick_path_length( @path1 );
1948 :     my $dist2 = newick_path_length( @path2 );
1949 :     $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
1950 :     @path = ( $dist <= 0 ) ? @path1 : @path2;
1951 :     $dist = abs( $dist );
1952 :     }
1953 :    
1954 :     # Descend tree until we reach the insertion branch:
1955 :    
1956 :     my $x;
1957 :     while ( ( $dist > ( $x = newick_x( $path[2] ) ) ) && ( @path > 3 ) )
1958 :     {
1959 :     $dist -= $x;
1960 :     push @prefix, splice( @path, 0, 2 );
1961 :     }
1962 :    
1963 :     # Insert the new node:
1964 :    
1965 :     my $newnode = [ [ $path[2] ], undef, $dist ];
1966 :     set_newick_desc_i( $path[0], $path[1], $newnode );
1967 :     set_newick_x( $path[2], ( ( $x > $dist ) ? ( $x - $dist ) : 0 ) );
1968 :    
1969 :     # We can now build the path from root to the new node
1970 :    
1971 :     reroot_newick_by_path( @prefix, @path[0,1], $newnode );
1972 :     }
1973 :    
1974 :    
1975 :     #-------------------------------------------------------------------------------
1976 : golsen 1.1 # Move root of tree to an approximate midpoint.
1977 :     #
1978 :     # $newtree = reroot_newick_to_approx_midpoint( $tree )
1979 :     #-------------------------------------------------------------------------------
1980 :     sub reroot_newick_to_approx_midpoint {
1981 :     my ( $tree ) = @_;
1982 : golsen 1.5
1983 : golsen 1.1 # Compile average tip to node distances assending
1984 :    
1985 :     my $dists1 = average_to_tips_1( $tree );
1986 :    
1987 :     # Compile average tip to node distances descending, returning midpoint node
1988 :    
1989 :     my $node = average_to_tips_2( $dists1, undef, undef );
1990 :    
1991 :     # Reroot
1992 :    
1993 :     $node ? reroot_newick_to_node_ref( $tree, $node ) : $tree
1994 :     }
1995 :    
1996 :    
1997 :     sub average_to_tips_1 {
1998 :     my ( $node ) = @_;
1999 :    
2000 :     my @desc_dists = map { average_to_tips_1( $_ ) } newick_desc_list( $node );
2001 :     my $x_below = 0;
2002 :     if ( @desc_dists )
2003 :     {
2004 :     foreach ( @desc_dists ) { $x_below += $_->[0] }
2005 :     $x_below /= @desc_dists;
2006 :     }
2007 :     my $x = newick_x( $node ) || 0;
2008 :     my $x_net = $x_below + $x;
2009 :    
2010 :     [ $x_net, $x, $x_below, [ @desc_dists ], $node ]
2011 :     }
2012 :    
2013 : golsen 1.9
2014 : golsen 1.1 sub average_to_tips_2 {
2015 :     my ( $dists1, $x_above, $anc_node ) = @_;
2016 :     my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;
2017 :    
2018 :     # Are we done? Root is in this node's branch, or "above"?
2019 :    
2020 :     # defined( $x_above ) and print STDERR "x_above = $x_above\n";
2021 :     # print STDERR "x = $x\n";
2022 :     # print STDERR "x_below = $x_below\n";
2023 :     # print STDERR "n_desc = ", scalar @$desc_list, "\n\n";
2024 :    
2025 :     if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2026 :     {
2027 :     # At this point the root can only be in this node's branch,
2028 :     # or "above" it in the current rooting of the tree (which
2029 :     # would mean that the midpoint is actually down a different
2030 :     # path from the root of the current tree).
2031 :     #
2032 :     # Is the root in the current branch?
2033 :    
2034 :     if ( ( $x_below + $x ) >= $x_above )
2035 :     {
2036 :     return ( $x_above >= $x_below ) ? $anc_node : $node;
2037 :     }
2038 :     else
2039 :     {
2040 :     return undef;
2041 :     }
2042 :     }
2043 :    
2044 : golsen 1.5 # The root must be somewhere below this node:
2045 : golsen 1.1
2046 : golsen 1.5 my $n_1 = @$desc_list - ( $anc_node ? 0 : 1 );
2047 : golsen 1.1 my $ttl_dist = ( @$desc_list * $x_below ) + ( defined( $x_above ) ? ( $x_above + $x ) : 0 );
2048 :    
2049 :     foreach ( @$desc_list )
2050 :     {
2051 :     # If input tree is tip_rooted, $n-1 can be 0, so:
2052 :    
2053 :     my $above2 = $n_1 ? ( ( $ttl_dist - $_->[0] ) / $n_1 ) : 0;
2054 :     my $root = average_to_tips_2( $_, $above2, $node );
2055 :     if ( $root ) { return $root }
2056 :     }
2057 :    
2058 :     # Was not anywhere below this node (oh-oh):
2059 :    
2060 :     return undef;
2061 :     }
2062 :    
2063 : golsen 1.9
2064 : golsen 1.1 #-------------------------------------------------------------------------------
2065 : golsen 1.5 # Move root of tree to an approximate midpoint. Weight by tips.
2066 :     #
2067 :     # $newtree = reroot_newick_to_approx_midpoint_w( $tree )
2068 :     #-------------------------------------------------------------------------------
2069 :     sub reroot_newick_to_approx_midpoint_w {
2070 :     my ( $tree ) = @_;
2071 :    
2072 :     # Compile average tip to node distances assending
2073 :    
2074 :     my $dists1 = average_to_tips_1_w( $tree );
2075 :    
2076 :     # Compile average tip to node distances descending, returning midpoint node
2077 :    
2078 :     my $node = average_to_tips_2_w( $dists1, undef, undef, undef );
2079 :    
2080 :     # Reroot
2081 :    
2082 :     $node ? reroot_newick_to_node_ref( $tree, $node ) : $tree
2083 :     }
2084 :    
2085 :    
2086 :     sub average_to_tips_1_w {
2087 :     my ( $node ) = @_;
2088 :    
2089 :     my @desc_dists = map { average_to_tips_1_w( $_ ) } newick_desc_list( $node );
2090 :     my $x_below = 0;
2091 :     my $n_below = 1;
2092 :     if ( @desc_dists )
2093 :     {
2094 :     $n_below = 0;
2095 :     my $n;
2096 :     foreach ( @desc_dists )
2097 :     {
2098 :     $n_below += $n = $_->[1];
2099 :     $x_below += $n * $_->[0];
2100 :     }
2101 :     $x_below /= $n_below;
2102 :     }
2103 :     my $x = newick_x( $node ) || 0;
2104 :     my $x_net = $x_below + $x;
2105 :    
2106 :     [ $x_net, $n_below, $x, $x_below, [ @desc_dists ], $node ]
2107 :     }
2108 :    
2109 :    
2110 :     sub average_to_tips_2_w {
2111 :     my ( $dists1, $x_above, $n_above, $anc_node ) = @_;
2112 :     my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;
2113 :    
2114 :     # Are we done? Root is in this node's branch, or "above"?
2115 :    
2116 :     # defined( $x_above ) and print STDERR "x_above = $x_above\n";
2117 :     # print STDERR "x = $x\n";
2118 :     # print STDERR "x_below = $x_below\n";
2119 :     # print STDERR "n_desc = ", scalar @$desc_list, "\n\n";
2120 :    
2121 :     if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2122 :     {
2123 :     # At this point the root can only be in this node's branch,
2124 :     # or "above" it in the current rooting of the tree (which
2125 :     # would mean that the midpoint is actually down a different
2126 :     # path from the root of the current tree).
2127 :     #
2128 :     # Is the root in the current branch?
2129 :    
2130 :     if ( ( $x_below + $x ) >= $x_above )
2131 :     {
2132 :     return ( $x_above >= $x_below ) ? $anc_node : $node;
2133 :     }
2134 :     else
2135 :     {
2136 :     return undef;
2137 :     }
2138 :     }
2139 :    
2140 :     # The root must be some where below this node:
2141 :    
2142 :     $n_above ||= 0;
2143 :     my $n = $n_above + $n_below;
2144 :     my $ttl_w_dist = ( $n_below * $x_below )
2145 :     + ( defined( $x_above ) ? $n_above * ( $x_above + $x ) : 0 );
2146 :    
2147 :     foreach ( @$desc_list )
2148 :     {
2149 :     my $n_2 = $_->[1]; # n in subtree
2150 :     my $n_above2 = $n - $n_2; # tip rooted has 1 above
2151 :    
2152 :     # If input tree is tip_rooted, $n_above2 can be 0, so:
2153 :    
2154 :     my $x_above2 = $n_above2 ? ( ( $ttl_w_dist - $n_2 * $_->[0] ) / $n_above2 )
2155 :     : 0;
2156 :     my $root = average_to_tips_2_w( $_, $x_above2, $n_above2 || 1, $node );
2157 :     if ( $root ) { return $root }
2158 :     }
2159 :    
2160 :     # Was not anywhere below this node (oh-oh):
2161 :    
2162 :     return undef;
2163 :     }
2164 :    
2165 : golsen 1.9
2166 : golsen 1.5 #-------------------------------------------------------------------------------
2167 : golsen 1.1 # Move root of tree from tip to adjacent node.
2168 :     #
2169 :     # $newtree = uproot_tip_rooted_newick( $tree )
2170 :     #-------------------------------------------------------------------------------
2171 :     sub uproot_tip_rooted_newick {
2172 :     my ( $node ) = @_;
2173 :     newick_is_tip_rooted( $node ) || return $node;
2174 :    
2175 :     # Path to the sole descendant:
2176 :    
2177 :     reroot_newick_by_path( $node, 1, newick_desc_i( $node, 1 ) );
2178 :     }
2179 :    
2180 :    
2181 :     #-------------------------------------------------------------------------------
2182 :     # Remove root bifurcation.
2183 :     #
2184 :     # Root node label, label comment and descendant list comment are discarded.
2185 :     #
2186 :     # $newtree = uproot_newick( $tree )
2187 :     #-------------------------------------------------------------------------------
2188 :     sub uproot_newick {
2189 :     my ( $node0 ) = @_;
2190 :     newick_is_rooted( $node0 ) || return $node0;
2191 :    
2192 :     my ( $node1, $node2 ) = newick_desc_list( $node0 );
2193 :    
2194 :     # Ensure that node1 has at least 1 descendant
2195 :    
2196 :     if ( newick_n_desc( $node1 ) ) {
2197 :     push @{ newick_desc_ref( $node1 ) }, $node2; # Add node2 to descend list
2198 :     }
2199 :    
2200 :     # Or node2 has at least 1 descendant
2201 :    
2202 :     elsif ( newick_n_desc( $node2 ) ) {
2203 :     unshift @{ newick_desc_ref( $node2 ) }, $node1; # Add node1 to descend list
2204 :     ( $node1, $node2 ) = ( $node2, $node1 ); # And reverse labels
2205 :     }
2206 :    
2207 :     # We could make this into a tip rooted tree, but for now:
2208 :    
2209 :     else { return $node0 }
2210 :    
2211 :     # Prefix node1 branch to that of node2:
2212 :    
2213 :     add_to_newick_branch( $node2, $node1 );
2214 :     set_newick_x( $node1, undef );
2215 :    
2216 :     # Tree prefix comment lists (as references):
2217 :    
2218 :     my $C10 = newick_c1( $node0 );
2219 :     my $C11 = newick_c1( $node1 );
2220 : golsen 1.9 if ( $C11 && @$C11 ) {
2221 : golsen 1.1 if ( $C10 && @$C10 ) { unshift @$C11, @$C10 } # Prefix to node1 comments
2222 :     }
2223 :     elsif ( $C10 && @$C10 ) {
2224 :     set_newick_c1( $node1, $C10 ) # Or move node0 comments to node1
2225 :     }
2226 :    
2227 :     $node1;
2228 :     }
2229 :    
2230 :    
2231 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2232 :     # Prefix branch of node2 to that of node1:
2233 :     #
2234 :     # $node1 = add_to_newick_branch( $node1, $node2 )
2235 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2236 :     sub add_to_newick_branch {
2237 :     my ( $node1, $node2 ) = @_;
2238 :     array_ref( $node1 ) || die "add_to_newick_branch: arg 1 not array ref\n";
2239 :     array_ref( $node2 ) || die "add_to_newick_branch: arg 2 not array ref\n";
2240 :    
2241 :     # Node structure template:
2242 :     # my ( $DL, $L, $X, $C1, $C2, $C3, $C4, $C5 ) = @$node;
2243 :    
2244 :     # Fix branch lengths for joining of two branches:
2245 :    
2246 :     set_newick_x( $node1, newick_x( $node1 ) + newick_x( $node2 ) );
2247 :    
2248 :     # Merge branch length comments:
2249 :    
2250 :     my $C41 = newick_c4( $node1 ); # Ref to node1 C4
2251 :     my $C42 = newick_c4( $node2 ); # Ref to node2 C4
2252 :     if ( $C41 && @$C41 ) {
2253 :     if ( $C42 && @$C42 ) { unshift @$C41, @$C42 } # Add node2 comment
2254 :     }
2255 :     elsif ( $C42 && @$C42 ) { set_newick_c4( $node1, $C42 ) } # Or move node1 comment
2256 :    
2257 :     my $C51 = newick_c5( $node1 ); # Ref to node1 C5
2258 :     my $C52 = newick_c5( $node2 ); # Ref to node2 C5
2259 :     if ( $C51 && @$C51 ) {
2260 :     if ( $C52 && @$C52 ) { unshift @$C51, @$C52 } # Add node2 comment
2261 :     }
2262 :     elsif ( $C52 && @$C52 ) { set_newick_c5( $node1, $C52 ) } # Or move node1 comment
2263 :    
2264 :     $node1;
2265 :     }
2266 :    
2267 :    
2268 :     #-------------------------------------------------------------------------------
2269 : golsen 1.5 # Collapse zero-length branches to make multifurcation. The original tree
2270 :     # is modified.
2271 :     #
2272 :     # $tree = collapse_zero_length_branches( $tree )
2273 :     # $tree = collapse_zero_length_branches( $tree, $not_root )
2274 :     #-------------------------------------------------------------------------------
2275 :     sub collapse_zero_length_branches {
2276 :     my ( $tree, $not_root ) = @_;
2277 :     array_ref( $tree ) || return undef;
2278 :    
2279 :     my @desc = newick_desc_list( $tree );
2280 :     @desc or return ( $tree ); # Cannot collapse terminal branch
2281 :    
2282 :     # Analyze descendants:
2283 :    
2284 :     $not_root ||= 0;
2285 :     my @new_desc = ();
2286 :     my $changed = 0;
2287 :     foreach ( @desc )
2288 :     {
2289 :     my ( undef, @to_add ) = collapse_zero_length_branches( $_, $not_root+1 );
2290 :     if ( @to_add )
2291 :     {
2292 :     push @new_desc, @to_add;
2293 :     $changed = 1;
2294 :     }
2295 :     else
2296 :     {
2297 :     push @new_desc, $_;
2298 :     }
2299 :     }
2300 :     set_newick_desc_ref( $tree, [ @new_desc ] ) if $changed;
2301 :    
2302 :     # Collapse if not root, not tip and zero (or negative) branch:
2303 :    
2304 :     my $collapse = $not_root && @new_desc && ( newick_x( $tree ) <= 0 ) ? 1 : 0;
2305 :     ( $tree, ( $collapse ? @new_desc : () ) );
2306 :     }
2307 :    
2308 : golsen 1.8 #-------------------------------------------------------------------------------
2309 :     # Add a subtree to a newick tree node:
2310 :     #
2311 :     # $node = newick_insert_at_node( $node, $subtree )
2312 :     #-------------------------------------------------------------------------------
2313 :     sub newick_insert_at_node
2314 :     {
2315 :     my ( $node, $subtree ) = @_;
2316 :     array_ref( $node ) && array_ref( $subtree ) or return undef;
2317 :    
2318 :     # We could check validity of trees, but ....
2319 :    
2320 :     my $dl = newick_desc_ref( $node );
2321 :     if ( array_ref( $dl ) )
2322 :     {
2323 :     push @$dl, $subtree;
2324 :     }
2325 :     else
2326 :     {
2327 :     set_newick_desc_ref( $node, [ $subtree ] );
2328 :     }
2329 :     return $node;
2330 :     }
2331 :    
2332 :    
2333 :     #-------------------------------------------------------------------------------
2334 :     # Insert a subtree into a newick tree along the path between 2 nodes:
2335 :     #
2336 :     # $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
2337 :     #-------------------------------------------------------------------------------
2338 :     sub newick_insert_between_nodes
2339 :     {
2340 :     my ( $tree, $subtree, $node1, $node2, $fraction ) = @_;
2341 :     array_ref( $tree ) && array_ref( $subtree ) or return undef;
2342 :     $fraction >= 0 && $fraction <= 1 or return undef;
2343 :    
2344 :     # Find the paths to the nodes:
2345 :    
2346 :     my @path1 = path_to_node( $tree, $node1 ) or return undef;
2347 :     my @path2 = path_to_node( $tree, $node2 ) or return undef;
2348 :    
2349 :     # Trim the common prefix:
2350 :    
2351 :     while ( $path1[1] == $path2[1] )
2352 :     {
2353 :     splice( @path1, 0, 2 );
2354 :     splice( @path2, 0, 2 );
2355 :     }
2356 :    
2357 :     my ( @path, $dist );
2358 :     if ( @path1 < 3 )
2359 :     {
2360 :     @path2 >= 3 or return undef; # node1 = node2
2361 : golsen 1.9 $dist = $fraction * newick_path_length( @path2 );
2362 : golsen 1.8 @path = @path2;
2363 :     }
2364 :     elsif ( @path2 < 3 )
2365 :     {
2366 :     $dist = ( 1 - $fraction ) * newick_path_length( @path1 );
2367 :     @path = @path1;
2368 :     }
2369 :     else
2370 :     {
2371 :     my $dist1 = newick_path_length( @path1 );
2372 :     my $dist2 = newick_path_length( @path2 );
2373 :     $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
2374 :     @path = ( $dist <= 0 ) ? @path1 : @path2;
2375 :     $dist = abs( $dist );
2376 :     }
2377 :    
2378 :     # Descend tree until we reach the insertion branch:
2379 :    
2380 :     my $x;
2381 :     while ( ( $dist > ( $x = newick_x( $path[2] ) ) ) && ( @path > 3 ) )
2382 :     {
2383 :     $dist -= $x;
2384 :     splice( @path, 0, 2 );
2385 :     }
2386 :    
2387 :     # Insert the new node:
2388 :    
2389 :     set_newick_desc_i( $path[0], $path[1], [ [ $path[2], $subtree ], undef, $dist ] );
2390 :     set_newick_x( $path[2], ( ( $x > $dist ) ? ( $x - $dist ) : 0 ) );
2391 :    
2392 :     return $tree;
2393 :     }
2394 :    
2395 : golsen 1.5
2396 :     #-------------------------------------------------------------------------------
2397 : golsen 1.1 # Prune one or more tips from a tree:
2398 :     # Caveat: if one tip is listed, the original tree is modified.
2399 : golsen 1.5 # if more than one tip is listed, a copy of the tree is returned
2400 : golsen 1.1 # (even if it is just listing the same tip twice!).
2401 :     #
2402 :     # $newtree = prune_from_newick( $tree, $tip )
2403 :     # $newtree = prune_from_newick( $tree, @tips )
2404 :     # $newtree = prune_from_newick( $tree, \@tips )
2405 :     #-------------------------------------------------------------------------------
2406 :     sub prune_from_newick {
2407 :     my ( $tr, @tips ) = @_;
2408 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
2409 : golsen 1.9
2410 : golsen 1.1 if ( @tips == 0 ) { return $tr }
2411 :     if ( @tips == 1 ) { return prune_1_from_newick( $tr, @tips ) }
2412 :    
2413 :     my %del = map { ( $_, 1 ) } @tips;
2414 :     my @keep = grep { ! $del{ $_ } } newick_tip_list( $tr );
2415 :     newick_subtree( $tr, @keep );
2416 :     }
2417 :    
2418 :    
2419 :     #-------------------------------------------------------------------------------
2420 :     # Prune a tip from a tree:
2421 :     #
2422 :     # $newtree = prune_1_from_newick( $tree, $tip )
2423 :     #-------------------------------------------------------------------------------
2424 :     sub prune_1_from_newick {
2425 :     my ( $tr, $tip ) = @_;
2426 :     my @path = path_to_tip( $tr, $tip );
2427 :     if ( @path < 3 ) { return $tr }
2428 :    
2429 :     my $node = $path[-1]; # Node with the tip
2430 :     my $i1 = $path[-2]; # Descendant number of node in ancestor desc list
2431 :     my $anc1 = $path[-3]; # Ancestor of node
2432 :     my $nd1 = newick_n_desc( $anc1 ); # Number of descendants of ancestor
2433 :     my $anc2 = ( @path >= 5 ) ? $path[-5] : undef; # Ancestor of anc1
2434 :    
2435 :     # dump_tree( $node );
2436 :     # print STDERR "i1 = $i1\n";
2437 :     # dump_tree( $anc1 );
2438 :     # print STDERR "nd1 = $nd1\n";
2439 :     # defined( $anc2 ) && dump_tree( $anc2 );
2440 :    
2441 :     if ( $nd1 > 3 || ( $anc2 && $nd1 > 2 ) ) { # Tip joins at multifurcation
2442 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant
2443 :     }
2444 :    
2445 :     elsif ( $anc2 ) { # Tip joins at internal bifurcation
2446 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
2447 :     add_to_newick_branch( $sis, $anc1 ); # combine internal branches
2448 :     set_newick_desc_i( $anc2, $path[-4], $sis ); # remove $anc1
2449 :     }
2450 :    
2451 :     elsif ( $nd1 == 2) { # Tip joins bifurcating root node
2452 :     my $sis = newick_desc_i( $anc1, 3-$i1 ); # find sister node
2453 :     $sis->[1] = $anc1->[1] if ! $sis->[1] && $anc1->[1]; # root label
2454 :     $sis->[2] = undef; # root branch len
2455 :     $sis->[3] = $anc1->[3] if ! $sis->[3] && $anc1->[3]; # tree comment
2456 :     $sis->[4] = $anc1->[4] if ! $sis->[4] && $anc1->[4]; # desc list comment
2457 : golsen 1.9 $sis->[5] = $anc1->[5] if ! $sis->[5] && $anc1->[5]; # label comment
2458 : golsen 1.1 $sis->[6] = undef if $sis->[6]; # root branch comment
2459 :     $sis->[7] = undef if $sis->[7]; # root branch comment
2460 :     $tr = $sis; # sister is new root
2461 :     }
2462 :    
2463 :     elsif ( $nd1 == 3 ) { # Tip joins trifurcating root:
2464 :     splice( @{ $anc1->[0] }, $i1-1, 1 ); # delete the descendant, and
2465 :     $tr = uproot_newick( $tr ); # fix the rooting
2466 :     }
2467 :    
2468 :     else {
2469 :     return undef;
2470 :     }
2471 :    
2472 :     return $tr;
2473 :     }
2474 :    
2475 :    
2476 :     #-------------------------------------------------------------------------------
2477 :     # Produce a subtree with the desired tips:
2478 :     #
2479 :     # Except for (some) tip nodes, the tree produced is a copy.
2480 :     # There is no check that requested tips exist.
2481 :     #
2482 :     # $newtree = newick_subtree( $tree, @tips )
2483 :     # $newtree = newick_subtree( $tree, \@tips )
2484 :     #-------------------------------------------------------------------------------
2485 :     sub newick_subtree {
2486 :     my ( $tr, @tips ) = @_;
2487 :     if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
2488 :    
2489 :     if ( @tips < 2 ) { return undef }
2490 :     my $was_rooted = newick_is_rooted( $tr );
2491 :     my $keephash = { map { ( $_, 1 ) } @tips };
2492 :     my $tr2 = subtree1( $tr, $keephash );
2493 :     $tr2 = uproot_newick( $tr2 ) if ! $was_rooted && newick_is_rooted( $tr2 );
2494 :     $tr2->[2] = undef if $tr2; # undef root branch length
2495 :     $tr2;
2496 :     }
2497 :    
2498 :    
2499 :     sub subtree1 {
2500 :     my ( $tr, $keep ) = @_;
2501 :     my @desc1 = newick_desc_list( $tr );
2502 :    
2503 :     # Is this a tip, and is it in the keep list?
2504 :    
2505 :     if ( @desc1 < 1 ) {
2506 :     return ( $keep->{ newick_lbl( $tr ) } ) ? $tr : undef;
2507 :     }
2508 :    
2509 :     # Internal node: analyze the descendants:
2510 :    
2511 :     my @desc2 = ();
2512 :     foreach ( @desc1 ) {
2513 :     my $desc = subtree1( $_, $keep );
2514 :     if ( $desc && @$desc ) { push @desc2, $desc }
2515 :     }
2516 :    
2517 :     if ( @desc2 == 0 ) { return undef }
2518 :     if ( @desc2 > 1 ) { return [ \@desc2, @$tr[ 1 .. @$tr - 1 ] ] }
2519 :    
2520 :     # Exactly 1 descendant
2521 :    
2522 :     my $desc = $desc2[ 0 ];
2523 :     my @nn = ( $desc->[0],
2524 :     $desc->[1] ? $desc->[1] : $tr->[1],
2525 :     defined( $tr->[2] ) ? $desc->[2] + $tr->[2] : undef
2526 :     );
2527 :    
2528 :     # Merge comments (only recreating the ones that existed):
2529 :    
2530 :     if ( $tr->[3] && @{$tr->[3]} || $desc->[3] && @{$desc->[3]} ) {
2531 :     $nn[3] = [ $tr->[3] ? @{$tr->[3]} : (), $desc->[3] ? @{$desc->[3]} : () ];
2532 :     }
2533 :     if ( $tr->[4] && @{$tr->[4]} || $desc->[4] && @{$desc->[4]} ) {
2534 :     $nn[4] = [ $tr->[4] ? @{$tr->[4]} : (), $desc->[4] ? @{$desc->[4]} : () ];
2535 :     }
2536 :     if ( $tr->[5] && @{$tr->[5]} || $desc->[5] && @{$desc->[5]} ) {
2537 :     $nn[5] = [ $tr->[5] ? @{$tr->[5]} : (), $desc->[5] ? @{$desc->[5]} : () ];
2538 :     }
2539 :     if ( $tr->[6] && @{$tr->[6]} || $desc->[6] && @{$desc->[6]} ) {
2540 :     $nn[6] = [ $tr->[6] ? @{$tr->[6]} : (), $desc->[6] ? @{$desc->[6]} : () ];
2541 :     }
2542 :     if ( $tr->[7] && @{$tr->[7]} || $desc->[7] && @{$desc->[7]} ) {
2543 :     $nn[7] = [ $tr->[7] ? @{$tr->[7]} : (), $desc->[7] ? @{$desc->[7]} : () ];
2544 :     }
2545 :    
2546 :     return \@nn;
2547 :     }
2548 :    
2549 :    
2550 :     #===============================================================================
2551 :     #
2552 : golsen 1.9 # Representative subtrees
2553 :     #
2554 :     #===============================================================================
2555 :     # Find subtree of size n representating vicinity of the root:
2556 :     #
2557 :     # $subtree = root_neighborhood_representative_tree( $tree, $n, \%tip_priority )
2558 :     # $subtree = root_neighborhood_representative_tree( $tree, $n )
2559 :     #
2560 :     # Note that if $tree is rooted, then the subtree will also be. This can have
2561 :     # consequences on downstream programs.
2562 :     #-------------------------------------------------------------------------------
2563 :     sub root_neighborhood_representative_tree
2564 :     {
2565 :     my ( $tree, $n, $tip_priority ) = @_;
2566 :     array_ref( $tree ) && ( $n >= 2 ) or return undef;
2567 :     if ( newick_tip_count( $tree ) <= $n ) { return $tree }
2568 :    
2569 :     $tip_priority ||= default_tip_priority( $tree );
2570 :     my @tips = map { representative_tip_of_newick_node( $_, $tip_priority ) }
2571 :     root_proximal_newick_subtrees( $tree, $n );
2572 :    
2573 :     newick_subtree( copy_newick_tree( $tree ), \@tips );
2574 :     }
2575 :    
2576 :    
2577 :     #-------------------------------------------------------------------------------
2578 :     # Find n tips to represent tree lineages in vicinity of another tip.
2579 :     # Default tip priority is short total branch length.
2580 :     #
2581 :     # \@tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
2582 :     # @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
2583 :     # \@tips = root_neighborhood_representative_tips( $tree, $n )
2584 :     # @tips = root_neighborhood_representative_tips( $tree, $n )
2585 :     #-------------------------------------------------------------------------------
2586 :     sub root_neighborhood_representative_tips
2587 :     {
2588 :     my ( $tree, $n, $tip_priority ) = @_;
2589 :     array_ref( $tree ) && ( $n >= 2 ) or return undef;
2590 :    
2591 :     my @tips;
2592 :     if ( newick_tip_count( $tree ) <= $n )
2593 :     {
2594 :     @tips = newick_tip_list( $tree );
2595 :     }
2596 :     else
2597 :     {
2598 :     $tip_priority ||= default_tip_priority( $tree );
2599 :     @tips = map { representative_tip_of_newick_node( $_, $tip_priority ) }
2600 :     root_proximal_newick_subtrees( $tree, $n );
2601 :     }
2602 :    
2603 :     wantarray ? @tips : \@tips;
2604 :     }
2605 :    
2606 :    
2607 :     #-------------------------------------------------------------------------------
2608 :     # Find subtree of size n representating vicinity of a tip:
2609 :     #
2610 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )
2611 :     # $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )
2612 :     #-------------------------------------------------------------------------------
2613 :     sub tip_neighborhood_representative_tree
2614 :     {
2615 :     my ( $tree, $tip, $n, $tip_priority ) = @_;
2616 :     array_ref( $tree ) && $tip && ( $n >= 2 ) or return undef;
2617 :     newick_tip_in_tree( $tree, $tip ) or return undef;
2618 :    
2619 :     my $tree1 = copy_newick_tree( $tree );
2620 :     if ( newick_tip_count( $tree1 ) - 1 <= $n )
2621 :     {
2622 :     return prune_from_newick( $tree1, $tip )
2623 :     }
2624 :    
2625 :     $tree1 = reroot_newick_to_tip( $tree1, $tip );
2626 :     $tree1 = newick_desc_i( $tree1, 1 ); # Node immediately below tip
2627 :     my @tips = root_neighborhood_representative_tips( $tree1, $n, $tip_priority );
2628 :     newick_subtree( copy_newick_tree( $tree ), \@tips );
2629 :     }
2630 :    
2631 :    
2632 :     #-------------------------------------------------------------------------------
2633 :     # Find n tips to represent tree lineages in vicinity of another tip.
2634 :     # Default tip priority is short total branch length.
2635 :     #
2636 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
2637 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
2638 :     # \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
2639 :     # @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
2640 :     #-------------------------------------------------------------------------------
2641 :     sub tip_neighborhood_representative_tips
2642 :     {
2643 :     my ( $tree, $tip, $n, $tip_priority ) = @_;
2644 :     array_ref( $tree ) && $tip && ( $n >= 2 ) or return undef;
2645 :     newick_tip_in_tree( $tree, $tip ) or return undef;
2646 :    
2647 :     my @tips = newick_tip_list( $tree );
2648 :     if ( newick_tip_count( $tree ) - 1 <= $n )
2649 :     {
2650 :     @tips = grep { $_ ne $tip } @tips;
2651 :     }
2652 :     else
2653 :     {
2654 :     my $tree1 = copy_newick_tree( $tree );
2655 :     $tree1 = reroot_newick_to_tip( $tree1, $tip );
2656 :     $tree1 = newick_desc_i( $tree1, 1 ); # Node immediately below tip
2657 :     @tips = root_neighborhood_representative_tips( $tree1, $n, $tip_priority );
2658 :     }
2659 :    
2660 :     wantarray ? @tips : \@tips;
2661 :     }
2662 :    
2663 :    
2664 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2665 :     # Anonymous hash of the negative distance from root to each tip:
2666 :     #
2667 :     # \%tip_priority = default_tip_priority( $tree )
2668 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2669 :     sub default_tip_priority
2670 :     {
2671 :     my ( $tree ) = @_;
2672 :     my $tip_distances = newick_tip_distances( $tree ) || {};
2673 :     return { map { $_ => -$tip_distances->{$_} } keys %$tip_distances };
2674 :     }
2675 :    
2676 :    
2677 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2678 :     # Select a tip from a subtree base on a priority value:
2679 :     #
2680 :     # $tip = representative_tip_of_newick_node( $node, \%tip_priority )
2681 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2682 :     sub representative_tip_of_newick_node
2683 :     {
2684 :     my ( $node, $tip_priority ) = @_;
2685 :     my ( $tip ) = sort { $b->[1] <=> $a->[1] } # The best
2686 :     map { [ $_, $tip_priority->{ $_ } ] }
2687 :     newick_tip_list( $node );
2688 :     $tip->[0]; # Label from label-priority pair
2689 :     }
2690 :    
2691 :    
2692 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2693 :     # Find n subtrees focused around the root of a tree. Typically each will
2694 :     # then be reduced to a single tip to make a representative tree:
2695 :     #
2696 :     # @subtrees = root_proximal_newick_subtrees( $tree, $n )
2697 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2698 :     sub root_proximal_newick_subtrees
2699 :     {
2700 :     my ( $tree, $n ) = @_;
2701 :     my $node_start_end = newick_branch_intervals( $tree );
2702 :     n_representative_branches( $n, $node_start_end );
2703 :     }
2704 :    
2705 :    
2706 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2707 :     # @node_start_end = newick_branch_intervals( $tree )
2708 :     # \@node_start_end = newick_branch_intervals( $tree )
2709 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2710 :     sub newick_branch_intervals
2711 :     {
2712 :     my ( $node, $parent_x ) = @_;
2713 :     $parent_x ||= 0;
2714 :     my ( $desc, undef, $dx ) = @$node;
2715 :     my $x = $parent_x + $dx;
2716 :     my $interval = [ $node, $parent_x, $desc && @$desc ? $x : 1e100 ];
2717 :     my @intervals = ( $interval,
2718 :     map { &newick_branch_intervals( $_, $x ) } @$desc
2719 :     );
2720 :     return wantarray ? @intervals : \@intervals;
2721 :     }
2722 :    
2723 :    
2724 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2725 :     # @ids = n_representative_branches( $n, @id_start_end )
2726 :     # @ids = n_representative_branches( $n, \@id_start_end )
2727 :     # \@ids = n_representative_branches( $n, @id_start_end )
2728 :     # \@ids = n_representative_branches( $n, \@id_start_end )
2729 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2730 :     sub n_representative_branches
2731 :     {
2732 :     my $n = shift;
2733 :     # Sort intervals by start point:
2734 :     my @unprocessed = sort { $a->[1] <=> $b->[1] }
2735 :     ( @_ == 1 ) ? @{ $_[0] } : @_;
2736 :     my @active = ();
2737 :     my ( $interval, $current_point );
2738 :     foreach $interval ( @unprocessed )
2739 :     {
2740 :     $current_point = $interval->[1];
2741 :     # Filter out intervals that have ended. This is N**2 in the number
2742 :     # of representatives. Fixing this would require maintaining a sorted
2743 :     # active list.
2744 :     @active = grep { $_->[2] > $current_point } @active;
2745 :     push @active, $interval;
2746 :     last if ( @active >= $n );
2747 :     }
2748 :    
2749 :     my @ids = map { $_->[0] } @active;
2750 :     return wantarray() ? @ids : \@ids;
2751 :     }
2752 :    
2753 :    
2754 :     #===============================================================================
2755 :     #
2756 : golsen 1.1 # Tree writing and reading
2757 :     #
2758 :     #===============================================================================
2759 : overbeek 1.7 # writeNewickTree( $tree )
2760 :     # writeNewickTree( $tree, $file )
2761 :     # writeNewickTree( $tree, \*FH )
2762 : golsen 1.1 #-------------------------------------------------------------------------------
2763 :     sub writeNewickTree {
2764 :     my ( $tree, $file ) = @_;
2765 : overbeek 1.7 my ( $fh, $close ) = open_output( $file );
2766 :     $fh or return;
2767 :     print $fh ( strNewickTree( $tree ), "\n" );
2768 :     close $fh if $close;
2769 : golsen 1.1 }
2770 :    
2771 :    
2772 :     #-------------------------------------------------------------------------------
2773 :     # fwriteNewickTree( $file, $tree ) # Args reversed to writeNewickTree
2774 :     #-------------------------------------------------------------------------------
2775 :     sub fwriteNewickTree { writeNewickTree( $_[1], $_[0] ) }
2776 :    
2777 :    
2778 :     #-------------------------------------------------------------------------------
2779 :     # $treestring = strNewickTree( $tree )
2780 :     #-------------------------------------------------------------------------------
2781 :     sub strNewickTree {
2782 :     my $node = shift @_;
2783 :     strNewickSubtree( $node, "" ) . ";";
2784 :     }
2785 :    
2786 :    
2787 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2788 :     # $string = strNewickSubtree( $node, $prefix )
2789 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2790 :     sub strNewickSubtree {
2791 :     my ( $node, $prefix ) = @_;
2792 :     my $s;
2793 :    
2794 :     $s = strNewickComments( newick_c1( $node ), $prefix );
2795 :     if ( $s ) { $prefix = " " }
2796 :    
2797 :     my $ndesc;
2798 :     if ( $ndesc = newick_n_desc( $node ) ) {
2799 :     for (my $d = 1; $d <= $ndesc; $d++) {
2800 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : "," )
2801 :     . strNewickSubtree( newick_desc_i( $node, $d ), " " );
2802 :     }
2803 :    
2804 :     $s .= ")" . strNewickComments( newick_c2( $node ), " " );
2805 :     $prefix = " ";
2806 :     }
2807 :    
2808 :     if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {
2809 :     $s .= $prefix
2810 :     . q_newick_lbl( $node )
2811 :     . strNewickComments( newick_c3( $node ), " " );
2812 :     }
2813 :    
2814 :     if ( defined( newick_x( $node ) ) ) {
2815 :     $s .= ":"
2816 :     . strNewickComments( newick_c4( $node ), " " )
2817 :     . sprintf( " %.6f", newick_x( $node ) )
2818 :     . strNewickComments( newick_c5( $node ), " " );
2819 :     }
2820 :    
2821 :     $s;
2822 :     }
2823 :    
2824 :    
2825 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2826 :     # $string = strNewickComments( $clist, $prefix )
2827 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2828 :     sub strNewickComments {
2829 :     my ( $clist, $prefix ) = @_;
2830 :     array_ref( $clist ) && ( @$clist > 0 ) || return "";
2831 :     $prefix . "[" . join( "] [", @$clist ) . "]";
2832 :     }
2833 :    
2834 :    
2835 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2836 :     # $quoted_label = q_newick_lbl( $label )
2837 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2838 :     sub q_newick_lbl {
2839 :     my $lbl = newick_lbl( $_[0] );
2840 :     defined( $lbl ) && ( $lbl ne "" ) || return undef;
2841 :    
2842 :     if ( $lbl =~ m/^[^][()_:;,]+$/ # Anything but []()_:;,
2843 :     && $lbl !~ m/^'/ ) { # and does not start with '
2844 :     $lbl =~ s/ /_/g; # Recode blanks as _
2845 :     return $lbl;
2846 :     }
2847 :    
2848 :     else {
2849 :     $lbl =~ s/'/''/g; # Double existing single quote marks
2850 :     return q(') . $lbl . q('); # Wrap in single quote marks
2851 :     }
2852 :     }
2853 :    
2854 :    
2855 :     #===============================================================================
2856 :     # $treestring = formatNewickTree( $tree )
2857 :     #===============================================================================
2858 :     sub formatNewickTree {
2859 :     formatNewickSubtree( $_[0], "", "" ) . ";";
2860 :     }
2861 :    
2862 :    
2863 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2864 :     # $string = formatNewickSubtree( $node, $prefix, $indent )
2865 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2866 :     sub formatNewickSubtree {
2867 :     my ( $node, $prefix, $indent ) = @_;
2868 :     my $s;
2869 :    
2870 :     $s = formatNewickComments( newick_c1( $node ), $prefix, $indent );
2871 :     if ( $s ) { $prefix = "\n$indent" }
2872 :    
2873 :     if ( my $ndesc = newick_n_desc( $node ) ) {
2874 :     for (my $d = 1; $d <= $ndesc; $d++) {
2875 :     $s .= ( ( $d == 1 ) ? $prefix . "(" : ",\n$indent " )
2876 :     . formatNewickSubtree( newick_desc_i( $node, $d ), " ", $indent . " " );
2877 :     }
2878 :    
2879 :     $s .= "\n$indent)" . formatNewickComments( newick_c2( $node ), " ", $indent );
2880 :     $prefix = " ";
2881 :     }
2882 :    
2883 :     if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {
2884 :     $s .= $prefix
2885 :     . q_newick_lbl( $node )
2886 :     . formatNewickComments( newick_c3( $node ), " ", $indent );
2887 :     }
2888 :    
2889 :     if ( defined( newick_x( $node ) ) ) {
2890 :     $s .= ":"
2891 :     . formatNewickComments( newick_c4( $node ), " ", $indent )
2892 :     . sprintf(" %.6f", newick_x( $node ) )
2893 :     . formatNewickComments( newick_c5( $node ), " ", $indent );
2894 :     }
2895 :    
2896 :     $s;
2897 :     }
2898 :    
2899 :    
2900 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2901 :     # $string = formatNewickComments( $clist, $prefix, $indent )
2902 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2903 :     sub formatNewickComments {
2904 :     my ( $clist, $prefix, $indent ) = @_;
2905 :     array_ref( $clist ) && @$clist || return "";
2906 :     $prefix . "[" . join( "] [", @$clist ) . "]";
2907 :     }
2908 :    
2909 :    
2910 :     #===============================================================================
2911 : overbeek 1.7 # $tree = read_newick_tree( $file ) # reads to a semicolon
2912 :     # @trees = read_newick_trees( $file ) # reads to end of file
2913 :     #===============================================================================
2914 :    
2915 :     sub read_newick_tree
2916 :     {
2917 :     my $file = shift;
2918 :     my ( $fh, $close ) = open_input( $file );
2919 :     my $tree;
2920 :     my @lines = ();
2921 : golsen 1.9 foreach ( <$fh> )
2922 : overbeek 1.7 {
2923 :     chomp;
2924 :     push @lines, $_;
2925 :     if ( /;/ )
2926 :     {
2927 :     $tree = parse_newick_tree_str( join( ' ', @lines ) );
2928 :     last;
2929 :     }
2930 :     }
2931 :     close $fh if $close;
2932 :    
2933 :     $tree;
2934 :     }
2935 :    
2936 :    
2937 :     sub read_newick_trees
2938 :     {
2939 :     my $file = shift;
2940 :     my ( $fh, $close ) = open_input( $file );
2941 :     my @trees = ();
2942 :     my @lines = ();
2943 : golsen 1.9 foreach ( <$fh> )
2944 : overbeek 1.7 {
2945 :     chomp;
2946 :     push @lines, $_;
2947 :     if ( /;/ )
2948 :     {
2949 :     push @trees, parse_newick_tree_str( join( ' ', @lines ) );
2950 :     @lines = ()
2951 :     }
2952 :     }
2953 :     close $fh if $close;
2954 :    
2955 :     @trees;
2956 :     }
2957 :    
2958 :    
2959 :     #===============================================================================
2960 : golsen 1.1 # Tree reader adapted from the C language reader in fastDNAml
2961 :     #
2962 :     # $tree = parse_newick_tree_str( $string )
2963 :     #===============================================================================
2964 :     sub parse_newick_tree_str {
2965 :     my $s = shift @_;
2966 :    
2967 :     my ( $ind, $rootnode ) = parse_newick_subtree( $s, 0 );
2968 :     if ( substr( $s, $ind, 1 ) ne ";") { warn "warning: tree missing ';'\n" }
2969 :     $rootnode;
2970 :     }
2971 :    
2972 :    
2973 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2974 :     # Read a subtrees recursively (everything of tree but a semicolon)
2975 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2976 :     sub parse_newick_subtree {
2977 :     my ( $s, $ind ) = @_;
2978 :    
2979 :     my $newnode = [];
2980 :     my @dlist = ();
2981 :     my ( $lbl, $x, $c1, $c2, $c3, $c4, $c5 );
2982 : golsen 1.9
2983 : golsen 1.1 ( $ind, $c1 ) = getNextTreeChar( $s, $ind ); # Comment 1
2984 :     if ( ! defined( $ind ) ) { treeParseError( "missing subtree" ) }
2985 :     if ( $c1 && @$c1 ) { set_newick_c1( $newnode, $c1 ) }
2986 :    
2987 :     if ( substr( $s, $ind, 1 ) eq "(" ) { # New internal node
2988 :     while ( ! @dlist || ( substr( $s, $ind, 1 ) eq "," ) ) {
2989 :     my $desc;
2990 :     ( $ind, $desc ) = parse_newick_subtree( $s, $ind+1 );
2991 :     if (! $ind) { return () }
2992 :     push @dlist, $desc;
2993 :     }
2994 :     if ( substr( $s, $ind, 1 ) ne ")" ) { treeParseError( "missing ')'" ) }
2995 :    
2996 :     ( $ind, $c2 ) = getNextTreeChar( $s, $ind+1 ); # Comment 2
2997 :     if ( $c2 && @$c2 ) { set_newick_c2( $newnode, $c2 ) }
2998 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Node label
2999 :     }
3000 :    
3001 :     elsif ( substr( $s, $ind, 1 ) =~ /[^][(,):;]/ ) { # New tip
3002 :     ( $ind, $lbl ) = parseTreeNodeLabel( $s, $ind ); # Tip label
3003 :     if (! $ind) { return () }
3004 :     }
3005 :    
3006 :     @dlist || $lbl || treeParseError( "no descendant list or label" );
3007 :    
3008 :     if ( @dlist ) { set_newick_desc_ref( $newnode, \@dlist ) }
3009 :     if ( $lbl ) { set_newick_lbl( $newnode, $lbl ) }
3010 :    
3011 :     ( $ind, $c3 ) = getNextTreeChar( $s, $ind ); # Comment 3
3012 :     if ( $c3 && @$c3 ) { set_newick_c3( $newnode, $c3 ) }
3013 :    
3014 :     if (substr( $s, $ind, 1 ) eq ":") { # Branch length
3015 :     ( $ind, $c4 ) = getNextTreeChar( $s, $ind+1 ); # Comment 4
3016 :     if ( $c4 && @$c4 ) { set_newick_c4( $newnode, $c4 ) }
3017 :     ( $ind, $x ) = parseBranchLength( $s, $ind );
3018 :     if ( defined( $x ) ) { set_newick_x( $newnode, $x ) }
3019 :     ( $ind, $c5 ) = getNextTreeChar( $s, $ind ); # Comment 5
3020 :     if ( $c5 && @$c5 ) { set_newick_c5( $newnode, $c5 ) }
3021 :     }
3022 :    
3023 :     ( $ind, $newnode );
3024 :     }
3025 :    
3026 :    
3027 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3028 :     # Read a Newick tree label
3029 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3030 :     sub parseTreeNodeLabel { # Empty string is permitted
3031 :     my ( $s, $ind ) = @_;
3032 :     my ( $lbl, $c );
3033 :    
3034 :     if ( substr( $s, $ind, 1 ) eq "'") {
3035 :     my $ind1 = ++$ind;
3036 :    
3037 :     while ( ) {
3038 :     if ( ! defined( $c = substr( $s, $ind, 1 ) ) || $c eq "" ) {
3039 :     treeParseError( "missing close quote on label '" . substr( $s, $ind1 ) . "'" )
3040 :     }
3041 :     elsif ( $c ne "'" ) { $ind++ }
3042 :     elsif ( substr( $s, $ind, 2 ) eq "''" ) { $ind += 2 }
3043 :     else { last }
3044 :     }
3045 :    
3046 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
3047 :     $lbl =~ s/''/'/g;
3048 :     $ind++;
3049 :     }
3050 :    
3051 :     else {
3052 :     my $ind1 = $ind;
3053 :     while ( defined( $c = substr($s, $ind, 1) ) && $c ne "" && $c !~ /[][\s(,):;]/ ) { $ind++ }
3054 :     $lbl = substr( $s, $ind1, $ind-$ind1 );
3055 :     $lbl =~ s/_/ /g;
3056 :     }
3057 :    
3058 :     ( $ind, $lbl );
3059 :     }
3060 :    
3061 :    
3062 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3063 :     # Read a Newick tree branch length
3064 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3065 :     sub parseBranchLength {
3066 :     my ( $s, $ind ) = @_;
3067 :    
3068 :     my $c = substr( $s, $ind, 1 );
3069 :    
3070 :     my $sign = ( $c ne "-" ) ? 1 : -1; # Sign
3071 :     if ( $c =~ /[-+]/ ) { $c = substr( $s, ++$ind, 1 ) }
3072 :    
3073 :     if ( $c !~ /^[.0-9]$/ ) { # Allows starting with decimal
3074 :     treeParseError( "invalid branch length character '$c'" )
3075 :     }
3076 :    
3077 :     my $v = 0;
3078 :     while ( $c =~ /[0-9]/ ) { # Whole number
3079 :     $v = 10 * $v + $c;
3080 :     $c = substr( $s, ++$ind, 1 );
3081 :     }
3082 :    
3083 :     if ( $c eq "." ) { # Fraction
3084 :     my $f = 0.1;
3085 :     $c = substr( $s, ++$ind, 1 );
3086 :     while ( $c =~ /[0-9]/ ) {
3087 :     $v += $f * $c;
3088 :     $f *= 0.1;
3089 :     $c = substr( $s, ++$ind, 1 );
3090 :     }
3091 :     }
3092 :    
3093 :     $v *= $sign;
3094 :    
3095 :     if ( $c =~ /[dDeEgG]/ ) { # Exponent
3096 :     $c = substr( $s, ++$ind, 1 );
3097 :     my $esign = ( $c ne "-" ) ? 1 : -1;
3098 :     if ( $c =~ /^[-+]$/ ) { $c = substr( $s, ++$ind, 1 ) }
3099 :     if ( $c !~ /^[0-9]$/ ) {
3100 :     treeParseError( "missing branch length exponent '$c'" )
3101 :     }
3102 :    
3103 :     my $e = 0;
3104 :     while ( $c =~ /[0-9]/ ) {
3105 :     $e = 10 * $e + $c;
3106 :     $c = substr( $s, ++$ind, 1 );
3107 :     }
3108 :     $e *= $esign;
3109 :     $v *= 10**$e;
3110 :     }
3111 :    
3112 :     ( $ind, $v );
3113 :     }
3114 :    
3115 :    
3116 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3117 :     # ( $index, /@commentlist ) = getNextTreeChar( $string, $index )
3118 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3119 :     sub getNextTreeChar { # Move to next nonblank, noncomment character
3120 :     my ( $s, $ind ) = @_;
3121 :    
3122 :     my @clist = ();
3123 :    
3124 :     # Skip white space
3125 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
3126 :    
3127 :     # Loop while it is a comment:
3128 :     while ( substr( $s, $ind, 1 ) eq "[" ) {
3129 :     $ind++;
3130 :    
3131 :     # Find end
3132 :     if ( substr( $s, $ind ) !~ /^([^]]*)\]/ ) {
3133 :     treeParseError( "comment missing closing bracket '["
3134 :     . substr( $s, $ind ) . "'" )
3135 :     }
3136 :     my $comment = $1;
3137 :    
3138 :     # Save if it includes any "text"
3139 :     if ( $comment =~ m/\S/ ) { push @clist, $comment }
3140 :    
3141 :     $ind += length( $comment ) + 1; # Comment plus closing bracket
3142 :    
3143 :     # Skip white space
3144 :     if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
3145 :     }
3146 :    
3147 :     ( $ind, @clist ? \@clist : undef )
3148 :     }
3149 :    
3150 :    
3151 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3152 :     # treeParseError( $message )
3153 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3154 :     sub treeParseError { die "Error: parse_newick_subtree: " . $_[0] . "\n" }
3155 :    
3156 :    
3157 :     #===============================================================================
3158 :     # Make a printer plot of a tree:
3159 :     #
3160 :     # $node newick tree root node
3161 : overbeek 1.4 # $file undef (= \*STDOUT), \*STDOUT, \*STDERR, or a file name.
3162 : golsen 1.1 # $width the approximate characters for the tree without labels
3163 :     # $min_dx the minimum horizontal branch length
3164 :     # $dy the vertical space per taxon
3165 :     #
3166 : overbeek 1.4 # printer_plot_newick( $node, $file (D=\*STDOUT), $width (D=68), $min_dx (D=2), $dy (D=1) )
3167 : golsen 1.1 #===============================================================================
3168 :     sub printer_plot_newick {
3169 :     my ( $node, $file, $width, $min_dx, $dy ) = @_;
3170 :    
3171 : overbeek 1.7 my ( $fh, $close ) = open_output( $file );
3172 :     $fh or return;
3173 : golsen 1.1
3174 :     print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";
3175 :     if ( $close ) { close $fh }
3176 :     }
3177 :    
3178 :    
3179 :     #===============================================================================
3180 :     # Make a text plot of a tree:
3181 :     #
3182 :     # $node newick tree root node
3183 :     # $width the approximate characters for the tree without labels
3184 :     # $min_dx the minimum horizontal branch length
3185 :     # $dy the vertical space per taxon
3186 :     #
3187 :     # @textlines = text_plot_newick( $node, $width (D=68), $min_dx (D=2), $dy (D=1) )
3188 :     #===============================================================================
3189 :     sub text_plot_newick {
3190 :     my ( $node, $width, $min_dx, $dy ) = @_;
3191 :     array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
3192 :     defined( $min_dx ) and ( $min_dx >= 0 ) or $min_dx = 2;
3193 :     defined( $dy ) and ( $dy >= 1 ) or $dy = 1;
3194 :     defined( $width ) or $width = 68;
3195 :    
3196 :     $min_dx = int( $min_dx );
3197 :     $dy = int( $dy );
3198 : golsen 1.5 my $x_scale = $width / ( newick_max_X( $node ) || 1 ); # Div by zero caught by RAE
3199 : golsen 1.1
3200 :     my $hash = {};
3201 :     layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );
3202 :    
3203 :     # dump_tree_hash( $node, $hash ); exit;
3204 :    
3205 :     # Generate the lines of the tree one by one:
3206 :    
3207 :     my ( $y1, $y2 ) = @{ $hash->{ $node } };
3208 :     map { text_tree_row( $node, $hash, $_, "", "+" ) } ( $y1 .. $y2 );
3209 :     }
3210 :    
3211 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3212 :     # ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy )
3213 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3214 :     sub layout_printer_plot {
3215 :     my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;
3216 :     array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
3217 :     hash_ref( $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
3218 :    
3219 :     my $dx = newick_x( $node );
3220 :     if ( defined( $dx ) ) {
3221 :     $dx *= $x_scale;
3222 :     $dx >= $min_dx or $dx = $min_dx;
3223 :     }
3224 :     else {
3225 :     $dx = ( $x0 > 0 ) ? $min_dx : 0;
3226 :     }
3227 :     $dx = int( $dx + 0.4999 );
3228 :    
3229 :     my ( $x, $xmax, $y, $ymax, $y1, $y2, $yn1, $yn2 );
3230 :    
3231 :     $x = $x0 + $dx;
3232 :     $y1 = int( $y0 + 0.5 * $dy + 0.4999 );
3233 :     my @dl = newick_desc_list( $node );
3234 :    
3235 :     if ( ! @dl ) { # A tip
3236 :     $xmax = $x;
3237 :     $y = $yn1 = $yn2 = $y2 = $y1;
3238 :     $ymax = $y + 0.5 * $dy;
3239 :     }
3240 :    
3241 :     else { # A subtree
3242 :     $xmax = -1;
3243 :     my $xmaxi;
3244 :     my $yi;
3245 :     my @ylist = ();
3246 :     $ymax = $y0;
3247 :    
3248 :     foreach ( @dl ) {
3249 :     ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy );
3250 :     push @ylist, $yi;
3251 :     if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
3252 :     }
3253 :    
3254 :     # Use of y-list is overkill for saving first and last values,
3255 :     # but eases implimentation of alternative y-value calculations.
3256 :    
3257 :     $yn1 = $ylist[ 0];
3258 :     $yn2 = $ylist[-1];
3259 :     $y = int( 0.5 * ( $yn1 + $yn2 ) + 0.4999 );
3260 :     }
3261 :    
3262 :     $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
3263 :    
3264 :     $hash->{ $node } = [ $y1, $y2, $x0, $x, $y, $yn1, $yn2 ];
3265 :     ( $xmax, $ymax, $y );
3266 :     }
3267 :    
3268 :    
3269 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3270 :     # Debug routine
3271 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3272 :     sub dump_tree {
3273 :     my ( $node, $prefix ) = @_;
3274 :     defined( $prefix ) or $prefix = "";
3275 :     print STDERR $prefix, join(", ", @$node), "\n";
3276 :     my @dl = $node->[0] ? @{$node->[0]} : ();
3277 :     foreach ( @dl ) { dump_tree( $_, $prefix . " " ) }
3278 :     $prefix or print STDERR "\n";
3279 :     }
3280 :    
3281 :    
3282 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3283 :     # Debug routine
3284 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3285 :     sub dump_tree_hash {
3286 :     my ( $node, $hash, $prefix ) = @_;
3287 :     defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
3288 :     print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
3289 :     my @dl = $node->[0] ? @{$node->[0]} : ();
3290 :     foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . " " ) }
3291 :     }
3292 :    
3293 :    
3294 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3295 :     # $line = text_tree_row( $node, $hash, $row, $line, $symb )
3296 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3297 :     sub text_tree_row {
3298 :     my ( $node, $hash, $row, $line, $symb ) = @_;
3299 :    
3300 :     my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3301 :     if ( $row < $y1 || $row > $y2 ) { return $line }
3302 :    
3303 :     if ( length( $line ) < $x0 ) { $line .= " " x ( $x0 - length( $line ) ) }
3304 :    
3305 :     if ( $row == $y ) {
3306 :     $line = substr( $line, 0, $x0 ) . $symb . (( $x > $x0 ) ? "-" x ($x - $x0) : "");
3307 :     }
3308 :    
3309 :     elsif ( $row > $yn1 && $row < $yn2 ) {
3310 :     if ( length( $line ) < $x ) { $line .= " " x ( $x - length( $line ) ) . "|" }
3311 :     else { substr( $line, $x ) = "|" }
3312 :     }
3313 :    
3314 :     my @dl = newick_desc_list( $node );
3315 :    
3316 :     if ( @dl < 1 ) {
3317 :     $line .= " " . $node->[1];
3318 :     }
3319 :    
3320 :     else {
3321 :     my @list = map { [ $_, "+" ] } @dl; # Print symbol for line
3322 :     $list[ 0]->[1] = "/";
3323 :     $list[-1]->[1] = "\\";
3324 :    
3325 :     foreach ( @list ) {
3326 :     my ( $n, $s ) = @$_;
3327 :     if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
3328 :     $line = text_tree_row( $n, $hash, $row, $line, $s );
3329 :     }
3330 :     }
3331 :    
3332 :     if ( $row == $y ) { substr( $line, $x, 1 ) = "+" }
3333 :     }
3334 :    
3335 :     return $line;
3336 :     }
3337 :    
3338 :    
3339 : overbeek 1.7 #===============================================================================
3340 :     # Open an input file stream:
3341 :     #
3342 :     # ( $handle, undef ) = open_input( ); # \*STDIN
3343 :     # ( $handle, undef ) = open_input( \*FH );
3344 :     # ( $handle, 1 ) = open_input( $file ); # need to close $handle
3345 :     #
3346 :     #===============================================================================
3347 :     sub open_input
3348 :     {
3349 :     my $file = shift;
3350 :     my $fh;
3351 :     if ( ! defined( $file ) ) { return ( \*STDIN ) }
3352 :     elsif ( ref( $file ) eq 'GLOB' ) { return ( $file ) }
3353 :     elsif ( open( $fh, "<$file" ) ) { return ( $fh, 1 ) } # Need to close
3354 :    
3355 :     print STDERR "gjonewick::open_input could not open '$file' for reading\n";
3356 :     return undef;
3357 :     }
3358 :    
3359 :    
3360 :     #===============================================================================
3361 :     # Open an output file stream:
3362 :     #
3363 :     # ( $handle, undef ) = open_output( ); # \*STDOUT
3364 :     # ( $handle, undef ) = open_output( \*FH );
3365 :     # ( $handle, 1 ) = open_output( $file ); # need to close $handle
3366 :     #
3367 :     #===============================================================================
3368 :     sub open_output
3369 :     {
3370 :     my $file = shift;
3371 :     my $fh;
3372 :     if ( ! defined( $file ) ) { return ( \*STDOUT ) }
3373 :     elsif ( ref( $file ) eq 'GLOB' ) { return ( $file ) }
3374 :     elsif ( ( open $fh, ">$file" ) ) { return ( $fh, 1 ) } # Need to close
3375 :    
3376 :     print STDERR "gjonewick::open_output could not open '$file' for writing\n";
3377 :     return undef;
3378 :     }
3379 :    
3380 : golsen 1.9
3381 :     #===============================================================================
3382 :     # Some subroutines copied from gjolists
3383 :     #===============================================================================
3384 :     # Return the common prefix of two lists:
3385 :     #
3386 :     # @common = common_prefix( \@list1, \@list2 )
3387 :     #-----------------------------------------------------------------------------
3388 :     sub common_prefix
3389 :     {
3390 :     my ($l1, $l2) = @_;
3391 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
3392 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
3393 :    
3394 :     my $i = 0;
3395 :     my $l1_i;
3396 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
3397 :    
3398 :     return @$l1[ 0 .. ($i-1) ]; # perl handles negative range
3399 :     }
3400 :    
3401 :    
3402 :     #-----------------------------------------------------------------------------
3403 :     # Return the unique suffixes of each of two lists:
3404 :     #
3405 :     # ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )
3406 :     #-----------------------------------------------------------------------------
3407 :     sub unique_suffixes
3408 :     {
3409 :     my ($l1, $l2) = @_;
3410 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
3411 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
3412 :    
3413 :     my $i = 0;
3414 :     my @l1 = @$l1;
3415 :     my @l2 = @$l2;
3416 :     my $l1_i;
3417 :     while ( defined( $l1_i = $l1[$i] ) && $l1_i eq $l2[$i] ) { $i++ }
3418 :    
3419 :     splice @l1, 0, $i;
3420 :     splice @l2, 0, $i;
3421 :     return ( \@l1, \@l2 );
3422 :     }
3423 :    
3424 :    
3425 :     #-------------------------------------------------------------------------------
3426 :     # List of values duplicated in a list (stable in order by second occurance):
3427 :     #
3428 :     # @dups = duplicates( @list )
3429 :     #-------------------------------------------------------------------------------
3430 :     sub duplicates
3431 :     {
3432 :     my %cnt = ();
3433 :     grep { ++$cnt{$_} == 2 } @_;
3434 :     }
3435 :    
3436 :    
3437 :     #-------------------------------------------------------------------------------
3438 :     # Randomize the order of a list:
3439 :     #
3440 :     # @random = random_order( @list )
3441 :     #-------------------------------------------------------------------------------
3442 :     sub random_order
3443 :     {
3444 :     my ( $i, $j );
3445 :     for ( $i = @_ - 1; $i > 0; $i-- )
3446 :     {
3447 :     $j = int( ($i+1) * rand() );
3448 :     ( $_[$i], $_[$j] ) = ( $_[$j], $_[$i] ); # Interchange i and j
3449 :     }
3450 :    
3451 :     @_;
3452 :     }
3453 :    
3454 :    
3455 :     #-----------------------------------------------------------------------------
3456 :     # Intersection of two or more sets:
3457 :     #
3458 :     # @intersection = intersection( \@set1, \@set2, ... )
3459 :     #-----------------------------------------------------------------------------
3460 :     sub intersection
3461 :     {
3462 :     my $set = shift;
3463 :     my @intersection = @$set;
3464 :    
3465 :     foreach $set ( @_ )
3466 :     {
3467 :     my %set = map { $_ => 1 } @$set;
3468 :     @intersection = grep { exists $set{ $_ } } @intersection;
3469 :     }
3470 :    
3471 :     @intersection;
3472 :     }
3473 :    
3474 :    
3475 :     #-----------------------------------------------------------------------------
3476 :     # Elements in set 1, but not set 2:
3477 :     #
3478 :     # @difference = set_difference( \@set1, \@set2 )
3479 :     #-----------------------------------------------------------------------------
3480 :     sub set_difference
3481 :     {
3482 :     my ($set1, $set2) = @_;
3483 :     my %set2 = map { $_ => 1 } @$set2;
3484 :     grep { ! ( exists $set2{$_} ) } @$set1;
3485 :     }
3486 :    
3487 :    
3488 : golsen 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3