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

Diff of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.23, Sat Sep 18 20:10:10 2010 UTC revision 1.24, Sat Oct 2 00:01:10 2010 UTC
# Line 22  Line 22 
22  #===============================================================================  #===============================================================================
23  #  perl functions for dealing with trees  #  perl functions for dealing with trees
24  #  #
25  #  Usage:  #  Usage:  use gjonewicklib
 #      use gjonewicklib  
 #  
26  #  #
27  #===============================================================================  #===============================================================================
28  #  Tree data structures:  #  Tree data structures:
# Line 101  Line 99 
99  #  @desclist = newick_desc_list( $noderef )  #  @desclist = newick_desc_list( $noderef )
100  #  $n        = newick_n_desc( $noderef )  #  $n        = newick_n_desc( $noderef )
101  #  $descref  = newick_desc_i( $noderef, $i )    # 1-based numbering  #  $descref  = newick_desc_i( $noderef, $i )    # 1-based numbering
102  #  $bool     = newick_is_tip( $noderef )  #
103    #  $bool     = node_is_tip( $noderef )
104    #  $bool     = node_is_valid( $noderef )
105    #  $bool     = node_has_lbl( $noderef )
106    #  $bool     = node_lbl_is( $noderef, $label )
107  #  #
108  #  set_newick_desc_ref( $noderef, $listref )  #  set_newick_desc_ref( $noderef, $listref )
109  #  set_newick_lbl( $noderef, $label )  #  set_newick_lbl( $noderef, $label )
# Line 171  Line 173 
173  #      () is returned upon failure  #      () is returned upon failure
174  #  #
175  #  @path = path_to_tip( $treenode, $tipname )  #  @path = path_to_tip( $treenode, $tipname )
176    # \%paths = paths_to_tips( $treenode, \@%tips )
177  #  @path = path_to_named_node( $treenode, $nodename )  #  @path = path_to_named_node( $treenode, $nodename )
178    # \%paths = paths_to_named_nodes( $treenode, \@names )
179  #  @path = path_to_node_ref( $treenode, $noderef )  #  @path = path_to_node_ref( $treenode, $noderef )
180  #  #
181  #  @path = path_to_node( $node,   $tip1, $tip2, $tip3   )  #  3 tip names  #  @path  = path_to_node( $node,   $name1, $name2, $name3   )  #  3 node names
182  #  @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] )  #  Array of tips  #  @path  = path_to_node( $node, [ $name1, $name2, $name3 ] )  #  Array of names
183  #  @path = path_to_node( $node,   $tip1                 )  #  Use path_to_tip  #  @path  = path_to_node( $node,   $name1, $name2   )          #  2 node names
184  #  @path = path_to_node( $node, [ $tip1 ]               )  #  Use path_to_tip  #  @path  = path_to_node( $node, [ $name1, $name2 ] )          #  Array of names
185    #  @path  = path_to_node( $node,   $name1   )                  #  1 node name
186    #  @path  = path_to_node( $node, [ $name1 ] )                  #  Array with name
187  #  #
188  #  $distance = newick_path_length( @path )  #  $distance = newick_path_length( @path )
189  #  $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )  #  $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
# Line 209  Line 215 
215  #  $n_changed = newick_set_all_branches( $node, $x )  #  $n_changed = newick_set_all_branches( $node, $x )
216  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
217  #  $node      = newick_rescale_branches( $node, $factor )  #  $node      = newick_rescale_branches( $node, $factor )
218    #  $node      = newick_random_branch_lengths( $node, $x1, $x2 )
219  #  $node      = newick_modify_branches( $node, \&function )  #  $node      = newick_modify_branches( $node, \&function )
220  #  $node      = newick_modify_branches( $node, \&function, \@func_parms )  #  $node      = newick_modify_branches( $node, \&function, \@func_parms )
221  #  #
# Line 223  Line 230 
230  #  $stdtree = std_unrooted_newick( $tree )  #  $stdtree = std_unrooted_newick( $tree )
231  #  $newtree = aesthetic_newick_tree( $tree, $direction )  #  $newtree = aesthetic_newick_tree( $tree, $direction )
232  #  $rndtree = random_order_newick_tree( $tree )  #  $rndtree = random_order_newick_tree( $tree )
233    #  $newtree - reroot_tree( $tree, \%options )
234  #  $newtree = reroot_newick_by_path( @path )  #  $newtree = reroot_newick_by_path( @path )
235  #  $newtree = reroot_newick_to_tip( $tree, $tip )  #  $newtree = reroot_newick_to_tip( $tree, $tip )
236  #  $newtree = reroot_newick_next_to_tip( $tree, $tip )  #  $newtree = reroot_newick_next_to_tip( $tree, $tip )
237  #  $newtree = reroot_newick_to_node( $tree, @node )  #  $newtree = reroot_newick_to_node( $tree, @node )
238  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )
239  #  $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )  #  $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
240    #  $newtree = reroot_newick_at_dist_between_nodes( $tree, $node1, $node2, $distance )
241  #  $newtree = reroot_newick_to_midpoint( $tree )           # unweighted  #  $newtree = reroot_newick_to_midpoint( $tree )           # unweighted
242  #  $newtree = reroot_newick_to_midpoint_w( $tree )         # weight by tips  #  $newtree = reroot_newick_to_midpoint_w( $tree )         # weight by tips
243  #  $newtree = reroot_newick_to_approx_midpoint( $tree )    # unweighted  #  $newtree = reroot_newick_to_approx_midpoint( $tree )    # unweighted
# Line 304  Line 313 
313  #  #
314  #  Read trees:  #  Read trees:
315  #  #
316  #  $tree  = read_newick_tree( )  #  $tree  = read_newick_tree( $file )  # reads to a semicolon
317  #  $tree  = read_newick_tree( \*FH )  #  @trees = read_newick_trees( $file ) # reads to end of file
 #  $tree  = read_newick_tree( $file )  
 #  
 #  @trees = read_newick_trees( )  
 #  @trees = read_newick_trees( \*FH )  
 #  @trees = read_newick_trees( $file )  
 #  
318  #  $tree  = parse_newick_tree_str( $string )  #  $tree  = parse_newick_tree_str( $string )
319  #  #
320  #===============================================================================  #===============================================================================
# Line 373  Line 376 
376          newick_set_all_branches          newick_set_all_branches
377          newick_fix_negative_branches          newick_fix_negative_branches
378          newick_rescale_branches          newick_rescale_branches
379            newick_random_branch_lengths
380          newick_modify_branches          newick_modify_branches
381    
382          newick_strip_comments          newick_strip_comments
# Line 384  Line 388 
388          unaesthetic_newick_tree          unaesthetic_newick_tree
389          random_order_newick_tree          random_order_newick_tree
390    
391            reroot_tree
392          reroot_newick_by_path          reroot_newick_by_path
393          reroot_newick_to_tip          reroot_newick_to_tip
394          reroot_newick_next_to_tip          reroot_newick_next_to_tip
395          reroot_newick_to_node          reroot_newick_to_node
396          reroot_newick_to_node_ref          reroot_newick_to_node_ref
397          reroot_newick_between_nodes          reroot_newick_between_nodes
398            reroot_newick_at_dist_between_nodes
399          reroot_newick_to_midpoint          reroot_newick_to_midpoint
400          reroot_newick_to_midpoint_w          reroot_newick_to_midpoint_w
401          reroot_newick_to_approx_midpoint          reroot_newick_to_approx_midpoint
# Line 439  Line 445 
445          newick_desc_list          newick_desc_list
446          newick_n_desc          newick_n_desc
447          newick_desc_i          newick_desc_i
448          newick_is_tip  
449          newick_is_valid          node_is_tip
450            node_is_valid
451            node_has_lbl
452            node_lbl_is
453    
454          set_newick_desc_ref          set_newick_desc_ref
455          set_newick_lbl          set_newick_lbl
# Line 466  Line 475 
475  sub array_ref { $_[0] && ref( $_[0] ) eq 'ARRAY' }  sub array_ref { $_[0] && ref( $_[0] ) eq 'ARRAY' }
476  sub hash_ref  { $_[0] && ref( $_[0] ) eq 'HASH'  }  sub hash_ref  { $_[0] && ref( $_[0] ) eq 'HASH'  }
477    
478    sub max       { $_[0] >= $_[1] ? $_[0] : $_[1] }
479    sub min       { $_[0] <= $_[1] ? $_[0] : $_[1] }
480    
481    
482  #===============================================================================  #===============================================================================
483  #  Interconvert overbeek and gjonewick trees:  #  Interconvert overbeek and gjonewick trees:
# Line 510  Line 522 
522  #     @list    = newick_desc_list( $noderef )  #     @list    = newick_desc_list( $noderef )
523  #     $int     = newick_n_desc( $noderef )  #     $int     = newick_n_desc( $noderef )
524  #     $listref = newick_desc_i( $noderef )  #     $listref = newick_desc_i( $noderef )
525    #
526  #     $bool    = node_is_tip( $noderef )  #     $bool    = node_is_tip( $noderef )
527  #     $bool    = node_is_valid( $noderef )  #     $bool    = node_is_valid( $noderef )
528    #     $bool    = node_has_lbl( $noderef )
529    #     $bool    = node_lbl_is( $noderef, $label )
530  #  #
531  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
532    
533  sub newick_desc_ref { ref($_[0]) ? $_[0]->[0] : Carp::confess() }  # = ${$_[0]}[0]  sub newick_desc_ref { ref($_[0]) ? $_[0]->[0] : Carp::confess() }
534  sub newick_lbl      { ref($_[0]) ? $_[0]->[1] : Carp::confess() }  sub newick_lbl      { ref($_[0]) ? $_[0]->[1] : Carp::confess() }
535  sub newick_x        { ref($_[0]) ? $_[0]->[2] : Carp::confess() }  sub newick_x        { ref($_[0]) ? $_[0]->[2] : Carp::confess() }
536  sub newick_c1       { ref($_[0]) ? $_[0]->[3] : Carp::confess() }  sub newick_c1       { ref($_[0]) ? $_[0]->[3] : Carp::confess() }
# Line 524  Line 539 
539  sub newick_c4       { ref($_[0]) ? $_[0]->[6] : Carp::confess() }  sub newick_c4       { ref($_[0]) ? $_[0]->[6] : Carp::confess() }
540  sub newick_c5       { ref($_[0]) ? $_[0]->[7] : Carp::confess() }  sub newick_c5       { ref($_[0]) ? $_[0]->[7] : Carp::confess() }
541    
542  sub newick_desc_list {  sub newick_desc_list
543      my $node = $_[0];  {
544      array_ref( $node ) && array_ref( $node->[0] ) ? @{ $node->[0] } : ();      local $_ = $_[0];
545        array_ref( $_ ) && array_ref( $_->[0] ) ? @{ $_->[0] } : ();
546  }  }
547    
548  sub newick_n_desc {  sub newick_n_desc
549      my $node = $_[0];  {
550      array_ref( $node ) && array_ref( $node->[0] ) ? scalar @{ $node->[0] } : 0;      local $_ = $_[0];
551        array_ref( $_ ) && array_ref( $_->[0] ) ? scalar @{ $_->[0] } : 0;
552  }  }
553    
554  sub newick_desc_i {  sub newick_desc_i
555      my ( $node, $i ) = @_;  {
556      array_ref( $node ) && $i && array_ref( $node->[0] ) ? $node->[0]->[$i-1] : undef;      local $_ = $_[0];
557        my    $i = $_[1];
558        array_ref( $_ ) && $i && array_ref( $_->[0] ) ? $_->[0]->[$i-1] : undef;
559  }  }
560    
561  sub node_is_tip {  sub node_is_tip
562      my $node = $_[0];  {
563      ! array_ref( $node      ) ? undef                :  # Not a node ref      local $_ = $_[0];
564        array_ref( $node->[0] ) ? @{ $node->[0] } == 0 :  # Empty descend list?      ! array_ref( $_ )      ? undef             :  # Not a node ref
565          array_ref( $_->[0] ) ? @{ $_->[0] } == 0 :  # Empty descend list?
566                                  1                    ;  # No descend list                                  1                    ;  # No descend list
567  }  }
568    
569  sub node_is_valid {      #  An array ref with nonempty descend list or a label  sub node_is_valid      #  An array ref with nonempty descend list or a label
570      my $node = $_[0];  {
571      array_ref( $node ) && (  array_ref( $node->[0] ) && @{ $node->[0] }      local $_ = $_[0];
572                            || defined( $node->[1] )      array_ref( $_ ) && ( array_ref( $_->[0] ) && @{ $_->[0] } || defined( $_->[1] ) )
                           )  
573  }  }
574    
575    sub node_has_lbl { local $_ = $_[0]->[1]; defined( $_ ) && ( $_ ne '' ) }
576    
577    sub node_lbl_is { local $_ = $_[0]->[1]; defined( $_ ) && ( $_ eq $_[1] ) }
578    
579    
580  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
581  #  Set tree structure values  #  Set tree structure values
# Line 567  Line 590 
590  sub set_newick_c4       { $_[0]->[6] = $_[1] }  sub set_newick_c4       { $_[0]->[6] = $_[1] }
591  sub set_newick_c5       { $_[0]->[7] = $_[1] }  sub set_newick_c5       { $_[0]->[7] = $_[1] }
592    
593  sub set_newick_desc_list {  sub set_newick_desc_list
594      my $node = shift;  {
595      array_ref( $node ) || return;      local $_ = shift;
596      if ( array_ref( $node->[0] ) ) { @{ $node->[0] } =   @_   }      array_ref( $_ ) || return;
597      else                           {    $node->[0]   = [ @_ ] }      if ( array_ref( $_->[0] ) ) { @{ $_->[0] } =   @_   }
598        else                        {    $_->[0]   = [ @_ ] }
599  }  }
600    
601  sub set_newick_desc_i {  sub set_newick_desc_i
602    {
603      my ( $node1, $i, $node2 ) = @_;      my ( $node1, $i, $node2 ) = @_;
604      array_ref( $node1 ) && array_ref( $node2 ) || return;      array_ref( $node1 ) && array_ref( $node2 ) || return;
605      if ( array_ref( $node1->[0] ) ) { $node1->[0]->[$i-1] =   $node2   }      if ( array_ref( $node1->[0] ) ) { $node1->[0]->[$i-1] =   $node2   }
# Line 641  Line 666 
666  #  #
667  #  $bool = newick_is_rooted( $node )  #  $bool = newick_is_rooted( $node )
668  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
669  sub newick_is_rooted {  sub newick_is_rooted
670      my $node = $_[0];  {
671      ! array_ref( $node      ) ? undef                :  # Not a node ref      local $_ = $_[0];
672        array_ref( $node->[0] ) ? @{ $node->[0] } == 2 :  # 2 branches      ! array_ref( $_      ) ? undef             :  # Not a node ref
673          array_ref( $_->[0] ) ? @{ $_->[0] } == 2 :  # 2 branches
674                                  0                    ;  # No descend list                                  0                    ;  # No descend list
675  }  }
676    
# Line 654  Line 680 
680  #  #
681  #  $bool = newick_is_unrooted( $node )  #  $bool = newick_is_unrooted( $node )
682  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
683  sub newick_is_unrooted {  sub newick_is_unrooted
684      my $node = $_[0];  {
685      ! array_ref( $node      ) ? undef                :  # Not a node ref      local $_ = $_[0];
686        array_ref( $node->[0] ) ? @{ $node->[0] } >= 3 :  # Over 2 branches      ! array_ref( $_      ) ? undef             :  # Not a node ref
687          array_ref( $_->[0] ) ? @{ $_->[0] } >= 3 :  # Over 2 branches
688                                  0                    ;  # No descend list                                  0                    ;  # No descend list
689  }  }
690    
# Line 667  Line 694 
694  #  #
695  #  $bool = newick_is_tip_rooted( $node )  #  $bool = newick_is_tip_rooted( $node )
696  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
697  sub newick_is_tip_rooted {  sub newick_is_tip_rooted
698      my $node = $_[0];  {
699      ! array_ref( $node      ) ? undef                :  # Not a node ref      local $_ = $_[0];
700        array_ref( $node->[0] ) ? @{ $node->[0] } == 1 :  # 1 branch      ! array_ref( $_      ) ? undef             :  # Not a node ref
701          array_ref( $_->[0] ) ? @{ $_->[0] } == 1 :  # 1 branch
702                                  0                    ;  # No descend list                                  0                    ;  # No descend list
703  }  }
704    
# Line 682  Line 710 
710  #  #
711  #  $n_desc = newick_is_bifurcating( $node )  #  $n_desc = newick_is_bifurcating( $node )
712  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
713  sub newick_is_bifurcating {  sub newick_is_bifurcating
714    {
715      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
716      if ( ! array_ref( $node ) ) { return undef }    #  Bad arg      if ( ! array_ref( $node ) ) { return undef }    #  Bad arg
717    
# Line 703  Line 732 
732  #  #
733  #  $n = newick_tip_count( $node )  #  $n = newick_tip_count( $node )
734  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
735  sub newick_tip_count {  sub newick_tip_count
736    {
737      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
738    
739      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
# Line 725  Line 755 
755  #  @tips = newick_tip_ref_list( $noderef )  #  @tips = newick_tip_ref_list( $noderef )
756  # \@tips = newick_tip_ref_list( $noderef )  # \@tips = newick_tip_ref_list( $noderef )
757  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
758  sub newick_tip_ref_list {  sub newick_tip_ref_list
759    {
760      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
761    
762      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
# Line 734  Line 765 
765      my @list = ();      my @list = ();
766    
767      #  Tree rooted on tip?      #  Tree rooted on tip?
768      if ( $imax == 1 && ! $not_root && newick_lbl( $node ) ) { push @list, $node }      if ( ! $not_root && ( $imax == 1 ) && node_has_lbl( $node ) ) { push @list, $node }
769    
770      foreach ( newick_desc_list( $node ) ) {      foreach ( newick_desc_list( $node ) ) {
771          push @list, newick_tip_ref_list( $_, 1 );          push @list, newick_tip_ref_list( $_, 1 );
# Line 750  Line 781 
781  #  @tips = newick_tip_list( $node )  #  @tips = newick_tip_list( $node )
782  # \@tips = newick_tip_list( $node )  # \@tips = newick_tip_list( $node )
783  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
784  sub newick_tip_list {  sub newick_tip_list
785    {
786      my @tips = map { newick_lbl( $_ ) } newick_tip_ref_list( $_[0] );      my @tips = map { newick_lbl( $_ ) } newick_tip_ref_list( $_[0] );
787      wantarray ? @tips : \@tips;      wantarray ? @tips : \@tips;
788  }  }
# Line 761  Line 793 
793  #  #
794  #  $tipref = newick_first_tip_ref( $node )  #  $tipref = newick_first_tip_ref( $node )
795  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
796  sub newick_first_tip_ref {  sub newick_first_tip_ref
797    {
798      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
799      valid_node( $node ) || return  undef;      valid_node( $node ) || return  undef;
800    
# Line 778  Line 811 
811  #  #
812  #  $tip = newick_first_tip( $node )  #  $tip = newick_first_tip( $node )
813  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
814  sub newick_first_tip {  sub newick_first_tip
815    {
816      my ( $noderef ) = @_;      my ( $noderef ) = @_;
817    
818      my $tipref;      my $tipref;
# Line 793  Line 827 
827  #  @tips = newick_duplicated_tips( $node )  #  @tips = newick_duplicated_tips( $node )
828  # \@tips = newick_duplicated_tips( $node )  # \@tips = newick_duplicated_tips( $node )
829  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
830  sub newick_duplicated_tips {  sub newick_duplicated_tips
831    {
832      my @tips = &duplicates( newick_tip_list( $_[0] ) );      my @tips = &duplicates( newick_tip_list( $_[0] ) );
833      wantarray ? @tips : \@tips;      wantarray ? @tips : \@tips;
834  }  }
# Line 804  Line 839 
839  #  #
840  #  $bool = newick_tip_in_tree( $node, $tipname )  #  $bool = newick_tip_in_tree( $node, $tipname )
841  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
842  sub newick_tip_in_tree {  sub newick_tip_in_tree
843    {
844      my ( $node, $tip, $not_root ) = @_;      my ( $node, $tip, $not_root ) = @_;
845    
846      my $n = newick_n_desc( $node );      my $n = newick_n_desc( $node );
847      if ( $n < 1 ) { return ( newick_lbl( $node ) eq $tip) ? 1 : 0 }      if ( $n < 1 ) { return node_lbl_is( $node, $tip ) ? 1 : 0 }
848    
849      #  Special case for tree rooted on tip      #  Special case for tree rooted on tip
850    
851      if ( $n == 1 && ( ! $not_root ) && newick_lbl( $node ) eq $tip ) { return 1 }      if ( ( $n == 1 ) && ( ! $not_root ) && node_lbl_is( $node, $tip ) )
852        {
853            return 1
854        }
855    
856      foreach ( newick_desc_list( $node ) ) {      foreach ( newick_desc_list( $node ) ) {
857          if ( newick_tip_in_tree( $_, $tip, 1 ) ) { return 1 }          if ( newick_tip_in_tree( $_, $tip, 1 ) ) { return 1 }
# Line 828  Line 867 
867  #  @tips = newick_shared_tips( $tree1, $tree2 )  #  @tips = newick_shared_tips( $tree1, $tree2 )
868  # \@tips = newick_shared_tips( $tree1, $tree2 )  # \@tips = newick_shared_tips( $tree1, $tree2 )
869  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
870  sub newick_shared_tips {  sub newick_shared_tips
871    {
872      my ( $tree1, $tree2 ) = @_;      my ( $tree1, $tree2 ) = @_;
873      my $tips1 = newick_tip_list( $tree1 );      my $tips1 = newick_tip_list( $tree1 );
874      my $tips2 = newick_tip_list( $tree2 );      my $tips2 = newick_tip_list( $tree2 );
# Line 842  Line 882 
882  #  #
883  #  $length = newick_tree_length( $node )  #  $length = newick_tree_length( $node )
884  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
885  sub newick_tree_length {  sub newick_tree_length
886    {
887      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
888    
889      my $x = $not_root ? newick_x( $node ) : 0;      my $x = $not_root ? newick_x( $node ) : 0;
# Line 880  Line 921 
921    
922      #  Tree rooted on tip?      #  Tree rooted on tip?
923    
924      if ( ( $n_desc == 1 ) && $root && ( newick_lbl( $node ) ) )      if ( $root && ( $n_desc == 1 ) && node_has_lbl( $node ) )
925      {      {
926          $hash->{ newick_lbl( $node ) } = 0;  # Distance to root is zero          $hash->{ newick_lbl( $node ) } = 0;  # Distance to root is zero
927      }      }
928    
929      foreach ( newick_desc_list( $node ) )      foreach ( newick_desc_list( $node ) ) { newick_tip_distances( $_, $x, $hash ) }
     {  
         newick_tip_distances( $_, $x, $hash );  
     }  
930    
931      wantarray ? %$hash : $hash;      wantarray ? %$hash : $hash;
932  }  }
# Line 899  Line 937 
937  #  #
938  #  $xmax = newick_max_X( $node )  #  $xmax = newick_max_X( $node )
939  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
940  sub newick_max_X {  sub newick_max_X
941    {
942      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
943    
944      my $xmax = 0;      my $xmax = 0;
# Line 918  Line 957 
957  #  #
958  #  ( $xmax, @path ) = newick_most_distant_tip_path( $tree )  #  ( $xmax, @path ) = newick_most_distant_tip_path( $tree )
959  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
960  sub newick_most_distant_tip_path {  sub newick_most_distant_tip_path
961    {
962      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
963    
964      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
# Line 940  Line 980 
980  #  #
981  #  ( $tipref, $xmax ) = newick_most_distant_tip_ref( $tree )  #  ( $tipref, $xmax ) = newick_most_distant_tip_ref( $tree )
982  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
983  sub newick_most_distant_tip_ref {  sub newick_most_distant_tip_ref
984    {
985      my ( $node, $not_root ) = @_;      my ( $node, $not_root ) = @_;
986    
987      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
# Line 962  Line 1003 
1003  #  #
1004  #  ( $tipname, $xmax ) = newick_most_distant_tip_name( $tree )  #  ( $tipname, $xmax ) = newick_most_distant_tip_name( $tree )
1005  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1006  sub newick_most_distant_tip_name {  sub newick_most_distant_tip_name
1007    {
1008      my ( $tipref, $xmax ) = newick_most_distant_tip_ref( $_[0] );      my ( $tipref, $xmax ) = newick_most_distant_tip_ref( $_[0] );
1009      ( newick_lbl( $tipref ), $xmax )      ( newick_lbl( $tipref ), $xmax )
1010  }  }
# Line 1070  Line 1112 
1112    
1113      #  Is it a tip?  Return list of one tip;      #  Is it a tip?  Return list of one tip;
1114    
1115      if ( ( ! $dl ) || @$dl == 0 )      if ( ( ! $dl ) || ! @$dl ) { return ( [ newick_lbl( $node ) ], $x ) }
     {  
         return ( [ newick_lbl( $node ) ], $x );  
     }  
1116    
1117      #  Get tips of each descendent, keeping lowest sorting from each.      #  Get tips of each descendent, keeping lowest sorting from each.
1118      #  Return the two lowest of those (the third will come from the      #  Return the two lowest of those (the third will come from the
# Line 1094  Line 1133 
1133  #  #
1134  #  @TipOrTips = std_node_name( $tree, $node )  #  @TipOrTips = std_node_name( $tree, $node )
1135  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1136  sub std_node_name {  sub std_node_name
1137    {
1138      my $tree = $_[0];      my $tree = $_[0];
1139    
1140      #  Node reference is last element of path to node      #  Node reference is last element of path to node
# Line 1102  Line 1142 
1142      my $noderef = ( path_to_node( @_ ) )[-1];      my $noderef = ( path_to_node( @_ ) )[-1];
1143      defined( $noderef ) || return ();      defined( $noderef ) || return ();
1144    
1145      if ( node_is_tip( $noderef ) || $noderef eq $tree ) {  # Is it a tip?      if ( node_is_tip( $noderef ) || ( $noderef eq $tree ) ) {  # Is it a tip?
1146          return newick_lbl( $noderef );          return newick_lbl( $noderef );
1147      }      }
1148    
# Line 1139  Line 1179 
1179  #  #
1180  #  @path = path_to_tip( $treenode, $tipname )  #  @path = path_to_tip( $treenode, $tipname )
1181  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1182  sub path_to_tip {  sub path_to_tip
1183      my ( $node, $tip, @path0 ) = @_;  {
1184        my ( $node, $tip ) = @_;
1185    
     push @path0, $node;  
1186      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
     if ( $imax < 1 ) { return ( newick_lbl( $node ) eq $tip ) ? @path0 : () }  
1187    
1188      #  Special case for tree rooted on tip      #  Tip (including root tip):
1189    
1190      if ( ( $imax  == 1 )                  #  One descendant      return ( $node ) if ( $imax < 2 ) && node_lbl_is( $node, $tip );
       && ( @path0 == 1 )                  #  First step in path  
       && ( newick_lbl( $node ) eq $tip )  #  Label matches  
        ) { return @path0 }  
1191    
     my @path;  
1192      for (my $i = 1; $i <= $imax; $i++ ) {      for (my $i = 1; $i <= $imax; $i++ ) {
1193         @path = path_to_tip( newick_desc_i( $node, $i ), $tip, ( @path0, $i ) );         my @suf = path_to_tip( newick_desc_i( $node, $i ), $tip );
1194         if ( @path ) { return @path }         return ( $node, $i, @suf ) if @suf;
1195      }      }
1196    
1197      ();  #  Not found      ();  #  Not found
# Line 1164  Line 1199 
1199    
1200    
1201  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1202  #  Path to named node.  #  Paths to tips:
1203  #  Like path to tip, but will find named internal nodes as well.  #
1204    #  \%paths = paths_to_tips( $treenode, \@tips )
1205    #  \%paths = paths_to_tips( $treenode, \%tips )
1206    #
1207    #-------------------------------------------------------------------------------
1208    sub paths_to_tips
1209    {
1210        my ( $node, $tips ) = @_;
1211        return {} if ! ( $tips && ref( $tips ) );
1212    
1213        #  Replace request for list with request by hash
1214    
1215        if ( ref( $tips ) eq 'ARRAY' ) { $tips = { map { $_ => 1 } @$tips } }
1216    
1217        my $paths = {};
1218        my $imax = newick_n_desc( $node );
1219        if ( $imax < 2 )
1220        {
1221            my $lbl;
1222            if ( node_has_lbl( $node ) && defined( $lbl = newick_lbl( $node ) ) && $tips->{ $lbl } )
1223            {
1224                delete $tips->{ $lbl };
1225                $paths->{ $lbl } = [ $node ];
1226            }
1227            return $paths if ! $imax;  # tip (no more to do it tested below)
1228        }
1229    
1230        for ( my $i = 1; $i <= $imax && keys %$tips; $i++ )
1231        {
1232           my $new = paths_to_tips( newick_desc_i( $node, $i ), $tips );
1233           foreach ( keys %$new )
1234           {
1235               splice @{ $new->{ $_ } }, 0, 0, ( $node, $i );
1236               $paths->{ $_ } = $new->{ $_ };
1237           }
1238        }
1239    
1240        return $paths;
1241    }
1242    
1243    
1244    #-------------------------------------------------------------------------------
1245    #  Path to named node.  Like path to tip, but also finds named internal nodes.
1246  #  #
1247  #  @path = path_to_named_node( $treenode, $name )  #  @path = path_to_named_node( $treenode, $name )
1248    #
1249  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1250  sub path_to_named_node {  sub path_to_named_node
1251      my ( $node, $name, @path0 ) = @_;  {
1252        my ( $node, $name ) = @_;
1253    
1254      push @path0, $node;      return ( $node ) if node_lbl_is( $node, $name );
     if ( newick_lbl( $node ) eq $name ) { return @path0 }  
1255    
     my @path;  
1256      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
1257      for ( my $i = 1; $i <= $imax; $i++ ) {      for ( my $i = 1; $i <= $imax; $i++ ) {
1258         @path = path_to_named_node( newick_desc_i( $node, $i ), $name, ( @path0, $i ) );         my @suf = path_to_named_node( newick_desc_i( $node, $i ), $name );
1259         if ( @path ) { return @path }         return ( $node, $i, @suf ) if @suf;
1260      }      }
1261    
1262      ();  #  Not found      ();  #  Not found
# Line 1187  Line 1264 
1264    
1265    
1266  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1267    #  Paths to named nodes in tree (need not be tips):
1268    #
1269    #  \%paths = paths_to_named_nodes( $treenode, \@names )
1270    #  \%paths = paths_to_named_nodes( $treenode, \%names )
1271    #
1272    #-------------------------------------------------------------------------------
1273    sub paths_to_named_nodes
1274    {
1275        my ( $node, $names ) = @_;
1276        return {} if ! ( $names && ref( $names ) );
1277    
1278        #  Replace request for list with request by hash
1279    
1280        if ( ref( $names ) eq 'ARRAY' ) { $names = { map { $_ => 1 } @$names } }
1281    
1282        my $paths = {};
1283        my $imax = newick_n_desc( $node );
1284    
1285        my $lbl;
1286        if ( node_has_lbl( $node ) && defined( $lbl = newick_lbl( $node ) ) && $names->{ $lbl } )
1287        {
1288            delete $names->{ $lbl };
1289            $paths->{ $lbl } = [ $node ];
1290        }
1291        return $paths if ! $imax;  # tip (no more to do it tested below)
1292    
1293        for ( my $i = 1; $i <= $imax && keys %$names; $i++ )
1294        {
1295           my $new = paths_to_named_nodes( newick_desc_i( $node, $i ), $names );
1296           foreach ( keys %$new )
1297           {
1298               splice @{ $new->{ $_ } }, 0, 0, ( $node, $i );
1299               $paths->{ $_ } = $new->{ $_ };
1300           }
1301        }
1302    
1303        return $paths;
1304    }
1305    
1306    
1307    #-------------------------------------------------------------------------------
1308  #  Path to node reference.  #  Path to node reference.
1309  #  #
1310  #  @path = path_to_node_ref( $treenode, $noderef )  #  @path = path_to_node_ref( $treenode, $noderef )
1311    #
1312  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1313  sub path_to_node_ref {  sub path_to_node_ref
1314      my ( $node, $noderef, @path0 ) = @_;  {
1315        my ( $node, $noderef ) = @_;
1316    
1317      push @path0, $node;      return ( $node ) if ( $node eq $noderef );
     if ( $node eq $noderef ) { return @path0 }  
1318    
     my @path;  
1319      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
1320      for ( my $i = 1; $i <= $imax; $i++ ) {      for ( my $i = 1; $i <= $imax; $i++ ) {
1321          @path = path_to_node_ref( newick_desc_i( $node, $i ), $noderef, ( @path0, $i ) );          my @suf = path_to_node_ref( newick_desc_i( $node, $i ), $noderef );
1322          return @path if @path;          return ( $node, $i, @suf ) if @suf;
1323      }      }
1324    
1325      ();  #  Not found      ();  #  Not found
# Line 1209  Line 1327 
1327    
1328    
1329  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1330  #  Path to node, as defined by 1 or 3 tips.  #  Path to node, as defined by 1, 2 or 3 node names (usually tips).
1331  #  #
1332  #  @path = path_to_node( $node,   $tip1, $tip2, $tip3   )  #  3 tip names  #  @path = path_to_node( $tree,   $name1, $name2, $name3   )  #  3 tip names
1333  #  @path = path_to_node( $node, [ $tip1, $tip2, $tip3 ] )  #  Allow array ref  #  @path = path_to_node( $tree, [ $name1, $name2, $name3 ] )  #  Allow array ref
1334  #  @path = path_to_node( $node,   $tip1                 )  #  Use path_to_tip  #  @path = path_to_node( $tree,   $name1, $name2   )          #  2 tip names
1335  #  @path = path_to_node( $node, [ $tip1 ]               )  #  Use path_to_tip  #  @path = path_to_node( $tree, [ $name1, $name2 ] )          #  Allow array ref
1336  #-------------------------------------------------------------------------------  #  @path = path_to_node( $tree,   $name1   )                  #  Path to tip or named node
1337  sub path_to_node {  #  @path = path_to_node( $tree, [ $name1 ] )                  #  Allow array ref
1338      my ( $node, $tip1, $tip2, $tip3 ) = @_;  #
1339      array_ref( $node ) && defined( $tip1 ) || return ();  #-------------------------------------------------------------------------------
1340    sub path_to_node
1341    {
1342        my ( $tree, @names ) = @_;
1343        array_ref( $tree ) && defined( $names[0] ) || return ();
1344    
1345      # Allow arg 2 to be an array reference      # Allow arg 2 to be an array reference
     if ( array_ref( $tip1 ) ) { ( $tip1, $tip2, $tip3 ) = @$tip1 }  
1346    
1347      my @p1 = path_to_tip( $node, $tip1 );                #  Path to first tip      @names = @{ $names[0] }  if array_ref( $names[0] );
     @p1 || return ();                                    #  Was the tip found?  
     defined( $tip2 ) && defined( $tip3 ) || return @p1;  #  Two more defined?  
1348    
1349      my @p2 = path_to_tip( $node, $tip2 );      return () if @names < 1 || @names > 3;
1350      my @p3 = path_to_tip( $node, $tip3 );  
1351      @p2 && @p3 || return ();                             #  Were they found?      #  Just one name:
1352    
1353        return path_to_named_node( $tree, $names[0] ) if ( @names == 1 );
1354    
1355      # Find the common prefix for each pair of paths      my @paths = values %{ paths_to_named_nodes( $tree, \@names ) };
1356      my @p12 = &common_prefix( \@p1, \@p2 );  
1357      my @p13 = &common_prefix( \@p1, \@p3 );      #  Were all node names found?
1358      my @p23 = &common_prefix( \@p2, \@p3 );  
1359        return () if @paths != @names;
1360    
1361        my @path12 = &common_prefix( @paths[0,1] );
1362        return () if ! @path12;
1363        return @path12 if @paths == 2;
1364    
1365        my @path13 = &common_prefix( @paths[0,2] );
1366        my @path23 = &common_prefix( @paths[1,2] );
1367    
1368      # Return the longest common prefix of any two paths      # Return the longest common prefix of any two paths
1369      ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :  
1370      ( @p13 >= @p23 )                 ? @p13 :      ( @path12 >= @path13 && @path12 >= @path23 ) ? @path12 :
1371                                         @p23 ;      ( @path13 >= @path23 )                       ? @path13 :
1372                                                       @path23 ;
1373  }  }
1374    
1375    
# Line 1247  Line 1377 
1377  #  Distance along path.  #  Distance along path.
1378  #  #
1379  #  $distance = newick_path_length( @path )  #  $distance = newick_path_length( @path )
1380    #
1381  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1382  sub newick_path_length {  sub newick_path_length
1383    {
1384      my $node = shift;      #  Discard the first node      my $node = shift;      #  Discard the first node
1385      array_ref( $node ) || return undef;      array_ref( $node ) || return undef;
1386      @_ ? distance_along_path_2( @_ ) : 0;      @_ ? distance_along_path_2( @_ ) : 0;
# Line 1259  Line 1391 
1391  #  This expects to get path minus root node:  #  This expects to get path minus root node:
1392  #  #
1393  #  $distance = distance_along_path_2( @path )  #  $distance = distance_along_path_2( @path )
1394    #
1395  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1396  sub distance_along_path_2 {  sub distance_along_path_2
1397    {
1398      shift;                 #  Discard descendant number      shift;                 #  Discard descendant number
1399      my $node = shift;      my $node = shift;
1400      array_ref( $node ) || return undef;      array_ref( $node ) || return undef;
# Line 1274  Line 1408 
1408  #  Tip-to-tip distance.  #  Tip-to-tip distance.
1409  #  #
1410  #  $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )  #  $distance = tip_to_tip_distance( $tree, $tip1, $tip2 )
1411    #
1412  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1413  sub tip_to_tip_distance {  sub tip_to_tip_distance
1414    {
1415      my ( $node, $tip1, $tip2 ) = @_;      my ( $node, $tip1, $tip2 ) = @_;
1416    
1417      array_ref( $node ) && defined( $tip1 )      array_ref( $node ) && defined( $tip1 )
# Line 1300  Line 1436 
1436  #                [ $tipname1, $tipname2, $tipname3 ]  #                [ $tipname1, $tipname2, $tipname3 ]
1437  #  #
1438  #  $distance = node_to_node_distance( $tree, $node1, $node2 )  #  $distance = node_to_node_distance( $tree, $node1, $node2 )
1439    #
1440  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1441  sub node_to_node_distance {  sub node_to_node_distance
1442    {
1443      my ( $node, $node1, $node2 ) = @_;      my ( $node, $node1, $node2 ) = @_;
1444    
1445      array_ref( $node ) && defined( $node1 )      array_ref( $node ) && defined( $node1 )
# Line 1326  Line 1464 
1464  #  Only defined fields are added, so tree list may be shorter than 8 fields.  #  Only defined fields are added, so tree list may be shorter than 8 fields.
1465  #  #
1466  #  $treecopy = copy_newick_tree( $tree )  #  $treecopy = copy_newick_tree( $tree )
1467    #
1468  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1469  sub copy_newick_tree {  sub copy_newick_tree
1470    {
1471      my ( $node ) = @_;      my ( $node ) = @_;
1472      array_ref( $node ) || return undef;      array_ref( $node ) || return undef;
1473    
# Line 1360  Line 1500 
1500  #  Use a hash to relabel the nodes in a newick tree.  #  Use a hash to relabel the nodes in a newick tree.
1501  #  #
1502  #  $newtree = newick_relabel_nodes( $node, \%new_name )  #  $newtree = newick_relabel_nodes( $node, \%new_name )
1503    #
1504  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1505  sub newick_relabel_nodes {  sub newick_relabel_nodes
1506    {
1507      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1508    
1509      my ( $lbl, $new );      my ( $new );
1510      if ( defined( $lbl = newick_lbl( $node ) )      if ( node_has_lbl( $node ) && defined( $new = $new_name->{ newick_lbl( $node ) } ) ) {
       && ( $lbl ne "" )  
       && defined( $new = $new_name->{ $lbl } )  
        ) {  
1511          set_newick_lbl( $node, $new );          set_newick_lbl( $node, $new );
1512      }      }
1513    
# Line 1384  Line 1523 
1523  #  Use a hash to relabel the nodes in a newick tree (case insensitive).  #  Use a hash to relabel the nodes in a newick tree (case insensitive).
1524  #  #
1525  #  $newtree = newick_relabel_nodes_i( $node, \%new_name )  #  $newtree = newick_relabel_nodes_i( $node, \%new_name )
1526    #
1527  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1528  sub newick_relabel_nodes_i {  sub newick_relabel_nodes_i
1529    {
1530      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1531    
1532      #  Add any necessary lowercase keys to the hash:      #  Add any necessary lowercase keys to the hash:
# Line 1403  Line 1544 
1544  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1545  #  Do the actual relabeling  #  Do the actual relabeling
1546  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1547  sub newick_relabel_nodes_i2 {  sub newick_relabel_nodes_i2
1548    {
1549      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1550    
1551      my ( $lbl, $new );      my ( $new );
1552      if ( defined( $lbl = newick_lbl( $node ) )      if ( node_has_lbl( $node ) && defined( $new = $new_name->{ lc newick_lbl( $node ) } ) ) {
       && ( $lbl ne "" )  
       && defined( $new = $new_name->{ lc $lbl } )  
        ) {  
1553          set_newick_lbl( $node, $new );          set_newick_lbl( $node, $new );
1554      }      }
1555    
# Line 1426  Line 1565 
1565  #  Use a hash to relabel the tips in a newick tree.  #  Use a hash to relabel the tips in a newick tree.
1566  #  #
1567  #  $newtree = newick_relabel_tips( $node, \%new_name )  #  $newtree = newick_relabel_tips( $node, \%new_name )
1568    #
1569  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1570  sub newick_relabel_tips {  sub newick_relabel_tips
1571    {
1572      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1573    
1574      my @desc = newick_desc_list( $node );      my @desc = newick_desc_list( $node );
# Line 1436  Line 1577 
1577          foreach ( @desc ) { newick_relabel_tips( $_, $new_name ) }          foreach ( @desc ) { newick_relabel_tips( $_, $new_name ) }
1578      }      }
1579      else {      else {
1580          my ( $lbl, $new );          my ( $new );
1581          if ( defined( $lbl = newick_lbl( $node ) )          if ( node_has_lbl( $node ) && defined( $new = $new_name->{ newick_lbl( $node ) } ) ) {
           && ( $lbl ne "" )  
           && defined( $new = $new_name->{ $lbl } )  
            ) {  
1582              set_newick_lbl( $node, $new );              set_newick_lbl( $node, $new );
1583          }          }
1584      }      }
# Line 1453  Line 1591 
1591  #  Use a hash to relabel the tips in a newick tree (case insensitive).  #  Use a hash to relabel the tips in a newick tree (case insensitive).
1592  #  #
1593  #  $newtree = newick_relabel_tips_i( $node, \%new_name )  #  $newtree = newick_relabel_tips_i( $node, \%new_name )
1594    #
1595  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1596  sub newick_relabel_tips_i {  sub newick_relabel_tips_i
1597    {
1598      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1599    
1600      #  Add any necessary lowercase keys to the hash:      #  Add any necessary lowercase keys to the hash:
# Line 1472  Line 1612 
1612  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1613  #  Do the actual relabeling  #  Do the actual relabeling
1614  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1615  sub newick_relabel_tips_i2 {  sub newick_relabel_tips_i2
1616    {
1617      my ( $node, $new_name ) = @_;      my ( $node, $new_name ) = @_;
1618    
1619      my @desc = newick_desc_list( $node );      my @desc = newick_desc_list( $node );
# Line 1481  Line 1622 
1622          foreach ( @desc ) { newick_relabel_tips_i2( $_, $new_name ) }          foreach ( @desc ) { newick_relabel_tips_i2( $_, $new_name ) }
1623      }      }
1624      else {      else {
1625          my ( $lbl, $new );          my ( $new );
1626          if ( defined( $lbl = newick_lbl( $node ) )          if ( node_has_lbl( $node ) && defined( $new = $new_name->{ lc newick_lbl( $node ) } ) ) {
           && ( $lbl ne "" )  
           && defined( $new = $new_name->{ lc $lbl } )  
            ) {  
1627              set_newick_lbl( $node, $new );              set_newick_lbl( $node, $new );
1628          }          }
1629      }      }
# Line 1498  Line 1636 
1636  #  Set undefined branch lenghts (except root) to length x.  #  Set undefined branch lenghts (except root) to length x.
1637  #  #
1638  #  $n_changed = newick_set_undefined_branches( $node, $x )  #  $n_changed = newick_set_undefined_branches( $node, $x )
1639    #
1640  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1641  sub newick_set_undefined_branches {  sub newick_set_undefined_branches
1642    {
1643      my ( $node, $x, $not_root ) = @_;      my ( $node, $x, $not_root ) = @_;
1644    
1645      my $n = 0;      my $n = 0;
# Line 1520  Line 1660 
1660  #  Set all branch lenghts (except root) to length x.  #  Set all branch lenghts (except root) to length x.
1661  #  #
1662  #  $n_changed = newick_set_all_branches( $node, $x )  #  $n_changed = newick_set_all_branches( $node, $x )
1663    #
1664  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1665  sub newick_set_all_branches {  sub newick_set_all_branches
1666    {
1667      my ( $node, $x, $not_root ) = @_;      my ( $node, $x, $not_root ) = @_;
1668    
1669      my $n = 0;      my $n = 0;
# Line 1544  Line 1686 
1686  #  Rescale all branch lenghts by factor.  #  Rescale all branch lenghts by factor.
1687  #  #
1688  #  $node = newick_rescale_branches( $node, $factor )  #  $node = newick_rescale_branches( $node, $factor )
1689    #
1690  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1691  sub newick_rescale_branches {  sub newick_rescale_branches
1692    {
1693      my ( $node, $factor ) = @_;      my ( $node, $factor ) = @_;
1694    
1695      my $x = newick_x( $node );      my $x = newick_x( $node );
# Line 1561  Line 1705 
1705    
1706    
1707  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1708    #  Set all branch lenghts (except root) to random number between x1 and x2.
1709    #
1710    #  $node = newick_random_branch_lengths( $node, $x1, $x2 )
1711    #
1712    #-------------------------------------------------------------------------------
1713    sub newick_random_branch_lengths
1714    {
1715        my ( $node, $x1, $x2 ) = @_;
1716        return undef if ! array_ref( $node );
1717        $x1 = 0        if ! defined( $x1 ) || $x1 < 0;
1718        $x2 = $x1 + 1  if ! defined( $x2 ) || $x2 < $x1;
1719        newick_random_branch_lengths_0( $node, $x1, $x2, 0 );
1720    }
1721    
1722    
1723    sub newick_random_branch_lengths_0
1724    {
1725        my ( $node, $x1, $x2, $not_root ) = @_;
1726    
1727        set_newick_x( $node, rand($x2-$x1) + $x1 ) if ( $not_root );
1728        foreach ( newick_desc_list( $node ) ) { newick_random_branch_lengths_0( $_, $x1, $x2, 1 ) }
1729    
1730        $node;
1731    }
1732    
1733    
1734    #-------------------------------------------------------------------------------
1735  #  Modify all branch lengths by a function.  #  Modify all branch lengths by a function.
1736  #  #
1737  #     $node = newick_modify_branches( $node, \&function )  #     $node = newick_modify_branches( $node, \&function )
# Line 1572  Line 1743 
1743  #     $x2 = &$function( $x1, @$func_parms )  #     $x2 = &$function( $x1, @$func_parms )
1744  #  #
1745  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1746  sub newick_modify_branches {  sub newick_modify_branches
1747    {
1748      my ( $node, $func, $parm ) = @_;      my ( $node, $func, $parm ) = @_;
1749    
1750      set_newick_x( $node, &$func( newick_x( $node ), ( $parm ? @$parm : () ) ) );      set_newick_x( $node, &$func( newick_x( $node ), ( $parm ? @$parm : () ) ) );
# Line 1589  Line 1761 
1761  #  Set negative branches to zero.  The original tree is modfied.  #  Set negative branches to zero.  The original tree is modfied.
1762  #  #
1763  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
1764    #
1765  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1766  sub newick_fix_negative_branches {  sub newick_fix_negative_branches
1767    {
1768      my ( $tree ) = @_;      my ( $tree ) = @_;
1769      array_ref( $tree ) or return undef;      array_ref( $tree ) or return undef;
1770      my $n_changed = 0;      my $n_changed = 0;
# Line 1614  Line 1788 
1788  #  Remove comments from a newick tree (e.g., before writing for phylip).  #  Remove comments from a newick tree (e.g., before writing for phylip).
1789  #  #
1790  #  $node = newick_strip_comments( $node )  #  $node = newick_strip_comments( $node )
1791    #
1792  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1793  sub newick_strip_comments {  sub newick_strip_comments
1794    {
1795      my ( $node ) = @_;      my ( $node ) = @_;
1796    
1797      @$node = @$node[ 0 .. 2 ];      @$node = @$node[ 0 .. 2 ];
# Line 1628  Line 1804 
1804  #  Normalize tree order (in place).  #  Normalize tree order (in place).
1805  #  #
1806  #  ( $tree, $label1 ) = normalize_newick_tree( $tree )  #  ( $tree, $label1 ) = normalize_newick_tree( $tree )
1807    #
1808  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1809  sub normalize_newick_tree {  sub normalize_newick_tree
1810    {
1811      my ( $node ) = @_;      my ( $node ) = @_;
1812    
1813      my @descends = newick_desc_list( $node );      my @descends = newick_desc_list( $node );
# Line 1647  Line 1825 
1825  #  Reverse tree order (in place).  #  Reverse tree order (in place).
1826  #  #
1827  #  $tree = reverse_newick_tree( $tree )  #  $tree = reverse_newick_tree( $tree )
1828    #
1829  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1830  sub reverse_newick_tree {  sub reverse_newick_tree
1831    {
1832      my ( $node ) = @_;      my ( $node ) = @_;
1833    
1834      my @descends = newick_desc_list( $node );      my @descends = newick_desc_list( $node );
# Line 1664  Line 1844 
1844  #  Standard unrooted tree (in place).  #  Standard unrooted tree (in place).
1845  #  #
1846  #  $stdtree = std_unrooted_newick( $tree )  #  $stdtree = std_unrooted_newick( $tree )
1847    #
1848  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1849  sub std_unrooted_newick {  sub std_unrooted_newick
1850    {
1851      my ( $tree ) = @_;      my ( $tree ) = @_;
1852    
1853      my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );      my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
# Line 1714  Line 1896 
1896  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1897  #  Move largest groups to periphery of tree (in place).  #  Move largest groups to periphery of tree (in place).
1898  #  #
1899    #  $tree = aesthetic_newick_tree( $treeref, $dir )
1900    #
1901  #      dir  <= -2 for up-sweeping tree (big groups always first),  #      dir  <= -2 for up-sweeping tree (big groups always first),
1902  #            = -1 for big group first, balanced tree,  #            = -1 for big group first, balanced tree,
1903  #            =  0 for balanced tree,  #            =  0 for balanced tree,
1904  #            =  1 for small group first, balanced tree, and  #            =  1 for small group first, balanced tree, and
1905  #           >=  2 for down-sweeping tree (small groups always top)  #           >=  2 for down-sweeping tree (small groups always top)
1906  #  #
 #  $tree = aesthetic_newick_tree( $treeref, $dir )  
1907  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1908  sub aesthetic_newick_tree {  sub aesthetic_newick_tree
1909    {
1910      my ( $tree, $dir ) = @_;      my ( $tree, $dir ) = @_;
1911      my %cnt;      my %cnt;
1912    
# Line 1741  Line 1925 
1925  #  Access count with $cntref->{$noderef}  #  Access count with $cntref->{$noderef}
1926  #  #
1927  #  $count = build_tip_count_hash( $node, $cnt_hash_ref )  #  $count = build_tip_count_hash( $node, $cnt_hash_ref )
1928    #
1929  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1930  sub build_tip_count_hash {  sub build_tip_count_hash
1931    {
1932      my ( $node, $cntref ) = @_;      my ( $node, $cntref ) = @_;
1933      my ( $i, $cnt );      my ( $i, $cnt );
1934    
# Line 1765  Line 1951 
1951  #           = 0 for no change, and  #           = 0 for no change, and
1952  #           > 0 for downward branch (small group first).  #           > 0 for downward branch (small group first).
1953  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1954  sub reorder_by_tip_count {  sub reorder_by_tip_count
1955    {
1956      my ( $node, $cntref, $dir ) = @_;      my ( $node, $cntref, $dir ) = @_;
1957    
1958      my $nd = newick_n_desc( $node );      my $nd = newick_n_desc( $node );
# Line 1810  Line 1997 
1997  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1998  #  Move smallest groups to periphery of tree (in place).  #  Move smallest groups to periphery of tree (in place).
1999  #  #
2000    #  $tree = unaesthetic_newick_tree( $treeref, $dir )
2001    #
2002  #      dir  <= -2 for up-sweeping tree (big groups always first),  #      dir  <= -2 for up-sweeping tree (big groups always first),
2003  #            = -1 for big group first, balanced tree,  #            = -1 for big group first, balanced tree,
2004  #            =  0 for balanced tree,  #            =  0 for balanced tree,
2005  #            =  1 for small group first, balanced tree, and  #            =  1 for small group first, balanced tree, and
2006  #           >=  2 for down-sweeping tree (small groups always top)  #           >=  2 for down-sweeping tree (small groups always top)
2007  #  #
 #  $tree = unaesthetic_newick_tree( $treeref, $dir )  
2008  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2009  sub unaesthetic_newick_tree  sub unaesthetic_newick_tree
2010  {  {
# Line 1878  Line 2066 
2066  #  Randomize descendant order at each node (in place).  #  Randomize descendant order at each node (in place).
2067  #  #
2068  #  $tree = random_order_newick_tree( $tree )  #  $tree = random_order_newick_tree( $tree )
2069    #
2070  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2071  sub random_order_newick_tree  sub random_order_newick_tree
2072  {  {
# Line 1900  Line 2089 
2089    
2090    
2091  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2092    #  Reroot a tree using method specified by options.
2093    #
2094    #     $newtree = reroot_tree( $tree, \%options )
2095    #
2096    #  Options
2097    #
2098    #     adjacent_to_tip =>  $tip         # root next to named tip (no nodes)
2099    #     adjacent_to_tip =>  $bool        # root next to tip defined by nodes
2100    #     distance        =>  $distance    # distance on path from node1 to node2
2101    #     fraction        =>  $fraction    # fraction of path from node1 to node2
2102    #     midpoint        =>  $bool        # midpoint root tree (no nodes)
2103    #     node            =>  $node_spec   # just one node spec
2104    #     nodes           => \@node_specs  # 0, 1 or 2 node specifiers
2105    #     tip             =>  $tip         # short way to get tip root
2106    #
2107    #  node_spec can be 1, 2 or 3 node labels:
2108    #
2109    #     With 1 label, it is the node with that name (tip or internal)
2110    #     With 2 labels, it is the most recent common ancestor of the 2 named nodes
2111    #     With 3 labels, it is the intersection point of the paths to the 3 nodes
2112    #
2113    #-------------------------------------------------------------------------------
2114    sub reroot_tree
2115    {
2116        my ( $tree, $opts ) = @_;
2117        return undef if ! array_ref( $tree );
2118        $opts ||= {};
2119    
2120        return reroot_newick_to_midpoint_w( $tree ) if $opts->{ midpoint };
2121    
2122        #  All other options require 1 or 2 node specifiers
2123    
2124        my @nodes = array_ref( $opts->{ nodes } ) ? @{ $opts->{ nodes } } : ();
2125        push @nodes, $opts->{ node } if array_ref( $opts->{ node } );
2126    
2127        foreach ( @nodes )
2128        {
2129            next if ( array_ref( $_ ) && ( @$_ > 0 ) && ( @$_ <= 3 ) );
2130            print STDERR "Bad node specifier passed to gjonewicklib::reroot_tree().\n";
2131            return $tree;
2132        }
2133    
2134        my $adj_to_tip = $opts->{ adjacent_to_tip };
2135        my $distance   = $opts->{ distance };
2136        my $fraction   = $opts->{ fraction };
2137        my $tip        = $opts->{ tip };
2138    
2139        if ( defined( $distance ) )
2140        {
2141            return $tree if @nodes != 2;
2142            $distance = 0 if $distance < 0;
2143            $tree = reroot_newick_at_dist_between_nodes( $tree, @nodes, $distance )
2144        }
2145        elsif ( @nodes == 2 )
2146        {
2147            $fraction = 0.5 if ! defined( $fraction );
2148            $fraction = 0   if $fraction < 0;
2149            $fraction = 1   if $fraction > 1;
2150            $tree = reroot_newick_between_nodes( $tree, @nodes, $fraction )
2151        }
2152        elsif ( $adj_to_tip )
2153        {
2154            $adj_to_tip = $nodes[0]->[0] if @nodes == 1 && @{$nodes[0]} == 1;
2155            $tree = reroot_newick_next_to_tip( $tree, $adj_to_tip );
2156        }
2157        elsif ( @nodes == 1 )
2158        {
2159            #  Root at node:
2160            $tree = reroot_newick_to_node( $tree, $nodes[0] );
2161        }
2162        elsif ( defined( $tip ) && $tip ne '' )
2163        {
2164            #  Root at tip:
2165            $tree = reroot_newick_to_tip( $tree, $tip );
2166        }
2167    
2168        return $tree;
2169    }
2170    
2171    
2172    #-------------------------------------------------------------------------------
2173  #  Reroot a tree to the node that lies at the end of a path.  #  Reroot a tree to the node that lies at the end of a path.
2174  #  #
2175  #  $newtree = reroot_newick_by_path( @path )  #  $newtree = reroot_newick_by_path( @path )
2176    #
2177  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2178  sub reroot_newick_by_path  sub reroot_newick_by_path
2179  {  {
# Line 1970  Line 2241 
2241  #  Move root of tree to named tip.  #  Move root of tree to named tip.
2242  #  #
2243  #  $newtree = reroot_newick_to_tip( $tree, $tip )  #  $newtree = reroot_newick_to_tip( $tree, $tip )
2244    #
2245  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2246  sub reroot_newick_to_tip {  sub reroot_newick_to_tip
2247    {
2248      my ( $tree, $tipname ) = @_;      my ( $tree, $tipname ) = @_;
2249      reroot_newick_by_path( path_to_tip( $tree, $tipname ) );      reroot_newick_by_path( path_to_tip( $tree, $tipname ) );
2250  }  }
# Line 1981  Line 2254 
2254  #  Move root of tree to be node adjacent to a named tip.  #  Move root of tree to be node adjacent to a named tip.
2255  #  #
2256  #  $newtree = reroot_newick_next_to_tip( $tree, $tip )  #  $newtree = reroot_newick_next_to_tip( $tree, $tip )
2257    #
2258  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2259  sub reroot_newick_next_to_tip {  sub reroot_newick_next_to_tip
2260    {
2261      my ( $tree, $tipname ) = @_;      my ( $tree, $tipname ) = @_;
2262      my @path = path_to_tip( $tree, $tipname );      my @path = path_to_tip( $tree, $tipname );
2263      @path || return undef;      @path || return undef;
# Line 1995  Line 2270 
2270  #  Move root of tree to a node, defined by 1 or 3 tip names.  #  Move root of tree to a node, defined by 1 or 3 tip names.
2271  #  #
2272  #  $newtree = reroot_newick_to_node( $tree, @node )  #  $newtree = reroot_newick_to_node( $tree, @node )
2273    #
2274  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2275  sub reroot_newick_to_node {  sub reroot_newick_to_node
2276    {
2277      reroot_newick_by_path( path_to_node( @_ ) );      reroot_newick_by_path( path_to_node( @_ ) );
2278  }  }
2279    
# Line 2005  Line 2282 
2282  #  Move root of tree to a node, defined by reference.  #  Move root of tree to a node, defined by reference.
2283  #  #
2284  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )
2285    #
2286  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2287  sub reroot_newick_to_node_ref {  sub reroot_newick_to_node_ref
2288    {
2289      my ( $tree, $node ) = @_;      my ( $tree, $node ) = @_;
2290      reroot_newick_by_path( path_to_node_ref( $tree, $node ) );      reroot_newick_by_path( path_to_node_ref( $tree, $node ) );
2291  }  }
# Line 2016  Line 2295 
2295  #  Reroot a newick tree along the path between 2 nodes:  #  Reroot a newick tree along the path between 2 nodes:
2296  #  #
2297  #  $tree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )  #  $tree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
2298    #
2299  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2300  sub reroot_newick_between_nodes  sub reroot_newick_between_nodes
2301  {  {
2302      my ( $tree, $node1, $node2, $fraction ) = @_;      my ( $tree, $node1, $node2, $fraction ) = @_;
2303      array_ref( $tree ) or return undef;      array_ref( $tree ) or return undef;
     $fraction >= 0 && $fraction <= 1 or return undef;  
2304    
2305      #  Find the paths to the nodes:      #  Find the paths to the nodes:
2306    
2307      my @path1 = path_to_node( $tree, $node1 ) or return undef;      my @path1 = path_to_node( $tree, $node1 ) or return $tree;
2308      my @path2 = path_to_node( $tree, $node2 ) or return undef;      my @path2 = path_to_node( $tree, $node2 ) or return $tree;
2309    
2310      reroot_newick_between_nodes_by_path( $tree, \@path1, \@path2, $fraction )      reroot_newick_between_nodes_by_path( \@path1, \@path2, $fraction )
2311  }  }
2312    
2313    
# Line 2036  Line 2315 
2315  #  Reroot a newick tree along the path between 2 nodes:  #  Reroot a newick tree along the path between 2 nodes:
2316  #  #
2317  #  $tree = reroot_newick_between_node_refs( $tree, $node1, $node2, $fraction )  #  $tree = reroot_newick_between_node_refs( $tree, $node1, $node2, $fraction )
2318    #
2319  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2320  sub reroot_newick_between_node_refs  sub reroot_newick_between_node_refs
2321  {  {
# Line 2044  Line 2324 
2324    
2325      #  Find the paths to the nodes:      #  Find the paths to the nodes:
2326    
2327      my @path1 = path_to_node_ref( $tree, $node1 ) or return undef;      my @path1 = path_to_node_ref( $tree, $node1 ) or return $tree;
2328      my @path2 = path_to_node_ref( $tree, $node2 ) or return undef;;      my @path2 = path_to_node_ref( $tree, $node2 ) or return $tree;
2329    
2330      reroot_newick_between_nodes_by_path( $tree, \@path1, \@path2, $fraction )      reroot_newick_between_nodes_by_path( \@path1, \@path2, $fraction )
2331  }  }
2332    
2333    
2334  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2335  #  Reroot a newick tree along the path between 2 nodes defined by paths:  #  Reroot a newick tree along the path between 2 nodes defined by paths:
2336  #  #
2337  #  $tree = reroot_newick_between_nodes_by_path( $tree, $path1, $path2, $fraction )  #  $tree = reroot_newick_between_nodes_by_path( $path1, $path2, $fraction )
2338    #
2339  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2340  sub reroot_newick_between_nodes_by_path  sub reroot_newick_between_nodes_by_path
2341  {  {
2342      my ( $tree, $path1, $path2, $fraction ) = @_;      my ( $path1, $path2, $fraction ) = @_;
2343      array_ref( $tree ) and array_ref( $path1 ) and  array_ref( $path2 )      array_ref( $path1 ) && array_ref( $path2 ) or return undef;
        or return undef;  
     $fraction >= 0 && $fraction <= 1 or return undef;  
2344    
2345      my @path1 = @$path1;      $fraction = 0 if ( ! defined( $fraction ) ) || ( $fraction < 0 );
2346      my @path2 = @$path2;      $fraction = 1 if ( $fraction > 1 );
2347    
2348      #  Trim the common prefix, saving it:      my $prefix;
2349        ( $prefix, $path1, $path2 ) = common_and_unique_paths( $path1, $path2 );
2350    
2351      my @prefix = ();      my $dist1 = ( @$path1 >= 3 ) ? newick_path_length( @$path1 ) : 0;
2352      while ( defined( $path1[1] ) && defined( $path2[1] ) && ( $path1[1] == $path2[1] ) )      my $dist2 = ( @$path2 >= 3 ) ? newick_path_length( @$path2 ) : 0;
2353    
2354        #  Case where there is no length (possibly same node):
2355    
2356        return reroot_newick_by_path( @$prefix, $path1->[0] ) if $dist1 + $dist2 <= 0;
2357    
2358        my $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
2359        my $path = ( $dist <= 0 ) ? $path1 : $path2;
2360        $dist = abs( $dist );
2361    
2362        #  Descend tree until we reach the insertion branch:
2363    
2364        reroot_newick_at_dist_along_path( $prefix, $path, $dist );
2365    }
2366    
2367    
2368    #-------------------------------------------------------------------------------
2369    #  Reroot a newick tree along the path between 2 nodes:
2370    #
2371    #  $tree = reroot_newick_at_dist_between_nodes( $tree, $node1, $node2, $distance )
2372    #
2373    #-------------------------------------------------------------------------------
2374    sub reroot_newick_at_dist_between_nodes
2375      {      {
2376          push @prefix, splice( @path1, 0, 2 );      my ( $tree, $node1, $node2, $distance ) = @_;
2377          splice( @path2, 0, 2 );      array_ref( $tree ) or return undef;
2378    
2379        #  Find the paths to the nodes:
2380    
2381        my @path1 = path_to_node( $tree, $node1 ) or return $tree;
2382        my @path2 = path_to_node( $tree, $node2 ) or return $tree;
2383    
2384        reroot_newick_at_dist_between_nodes_by_path( \@path1, \@path2, $distance );
2385      }      }
2386    
2387      my ( @path, $dist );  
2388      if    ( @path1 < 3 )  #-------------------------------------------------------------------------------
2389    #  Reroot a newick tree along the path between 2 nodes identified by ref:
2390    #
2391    #  $tree = reroot_newick_at_dist_between_node_refs( $tree, $node1, $node2, $distance )
2392    #
2393    #-------------------------------------------------------------------------------
2394    sub reroot_newick_at_dist_between_node_refs
2395      {      {
2396          @path2 >= 3 or return undef;              # node1 = node2      my ( $tree, $node1, $node2, $distance ) = @_;
2397          $dist = $fraction * newick_path_length( @path2 );      array_ref( $tree ) or return undef;
2398          @path = @path2;  
2399        #  Find the paths to the nodes:
2400    
2401        my @path1 = path_to_node_ref( $tree, $node1 ) or return $tree;
2402        my @path2 = path_to_node_ref( $tree, $node2 ) or return $tree;
2403    
2404        reroot_newick_at_dist_between_nodes_by_path( \@path1, \@path2, $distance );
2405      }      }
2406      elsif ( @path2 < 3 )  
2407    
2408    #-------------------------------------------------------------------------------
2409    #  Reroot a newick tree along the path between 2 nodes defined by paths:
2410    #
2411    #  $tree = reroot_newick_at_dist_between_nodes_by_path( $path1, $path2, $distance )
2412    #
2413    #-------------------------------------------------------------------------------
2414    sub reroot_newick_at_dist_between_nodes_by_path
2415      {      {
2416          $dist = ( 1 - $fraction ) * newick_path_length( @path1 );      my ( $path1, $path2, $distance ) = @_;
2417          @path = @path1;      array_ref( $path1 ) && array_ref( $path2 ) or return undef;
2418        $distance = 0 if ( ! defined( $distance ) ) || ( $distance < 0 );
2419    
2420        my $prefix;
2421        ( $prefix, $path1, $path2 ) = common_and_unique_paths( $path1, $path2 );
2422    
2423        my $dist1 = ( @$path1 >= 3 ) ? newick_path_length( @$path1 ) : 0;
2424        my $dist2 = ( @$path2 >= 3 ) ? newick_path_length( @$path2 ) : 0;
2425    
2426        #  Case where there is no length (possibly same node):
2427    
2428        return reroot_newick_by_path( @$prefix, $path1->[0] ) if $dist1 + $dist2 <= 0;
2429    
2430        my ( $path, $dist );
2431        if ( $distance < $dist1 )
2432        {
2433            $path = $path1;
2434            $dist = $dist1 - $distance;
2435      }      }
2436      else      else
2437      {      {
2438          my $dist1 = newick_path_length( @path1 );          $path = $path2;
2439          my $dist2 = newick_path_length( @path2 );          $dist = $distance - $dist1;
         $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;  
         @path = ( $dist <= 0 ) ? @path1 : @path2;  
         $dist = abs( $dist );  
2440      }      }
2441    
2442      #  Descend tree until we reach the insertion branch:      #  Descend tree until we reach the insertion branch:
2443    
2444      my $x;      reroot_newick_at_dist_along_path( $prefix, $path, $dist );
2445      while ( ( $dist > ( $x = newick_x( $path[2] ) ) ) && ( @path > 3 ) )  }
2446    
2447    
2448    #-------------------------------------------------------------------------------
2449    #  Reroot a newick tree along the path between 2 nodes defined by paths:
2450    #
2451    #  ( \@common, \@unique1, \@unique2 ) = common_and_unique_paths( \@path1, \@path2 )
2452    #
2453    #-------------------------------------------------------------------------------
2454    sub common_and_unique_paths
2455    {
2456        my ( $path1, $path2 ) = @_;
2457    
2458        my @path1 = @$path1;
2459        my @path2 = @$path2;
2460    
2461        #  Trim the common prefix, saving it:
2462    
2463        my $i = 1;
2464        my $imax = min( scalar @path1, scalar @path2 );
2465        while ( ( $i < $imax ) && ( $path1[$i] == $path2[$i] ) ) { $i += 2 }
2466    
2467        my @prefix = ();
2468        if ( $i > 1 ) { @prefix = splice( @path1, 0, $i-1 ); splice( @path2, 0, $i-1 ) }
2469    
2470        ( \@prefix, \@path1, \@path2 );
2471    }
2472    
2473    
2474    #-------------------------------------------------------------------------------
2475    #  Reroot a newick tree at a distance from the most ancestral node along a path:
2476    #
2477    #  $tree = reroot_newick_at_dist_along_path( \@prefix, \@path, $distance )
2478    #
2479    #     -   n1              n1
2480    #     |  /  \            /  \
2481    #     |      \ x2            \ x2
2482    #     |       \               \
2483    #     | dist   n2              n2
2484    #     |       /  \            /  \ x23 = dist - x2
2485    #     |           \               \
2486    #     -----------  \ x3  --------  n23
2487    #                   \             /  \ x3' = x3 - x23
2488    #                    n3               n3
2489    #                   /  \             /  \
2490    #
2491    #-------------------------------------------------------------------------------
2492    sub reroot_newick_at_dist_along_path
2493    {
2494        my ( $prefix, $path, $dist ) = @_;
2495        array_ref( $prefix ) or return undef;
2496        array_ref( $path )   or return $prefix->[0];
2497        defined( $dist )     or $dist = 0;
2498    
2499        my @prefix = @$prefix;
2500        my @path   = @$path;
2501    
2502        #  Descend tree until we reach the insertion branch:
2503    
2504        my $x = ( @path > 2 ) ? newick_x( $path[2] ) : 0;
2505        while ( ( @path > 4 ) && ( $dist > $x ) )
2506      {      {
2507          $dist -= $x;          $dist -= $x;
2508          push @prefix, splice( @path, 0, 2 );          push @prefix, splice( @path, 0, 2 );
2509            $x = newick_x( $path[2] );
2510      }      }
2511        $dist = $x if ( $dist > $x );
2512    
2513      #  Insert the new node:      #  Insert the new node:
2514    
2515      my $newnode = [ [ $path[2] ], undef, $dist ];      my $newnode = [ [ $path[2] ], undef, $dist ];
2516      set_newick_desc_i( $path[0], $path[1], $newnode );      set_newick_desc_i( $path[0], $path[1], $newnode );
2517      set_newick_x( $path[2], ( ( $x > $dist ) ? ( $x - $dist ) : 0 ) );      set_newick_x( $path[2], $x - $dist );
2518    
2519      #  We can now build the path from root to the new node      #  We can now build the path from root to the new node
2520    
# Line 2121  Line 2526 
2526  #  Move root of tree to an approximate midpoint.  #  Move root of tree to an approximate midpoint.
2527  #  #
2528  #  $newtree = reroot_newick_to_approx_midpoint( $tree )  #  $newtree = reroot_newick_to_approx_midpoint( $tree )
2529    #
2530  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2531  sub reroot_newick_to_approx_midpoint {  sub reroot_newick_to_approx_midpoint
2532    {
2533      my ( $tree ) = @_;      my ( $tree ) = @_;
2534    
2535      #  Compile average tip to node distances assending      #  Compile average tip to node distances assending
# Line 2146  Line 2553 
2553  #  Move root of tree to a midpoint.  #  Move root of tree to a midpoint.
2554  #  #
2555  #  $newtree = reroot_newick_to_midpoint( $tree )  #  $newtree = reroot_newick_to_midpoint( $tree )
2556    #
2557  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2558  sub reroot_newick_to_midpoint {  sub reroot_newick_to_midpoint
2559    {
2560      my ( $tree ) = @_;      my ( $tree ) = @_;
2561    
2562      #  Compile average tip to node distances assending      #  Compile average tip to node distances assending
# Line 2166  Line 2575 
2575  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2576  #  Compile average tip to node distances assending  #  Compile average tip to node distances assending
2577  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2578  sub average_to_tips_1 {  sub average_to_tips_1
2579    {
2580      my ( $node ) = @_;      my ( $node ) = @_;
2581    
2582      my @desc_dists = map { average_to_tips_1( $_ ) } newick_desc_list( $node );      my @desc_dists = map { average_to_tips_1( $_ ) } newick_desc_list( $node );
# Line 2188  Line 2598 
2598  #  Compile average tip to node distances descending, returning midpoint as  #  Compile average tip to node distances descending, returning midpoint as
2599  #  [ $node1, $node2, $fraction_of_dist_between ]  #  [ $node1, $node2, $fraction_of_dist_between ]
2600  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2601  sub average_to_tips_2 {  sub average_to_tips_2
2602    {
2603      my ( $dists1, $x_above, $anc_node ) = @_;      my ( $dists1, $x_above, $anc_node ) = @_;
2604      my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;      my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;
2605    
# Line 2235  Line 2646 
2646  #  Move root of tree to an approximate midpoint.  Weight by tips.  #  Move root of tree to an approximate midpoint.  Weight by tips.
2647  #  #
2648  #  $newtree = reroot_newick_to_approx_midpoint_w( $tree )  #  $newtree = reroot_newick_to_approx_midpoint_w( $tree )
2649    #
2650  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2651  sub reroot_newick_to_approx_midpoint_w {  sub reroot_newick_to_approx_midpoint_w
2652    {
2653      my ( $tree ) = @_;      my ( $tree ) = @_;
2654      array_ref( $tree ) or return undef;      array_ref( $tree ) or return undef;
2655    
# Line 2260  Line 2673 
2673  #  Move root of tree to an approximate midpoint.  Weight by tips.  #  Move root of tree to an approximate midpoint.  Weight by tips.
2674  #  #
2675  #  $newtree = reroot_newick_to_midpoint_w( $tree )  #  $newtree = reroot_newick_to_midpoint_w( $tree )
2676    #
2677  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2678  sub reroot_newick_to_midpoint_w {  sub reroot_newick_to_midpoint_w
2679    {
2680      my ( $tree ) = @_;      my ( $tree ) = @_;
2681      array_ref( $tree ) or return ();      array_ref( $tree ) or return ();
2682    
# Line 2280  Line 2695 
2695    
2696    
2697  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2698  sub average_to_tips_1_w {  sub average_to_tips_1_w
2699    {
2700      my ( $node ) = @_;      my ( $node ) = @_;
2701    
2702      my @desc_dists = map { average_to_tips_1_w( $_ ) } newick_desc_list( $node );      my @desc_dists = map { average_to_tips_1_w( $_ ) } newick_desc_list( $node );
# Line 2306  Line 2722 
2722    
2723    
2724  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2725  sub average_to_tips_2_w {  sub average_to_tips_2_w
2726    {
2727      my ( $dists1, $x_above, $n_above, $anc_node ) = @_;      my ( $dists1, $x_above, $n_above, $anc_node ) = @_;
2728      my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;      my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;
2729    
# Line 2359  Line 2776 
2776  #  Move root of tree from tip to adjacent node.  #  Move root of tree from tip to adjacent node.
2777  #  #
2778  #  $newtree = uproot_tip_rooted_newick( $tree )  #  $newtree = uproot_tip_rooted_newick( $tree )
2779    #
2780  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2781  sub uproot_tip_rooted_newick {  sub uproot_tip_rooted_newick
2782    {
2783      my ( $node ) = @_;      my ( $node ) = @_;
2784      newick_is_tip_rooted( $node ) || return $node;      newick_is_tip_rooted( $node ) || return $node;
2785    
# Line 2376  Line 2795 
2795  #  Root node label, label comment and descendant list comment are discarded.  #  Root node label, label comment and descendant list comment are discarded.
2796  #  #
2797  #  $newtree = uproot_newick( $tree )  #  $newtree = uproot_newick( $tree )
2798    #
2799  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2800  sub uproot_newick {  sub uproot_newick
2801    {
2802      my ( $node0 ) = @_;      my ( $node0 ) = @_;
2803      newick_is_rooted( $node0 ) || return $node0;      newick_is_rooted( $node0 ) || return $node0;
2804    
# Line 2424  Line 2845 
2845  #  Prefix branch of node2 to that of node1:  #  Prefix branch of node2 to that of node1:
2846  #  #
2847  #  $node1 = add_to_newick_branch( $node1, $node2 )  #  $node1 = add_to_newick_branch( $node1, $node2 )
2848    #
2849  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2850  sub add_to_newick_branch {  sub add_to_newick_branch
2851    {
2852      my ( $node1, $node2 ) = @_;      my ( $node1, $node2 ) = @_;
2853      array_ref( $node1 ) || die "add_to_newick_branch: arg 1 not array ref\n";      array_ref( $node1 ) || die "add_to_newick_branch: arg 1 not array ref\n";
2854      array_ref( $node2 ) || die "add_to_newick_branch: arg 2 not array ref\n";      array_ref( $node2 ) || die "add_to_newick_branch: arg 2 not array ref\n";
# Line 2463  Line 2886 
2886  #  #
2887  #  $tree = collapse_zero_length_branches( $tree )  #  $tree = collapse_zero_length_branches( $tree )
2888  #  $tree = collapse_zero_length_branches( $tree, $not_root )  #  $tree = collapse_zero_length_branches( $tree, $not_root )
2889    #
2890  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2891  sub collapse_zero_length_branches {  sub collapse_zero_length_branches
2892    {
2893      my ( $tree, $not_root ) = @_;      my ( $tree, $not_root ) = @_;
2894      array_ref( $tree ) || return undef;      array_ref( $tree ) || return undef;
2895    
# Line 2501  Line 2926 
2926  #  Add a subtree to a newick tree node:  #  Add a subtree to a newick tree node:
2927  #  #
2928  #  $node = newick_insert_at_node( $node, $subtree )  #  $node = newick_insert_at_node( $node, $subtree )
2929    #
2930  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2931  sub newick_insert_at_node  sub newick_insert_at_node
2932  {  {
# Line 2526  Line 2952 
2952  #  Insert a subtree into a newick tree along the path between 2 nodes:  #  Insert a subtree into a newick tree along the path between 2 nodes:
2953  #  #
2954  #  $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )  #  $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
2955    #
2956  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2957  sub newick_insert_between_nodes  sub newick_insert_between_nodes
2958  {  {
# Line 2594  Line 3021 
3021  #  $newtree = prune_from_newick( $tree,  $tip  )  #  $newtree = prune_from_newick( $tree,  $tip  )
3022  #  $newtree = prune_from_newick( $tree,  @tips )  #  $newtree = prune_from_newick( $tree,  @tips )
3023  #  $newtree = prune_from_newick( $tree, \@tips )  #  $newtree = prune_from_newick( $tree, \@tips )
3024    #
3025  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3026  sub prune_from_newick {  sub prune_from_newick
3027    {
3028      my ( $tr, @tips ) = @_;      my ( $tr, @tips ) = @_;
3029      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3030    
# Line 2612  Line 3041 
3041  #  Prune a tip from a tree:  #  Prune a tip from a tree:
3042  #  #
3043  #  $newtree = prune_1_from_newick( $tree, $tip )  #  $newtree = prune_1_from_newick( $tree, $tip )
3044    #
3045  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3046  sub prune_1_from_newick {  sub prune_1_from_newick
3047    {
3048      my ( $tr, $tip ) = @_;      my ( $tr, $tip ) = @_;
3049      my @path = path_to_tip( $tr, $tip );      my @path = path_to_tip( $tr, $tip );
3050      if ( @path < 3 ) { return $tr }      if ( @path < 3 ) { return $tr }
# Line 2673  Line 3104 
3104  #  #
3105  #  $newtree = rooted_newick_subtree( $tree,  @tips )  #  $newtree = rooted_newick_subtree( $tree,  @tips )
3106  #  $newtree = rooted_newick_subtree( $tree, \@tips )  #  $newtree = rooted_newick_subtree( $tree, \@tips )
3107    #
3108  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3109  sub rooted_newick_subtree {  sub rooted_newick_subtree
3110    {
3111      my ( $tr, @tips ) = @_;      my ( $tr, @tips ) = @_;
3112      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3113    
# Line 2694  Line 3127 
3127  #  #
3128  #  $newtree = newick_subtree( $tree,  @tips )  #  $newtree = newick_subtree( $tree,  @tips )
3129  #  $newtree = newick_subtree( $tree, \@tips )  #  $newtree = newick_subtree( $tree, \@tips )
3130    #
3131  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3132  sub newick_subtree {  sub newick_subtree
3133    {
3134      my ( $tr, @tips ) = @_;      my ( $tr, @tips ) = @_;
3135      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }      if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
3136    
# Line 2709  Line 3144 
3144  }  }
3145    
3146    
3147  sub subtree1 {  sub subtree1
3148    {
3149      my ( $tr, $keep ) = @_;      my ( $tr, $keep ) = @_;
3150      my @desc1 = newick_desc_list( $tr );      my @desc1 = newick_desc_list( $tr );
3151    
# Line 2765  Line 3201 
3201  #  #
3202  #    $node = newick_covering_subtree( $tree,  @tips )  #    $node = newick_covering_subtree( $tree,  @tips )
3203  #    $node = newick_covering_subtree( $tree, \@tips )  #    $node = newick_covering_subtree( $tree, \@tips )
3204    #
3205  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3206    
3207  sub newick_covering_subtree {  sub newick_covering_subtree
3208    {
3209      my $tree = shift;      my $tree = shift;
3210      my %tips = map { $_ => 1 } ( ( ref( $_[0] ) eq 'ARRAY' ) ? @{ $_[0] } : @_ );      my %tips = map { $_ => 1 } ( ( ref( $_[0] ) eq 'ARRAY' ) ? @{ $_[0] } : @_ );
3211    
# Line 2777  Line 3215 
3215  }  }
3216    
3217    
3218  sub newick_covering_subtree_1 {  sub newick_covering_subtree_1
3219    {
3220      my ( $node, $tips ) = @_;      my ( $node, $tips ) = @_;
3221      my $n_cover = 0;      my $n_cover = 0;
3222      my @desc = newick_desc_list( $node );      my @desc = newick_desc_list( $node );
# Line 2836  Line 3275 
3275  #   @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )  #   @tips = root_neighborhood_representative_tips( $tree, $n, \%tip_priority )
3276  #  \@tips = root_neighborhood_representative_tips( $tree, $n )  #  \@tips = root_neighborhood_representative_tips( $tree, $n )
3277  #   @tips = root_neighborhood_representative_tips( $tree, $n )  #   @tips = root_neighborhood_representative_tips( $tree, $n )
3278    #
3279  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3280  sub root_neighborhood_representative_tips  sub root_neighborhood_representative_tips
3281  {  {
# Line 2863  Line 3303 
3303  #  #
3304  #   $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )  #   $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n, \%tip_priority )
3305  #   $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )  #   $subtree = tip_neighborhood_representative_tree( $tree, $tip, $n )
3306    #
3307  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3308  sub tip_neighborhood_representative_tree  sub tip_neighborhood_representative_tree
3309  {  {
# Line 2891  Line 3332 
3332  #   @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )  #   @tips = tip_neighborhood_representative_tips( $tree, $tip, $n, \%tip_priority )
3333  #  \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )  #  \@tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
3334  #   @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )  #   @tips = tip_neighborhood_representative_tips( $tree, $tip, $n )
3335    #
3336  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3337  sub tip_neighborhood_representative_tips  sub tip_neighborhood_representative_tips
3338  {  {
# Line 2919  Line 3361 
3361  #  Anonymous hash of the negative distance from root to each tip:  #  Anonymous hash of the negative distance from root to each tip:
3362  #  #
3363  #   \%tip_priority = default_tip_priority( $tree )  #   \%tip_priority = default_tip_priority( $tree )
3364    #
3365  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3366  sub default_tip_priority  sub default_tip_priority
3367  {  {
# Line 2932  Line 3375 
3375  #  Select a tip from a subtree base on a priority value:  #  Select a tip from a subtree base on a priority value:
3376  #  #
3377  #    $tip = representative_tip_of_newick_node( $node, \%tip_priority )  #    $tip = representative_tip_of_newick_node( $node, \%tip_priority )
3378    #
3379  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3380  sub representative_tip_of_newick_node  sub representative_tip_of_newick_node
3381  {  {
# Line 2948  Line 3392 
3392  #  then be reduced to a single tip to make a representative tree:  #  then be reduced to a single tip to make a representative tree:
3393  #  #
3394  #   @subtrees = root_proximal_newick_subtrees( $tree, $n )  #   @subtrees = root_proximal_newick_subtrees( $tree, $n )
3395    #
3396  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3397  sub root_proximal_newick_subtrees  sub root_proximal_newick_subtrees
3398  {  {
# Line 3180  Line 3625 
3625  #  Tree writing and reading  #  Tree writing and reading
3626  #  #
3627  #===============================================================================  #===============================================================================
3628    #
3629  #  writeNewickTree( $tree )  #  writeNewickTree( $tree )
3630  #  writeNewickTree( $tree, $file )  #  writeNewickTree( $tree, $file )
3631  #  writeNewickTree( $tree, \*FH )  #  writeNewickTree( $tree, \*FH )
3632    #
3633  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3634  sub writeNewickTree {  sub writeNewickTree
3635    {
3636      my ( $tree, $file ) = @_;      my ( $tree, $file ) = @_;
3637      my ( $fh, $close ) = open_output( $file );      my ( $fh, $close ) = open_output( $file );
3638      $fh or return;      $fh or return;
# Line 3202  Line 3650 
3650  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3651  #  $treestring = strNewickTree( $tree )  #  $treestring = strNewickTree( $tree )
3652  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
3653  sub strNewickTree {  sub strNewickTree
3654    {
3655      my $node = shift @_;      my $node = shift @_;
3656      strNewickSubtree( $node, "" ) . ";";      strNewickSubtree( $node, "" ) . ";";
3657  }  }
# Line 3211  Line 3660 
3660  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3661  #  $string = strNewickSubtree( $node, $prefix )  #  $string = strNewickSubtree( $node, $prefix )
3662  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3663  sub strNewickSubtree {  sub strNewickSubtree
3664    {
3665      my ( $node, $prefix ) = @_;      my ( $node, $prefix ) = @_;
3666      my  $s;      my  $s;
3667    
# Line 3229  Line 3679 
3679          $prefix = " ";          $prefix = " ";
3680      }      }
3681    
3682      if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {      if ( node_has_lbl( $node ) ) {
3683          $s .= $prefix          $s .= $prefix
3684             .  q_newick_lbl( $node )             .  q_newick_lbl( $node )
3685             .  strNewickComments( newick_c3( $node ), " " );             .  strNewickComments( newick_c3( $node ), " " );
# Line 3249  Line 3699 
3699  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3700  #  $string = strNewickComments( $clist, $prefix )  #  $string = strNewickComments( $clist, $prefix )
3701  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3702  sub strNewickComments {  sub strNewickComments
3703    {
3704      my ( $clist, $prefix ) = @_;      my ( $clist, $prefix ) = @_;
3705      array_ref( $clist ) && ( @$clist > 0 ) || return  "";      array_ref( $clist ) && ( @$clist > 0 ) || return  "";
3706      $prefix . "[" . join( "] [", @$clist ) . "]";      $prefix . "[" . join( "] [", @$clist ) . "]";
# Line 3259  Line 3710 
3710  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3711  #  $quoted_label = q_newick_lbl( $label )  #  $quoted_label = q_newick_lbl( $label )
3712  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3713  sub q_newick_lbl {  sub q_newick_lbl
3714      my $lbl = newick_lbl( $_[0] );  {
3715      defined( $lbl ) && ( $lbl ne "" ) || return undef;      node_has_lbl( $_[0] ) || return undef;
3716    
3717        my $lbl = newick_lbl( $_[0] );
3718      if ( $lbl =~ m/^[^][()_:;,]+$/        #  Anything but []()_:;,      if ( $lbl =~ m/^[^][()_:;,]+$/        #  Anything but []()_:;,
3719        && $lbl !~ m/^'/  ) {               #     and does not start with '        && $lbl !~ m/^'/  ) {               #     and does not start with '
3720          $lbl =~ s/ /_/g;                  #  Recode blanks as _          $lbl =~ s/ /_/g;                  #  Recode blanks as _
# Line 3277  Line 3729 
3729    
3730    
3731  #===============================================================================  #===============================================================================
3732    #
3733  #  $treestring = formatNewickTree( $tree )  #  $treestring = formatNewickTree( $tree )
3734    #
3735  #===============================================================================  #===============================================================================
3736  sub formatNewickTree {  sub formatNewickTree
3737    {
3738      formatNewickSubtree( $_[0], "", "" ) . ";";      formatNewickSubtree( $_[0], "", "" ) . ";";
3739  }  }
3740    
# Line 3287  Line 3742 
3742  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3743  #  $string = formatNewickSubtree( $node, $prefix, $indent )  #  $string = formatNewickSubtree( $node, $prefix, $indent )
3744  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3745  sub formatNewickSubtree {  sub formatNewickSubtree
3746    {
3747      my ( $node, $prefix, $indent ) = @_;      my ( $node, $prefix, $indent ) = @_;
3748      my  $s;      my  $s;
3749    
# Line 3304  Line 3760 
3760          $prefix = " ";          $prefix = " ";
3761      }      }
3762    
3763      if ( defined( newick_lbl( $node ) ) && newick_lbl( $node ) ) {      if ( node_has_lbl( $node ) ) {
3764          $s .= $prefix          $s .= $prefix
3765             .  q_newick_lbl( $node )             .  q_newick_lbl( $node )
3766             .  formatNewickComments( newick_c3( $node ), " ", $indent );             .  formatNewickComments( newick_c3( $node ), " ", $indent );
# Line 3324  Line 3780 
3780  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3781  #  $string = formatNewickComments( $clist, $prefix, $indent )  #  $string = formatNewickComments( $clist, $prefix, $indent )
3782  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3783  sub formatNewickComments {  sub formatNewickComments
3784    {
3785      my ( $clist, $prefix, $indent ) = @_;      my ( $clist, $prefix, $indent ) = @_;
3786      array_ref( $clist ) && @$clist || return  "";      array_ref( $clist ) && @$clist || return  "";
3787      $prefix . "[" . join( "] [", @$clist ) . "]";      $prefix . "[" . join( "] [", @$clist ) . "]";
# Line 3332  Line 3789 
3789    
3790    
3791  #===============================================================================  #===============================================================================
 #  Read to a semicolon  
3792  #  #
3793  #  $tree  = read_newick_tree( )  #  $tree  = read_newick_tree( $file )  # reads to a semicolon
3794  #  $tree  = read_newick_tree( \*FH )  #  @trees = read_newick_trees( $file ) # reads to end of file
3795  #  $tree  = read_newick_tree( $file )  #
 #  
 #  Read to end of file:  
 #  @trees = read_newick_trees( )  
 #  @trees = read_newick_trees( \*FH )  
 #  @trees = read_newick_trees( $file )  
3796  #===============================================================================  #===============================================================================
3797    
3798  sub read_newick_tree  sub read_newick_tree
# Line 3392  Line 3843 
3843  #  Tree reader adapted from the C language reader in fastDNAml  #  Tree reader adapted from the C language reader in fastDNAml
3844  #  #
3845  #  $tree = parse_newick_tree_str( $string )  #  $tree = parse_newick_tree_str( $string )
3846    #
3847  #===============================================================================  #===============================================================================
3848  sub parse_newick_tree_str {  sub parse_newick_tree_str
3849    {
3850      my $s = shift @_;      my $s = shift @_;
3851    
3852      my ( $ind, $rootnode ) = parse_newick_subtree( $s, 0 );      my ( $ind, $rootnode ) = parse_newick_subtree( $s, 0 );
# Line 3405  Line 3858 
3858  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3859  #  Read a subtrees recursively (everything of tree but a semicolon)  #  Read a subtrees recursively (everything of tree but a semicolon)
3860  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3861  sub parse_newick_subtree {  sub parse_newick_subtree
3862    {
3863      my ( $s, $ind ) = @_;      my ( $s, $ind ) = @_;
3864    
3865      my $newnode = [];      my $newnode = [];
# Line 3459  Line 3913 
3913  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3914  #  Read a Newick tree label  #  Read a Newick tree label
3915  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3916  sub parseTreeNodeLabel {  #  Empty string is permitted  sub parseTreeNodeLabel
3917    {  #  Empty string is permitted
3918      my ( $s, $ind ) = @_;      my ( $s, $ind ) = @_;
3919      my ( $lbl, $c );      my ( $lbl, $c );
3920    
# Line 3494  Line 3949 
3949  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3950  #  Read a Newick tree branch length  #  Read a Newick tree branch length
3951  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3952  sub parseBranchLength {  sub parseBranchLength
3953    {
3954      my ( $s, $ind ) = @_;      my ( $s, $ind ) = @_;
3955    
3956      my $c = substr( $s, $ind, 1 );      my $c = substr( $s, $ind, 1 );
# Line 3548  Line 4004 
4004  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4005  #  ( $index, /@commentlist ) = getNextTreeChar( $string, $index )  #  ( $index, /@commentlist ) = getNextTreeChar( $string, $index )
4006  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4007  sub getNextTreeChar {       #  Move to next nonblank, noncomment character  sub getNextTreeChar
4008    {       #  Move to next nonblank, noncomment character
4009      my ( $s, $ind ) = @_;      my ( $s, $ind ) = @_;
4010    
4011      my @clist = ();      my @clist = ();
# Line 3929  Line 4386 
4386    
4387          #  Handle special case of internal node label. Put it between subtrees.          #  Handle special case of internal node label. Put it between subtrees.
4388    
4389          if ( ( $dy >= 2 ) && newick_lbl( $node ) && ( @dl > 1 ) ) {          if ( ( $dy >= 2 ) && node_has_lbl( $node ) && ( @dl > 1 ) ) {
4390              #  Find the descendents $i1 and $i2 to put the branch between              #  Find the descendents $i1 and $i2 to put the branch between
4391              my $i2 = 1;              my $i2 = 1;
4392              while ( ( $i2+1 < @ylist ) && ( $ylist[$i2] < $y ) ) { $i2++ }              while ( ( $i2+1 < @ylist ) && ( $ylist[$i2] < $y ) ) { $i2++ }
# Line 4010  Line 4467 
4467    
4468      my @dl = newick_desc_list( $node );      my @dl = newick_desc_list( $node );
4469    
4470      if ( @dl < 1 ) { push @$line, ( newick_lbl( $node ) || '' ), '' }      if ( @dl < 1 ) {
4471            push @$line, ( node_has_lbl( $node ) ? newick_lbl( $node ) : '' ), '';
4472        }
4473    
4474      else {      else {
4475          my @list = map { [ $_, 'tee_r' ] } @dl;  # Line to the right          my @list = map { [ $_, 'tee_r' ] } @dl;  # Line to the right
# Line 4031  Line 4490 
4490          if ( $row == $y ) {          if ( $row == $y ) {
4491              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'
4492                                                       : $with_left_line{ $line->[$x] };                                                       : $with_left_line{ $line->[$x] };
4493              push( @$line, newick_lbl( $node ), '' ) if $ilbl && newick_lbl( $node );              push @$line, newick_lbl( $node), '' if $ilbl && node_has_lbl( $node );
4494          }          }
4495      }      }
4496    
# Line 4042  Line 4501 
4501  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4502  #  Debug routine  #  Debug routine
4503  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4504  sub dump_tree {  sub dump_tree
4505    {
4506      my ( $node, $prefix ) = @_;      my ( $node, $prefix ) = @_;
4507      defined( $prefix ) or $prefix = "";      defined( $prefix ) or $prefix = "";
4508      print STDERR $prefix, join(", ", @$node), "\n";      print STDERR $prefix, join(", ", @$node), "\n";
# Line 4055  Line 4515 
4515  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4516  #  Debug routine  #  Debug routine
4517  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4518  sub dump_tree_hash {  sub dump_tree_hash
4519    {
4520      my ( $node, $hash, $prefix ) = @_;      my ( $node, $hash, $prefix ) = @_;
4521      defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";      defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
4522      print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";      print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
# Line 4112  Line 4573 
4573  #  Return the common prefix of two lists:  #  Return the common prefix of two lists:
4574  #  #
4575  #  @common = common_prefix( \@list1, \@list2 )  #  @common = common_prefix( \@list1, \@list2 )
4576    #
4577  #-----------------------------------------------------------------------------  #-----------------------------------------------------------------------------
4578  sub common_prefix  sub common_prefix
4579  {  {
# Line 4131  Line 4593 
4593  #  Return the unique suffixes of each of two lists:  #  Return the unique suffixes of each of two lists:
4594  #  #
4595  #  ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )  #  ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )
4596    #
4597  #-----------------------------------------------------------------------------  #-----------------------------------------------------------------------------
4598  sub unique_suffixes  sub unique_suffixes
4599  {  {
# Line 4154  Line 4617 
4617  #  List of values duplicated in a list (stable in order by second occurance):  #  List of values duplicated in a list (stable in order by second occurance):
4618  #  #
4619  #  @dups = duplicates( @list )  #  @dups = duplicates( @list )
4620    #
4621  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
4622  sub duplicates  sub duplicates
4623  {  {
# Line 4166  Line 4630 
4630  #  Randomize the order of a list:  #  Randomize the order of a list:
4631  #  #
4632  #  @random = random_order( @list )  #  @random = random_order( @list )
4633    #
4634  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
4635  sub random_order  sub random_order
4636  {  {
# Line 4184  Line 4649 
4649  #  Intersection of two or more sets:  #  Intersection of two or more sets:
4650  #  #
4651  #  @intersection = intersection( \@set1, \@set2, ... )  #  @intersection = intersection( \@set1, \@set2, ... )
4652    #
4653  #-----------------------------------------------------------------------------  #-----------------------------------------------------------------------------
4654  sub intersection  sub intersection
4655  {  {
# Line 4204  Line 4670 
4670  #  Elements in set 1, but not set 2:  #  Elements in set 1, but not set 2:
4671  #  #
4672  #  @difference = set_difference( \@set1, \@set2 )  #  @difference = set_difference( \@set1, \@set2 )
4673    #
4674  #-----------------------------------------------------------------------------  #-----------------------------------------------------------------------------
4675  sub set_difference  sub set_difference
4676  {  {

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3