Diff of /FigKernelPackages/gjonewicklib.pm

-revision 1.7, Fri Jan 12 23:45:29 2007 UTC
+revision 1.8, Sun Feb 11 18:25:48 2007 UTC
 Line 1
  #
- # Copyright (c) 2003-2006 University of Chicago and Fellowship
+ # Copyright (c) 2003-2007 University of Chicago and Fellowship
  # for Interpretations of Genomes. All Rights Reserved.
  #
  # This file is part of the SEED Toolkit.
 Line 109
  #  set_newick_desc_list( $noderef, @desclist )
  #  set_newick_desc_i( $noderef1, $i, $noderef2)
  #
+ #  $bool    = newick_is_valid( $noderef )       # verify that tree is valid
+ #
  #  $bool    = newick_is_rooted( $noderef )      # 2 branches from root
  #  $bool    = newick_is_unrooted( $noderef )    # 3 or more branches from root
  #  $bool    = newick_is_tip_rooted( $noderef )  # 1 branch from root
-Line 128
+Line 130
  #  ( $tipref,  $xmax ) = newick_most_distant_tip_ref( $noderef )
  #  ( $tipname, $xmax ) = newick_most_distant_tip( $noderef )
  #
+ #  Tree tip insertion point (tip is on branch of length x that
+ #  is inserted into branch connecting node1 and node2, a distance
+ #  x1 from node1 and x2 from node2):
+ #
+ #  [ $node1, $x1, $node2, $x2, $x ]
+ #           = newick_tip_insertion_point( $tree, $tip )
+ #
+ #  Standardized label for a node in terms of intersection of 3 lowest sorting
+ #  tips (sort is lower case):
+ #
+ #  @TipOrTips = std_node_name( $Tree, $Node )
+ #
  #-------------------------------------------------------------------------------
  #  Paths from root of tree:
  #-------------------------------------------------------------------------------
-Line 157
+Line 171
  #  $treecopy = copy_newick_tree( $tree )
  #
  #-------------------------------------------------------------------------------
- #  The following modify the existing tree, and passibly any components of that
+ #  The following modify the existing tree, and possibly any components of that
  #  tree that are reached by reference.  If the old version is still needed, copy
  #  before modifying.
  #-------------------------------------------------------------------------------
-Line 176
+Line 190
  #  $n_changed = newick_fix_negative_branches( $tree )
  #  $node      = newick_rescale_branches( $node, $factor )
  #
+ #  Modify comments:
+ #
+ #  $node = newick_strip_comments( $node )
+ #
  #  Modify rooting and/or order:
  #
  #  $nrmtree = normalize_newick_tree( $tree )
-Line 200
+Line 218
  #
  #  $newtree = collapse_zero_length_branches( $tree )
  #
+ #  $node = newick_insert_at_node( $node, $subtree )
+ #  $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
+ #
  #===============================================================================
  #  Tree reading and writing:
  #===============================================================================
-Line 220
+Line 241
  #===============================================================================
+ use Carp;
+ use Data::Dumper;
  require Exporter;
  our @ISA = qw(Exporter);
-Line 227
+Line 251
          overbeek_to_gjonewick
          gjonewick_to_overbeek
+         newick_is_valid
          newick_is_rooted
          newick_is_unrooted
          tree_rooted_on_tip
-Line 266
+Line 291
          newick_fix_negative_branches
          newick_rescale_branches
+         newick_strip_comments
          normalize_newick_tree
          reverse_newick_tree
          std_unrooted_newick
-Line 287
+Line 314
          newick_subtree
          collapse_zero_length_branches
+         newick_insert_at_node
+         newick_insert_between_nodes
          writeNewickTree
          fwriteNewickTree
          strNewickTree
-Line 399
+Line 429
  #-------------------------------------------------------------------------------
  sub newick_desc_ref { $_[0]->[0] }  # = ${$_[0]}[0]
- sub newick_lbl      { $_[0]->[1] }
+ sub newick_lbl      { ref($_[0]) ? $_[0]->[1] : Carp::confess() }
  sub newick_x        { $_[0]->[2] }
  sub newick_c1       { $_[0]->[3] }
  sub newick_c2       { $_[0]->[4] }
-Line 474
+Line 504
  #===============================================================================
  #  Some tree property tests:
  #===============================================================================
+ #  Tree is valid?
+ #
+ #  $bool = newick_is_valid( $node, $verbose )
+ #-------------------------------------------------------------------------------
+ sub newick_is_valid
+ {
+     my $node = shift;
+     if ( ! array_ref( $node ) )
+     {
+         print STDERR "Node is not array reference\n" if $_[0];
+         return 0;
+     }
+     my @node = @$node;
+     if ( ! @node )
+     {
+         print STDERR "Node is empty array reference\n" if $_[0];
+         return 0;
+     }
+     # Must have descendant or label:
+     if ( ! ( array_ref( $node[0] ) && @{ $node[0] } ) && ! $node[2] )
+     {
+         print STDERR "Node has neither descendant nor label\n" if $_[0];
+         return 0;
+     }
+     #  If comments are present, they must be array references
+     foreach ( ( @node > 3 ) ? @node[ 3 .. $#node ] : () )
+     {
+         if ( defined( $_ ) && ! array_ref( $_ ) )
+         {
+             print STDERR "Node has neither descendant or label\n" if $_[0];
+             return 0;
+         }
+     }
+     #  Inspect the descendants:
+     foreach ( array_ref( $node[0] ) ? @{ $node[0] } : () )
+     {
+         newick_is_valid( $_, @_ ) || return 0
+     }
+     return 1;
+ }
+ #-------------------------------------------------------------------------------
  #  Tree is rooted (2 branches at root node)?
  #
  #  $bool = newick_is_rooted( $node )
-Line 759
+Line 841
  #-------------------------------------------------------------------------------
+ #  Tree tip insertion point (with standard node labels):
+ #
+ #  [ $node1, $x1, $node2, $x2, $x ]
+ #           = newick_tip_insertion_point( $tree, $tip )
+ #
+ #  Which means: tip is on a branch of length x that is inserted into the branch
+ #  connecting node1 and node2, at distance x1 from node1 and x2 from node2.
+ #
+ #                x1    +------ n1a (lowest sorting tip of this subtree)
+ #            +--------n1
+ #            |         +------n1b (lowest sorting tip of this subtree)
+ #  tip-------n
+ #        x   |       +------------- n2a (lowest sorting tip of this subtree)
+ #            +------n2
+ #               x2   +-------- n2b (lowest sorting tip of this subtree)
+ #
+ #  The designations of 1 vs 2, and a vs b are chosen such that:
+ #     n1a < n1b, and n2a < n2b, and n1a < n2a
+ #
+ #  Then the statandard description becomes:
+ #
+ #  [ [ $n1a, min(n1b,n2a), max(n1b,n2a) ], x1,
+ #    [ $n2a, min(n2b,n1a), max(n2b,n1a) ], x2,
+ #    x
+ #  ]
+ #
+ #-------------------------------------------------------------------------------
+ sub newick_tip_insertion_point
+ {
+     my ( $tree, $tip ) = @_;
+     $tree && $tip && ref( $tree ) eq 'ARRAY'    or return undef;
+     $tree = copy_newick_tree( $tree )           or return undef;
+     $tree = reroot_newick_to_tip( $tree, $tip ) or return undef;
+     my $node = $tree;
+     my $x  = 0;                        # Distance to node
+     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
+     $node  = $dl->[0];                 # Node adjacent to tip
+     $dl    = newick_desc_ref( $node );
+     while ( $dl && ( @$dl == 1 ) )     # Traverse unbranched nodes
+     {
+         $node = $dl->[0];
+         $x   += newick_x( $node );
+         $dl   = newick_desc_ref( $node );
+     }
+     $x += newick_x( $node );
+     #  We are now at the node that is the insertion point.
+     #  Is it a tip?
+     my @description;
+     if ( ( ! $dl ) || @$dl == 0 )
+     {
+         @description = ( [ newick_lbl( $node ) ], 0, undef, 0, $x );
+     }
+     #  Is it a trifurcation or greater, in which case it does not go
+     #  away with tip deletion?
+     elsif ( @$dl > 2 )
+     {
+         @description = ( [ std_node_name( $node, $node ) ], 0, undef, 0, $x );
+     }
+     #  The node is bifurcating.  We need to describe it.
+     else
+     {
+         my ( $n1, $x1 ) = describe_desc( $dl->[0] );
+         my ( $n2, $x2 ) = describe_desc( $dl->[1] );
+         if ( @$n1 == 2 ) { push @$n1, $n2->[0] }
+         if ( @$n2 == 2 )
+         {
+             @$n2 = sort { lc $a cmp lc $b } ( @$n2, $n1->[0] );
+         }
+         if ( @$n1 == 3 ) { @$n2 = sort { lc $a cmp lc $b } @$n2 }
+         @description = ( $n1, $x1, $n2, $x2, $x );
+     }
+     return wantarray ? @description : \@description;
+ }
+ sub describe_desc
+ {
+     my $node = shift;
+     my $x  = 0;                        # Distance to node
+     my $dl = newick_desc_ref( $node ); # Descendent list of tip node;
+     while ( $dl && ( @$dl == 1 ) )     # Traverse unbranched nodes
+     {
+         $node = $dl->[0];
+         $x   += newick_x( $node );
+         $dl   = newick_desc_ref( $node );
+     }
+     $x += newick_x( $node );
+     #  Is it a tip?  Return list of one tip;
+     if ( ( ! $dl ) || @$dl == 0 )
+     {
+         return ( [ newick_lbl( $node ) ], $x );
+     }
+     #  Get tips of each descendent, keeping lowest sorting from each.
+     #  Return the two lowest of those (the third will come from the
+     #  other side of the original node).
+     else
+     {
+         my @rep_tips = sort { lc $a cmp lc $b }
+                        map  { ( sort { lc $a cmp lc $b } newick_tip_list( $_ ) )[0] }
+                        @$dl;
+         return ( [ @rep_tips[0,1] ], $x );
+     }
+ }
+ #-------------------------------------------------------------------------------
  #  Standard node name:
  #     Tip label if at a tip
  #     Three sorted tip labels intersecting at node, each being smallest
-Line 781
+Line 984
      #  Work through lists of tips in descendant subtrees, removing them from
      #  @rest, and keeping the best tip for each subtree.
-     my @rest = tips_in_newick( $tree );
+     my @rest = newick_tip_list( $tree );
      my @best = map {
-             my @tips = sort { lc $a cmp lc $b } tips_in_newick( $_ );
+             my @tips = sort { lc $a cmp lc $b } newick_tip_list( $_ );
              @rest = gjolists::set_difference( \@rest, \@tips );
              $tips[0];
          } newick_desc_list( $noderef );
-Line 977
+Line 1180
      array_ref( $node ) && defined( $node1 )
                         && defined( $node2 ) || return undef;
-     my @p1 = path_to_node( $node, $node1 );
+     my @p1 = path_to_node( $node, $node1 ) or return undef;
-     my @p2 = path_to_node( $node, $node2 );
+     my @p2 = path_to_node( $node, $node2 ) or return undef;
-     @p1 && @p2 || return undef;                          # Were they found?
      # Find the unique suffixes of the two paths
      my ( $suf1, $suf2 ) = gjolists::unique_suffixes( \@p1, \@p2 ); # Common node is lost
-Line 1258
+Line 1460
  #-------------------------------------------------------------------------------
+ #  Remove comments from a newick tree (e.g., before writing for phylip).
+ #
+ #  $node = newick_strip_comments( $node )
+ #-------------------------------------------------------------------------------
+ sub newick_strip_comments {
+     my ( $node ) = @_;
+     @$node = @$node[ 0 .. 2 ];
+     foreach ( newick_desc_list( $node ) ) { newick_strip_comments( $_ ) }
+     $node;
+ }
+ #-------------------------------------------------------------------------------
  #  Normalize tree order (in place).
  #
  #  ( $tree, $label1 ) = normalize_newick_tree( $tree )
-Line 1501
+Line 1717
      #
      #      splice( @$dl1, $path1-1, 1 );
      #
-     #  But this maintains the cyclic order of the nodes:
+     #  But the following maintains the cyclic order of the nodes:
      my $dl1 = newick_desc_ref( $node1 );
      my $nd1 = @$dl1;
-Line 1516
+Line 1732
      my $dl2 = newick_desc_ref( $node2 );
      if ( array_ref( $dl2 ) ) { push @$dl2, $node1 }
-     else                     { set_newick_desc_list( $node2, [ $node1 ] ) }
+     else                     { set_newick_desc_list( $node2, $node1 ) }
      #  Move c1 comments from node 1 to node 2:
-Line 1928
+Line 2144
      ( $tree, ( $collapse ? @new_desc : () ) );
  }
+ #-------------------------------------------------------------------------------
+ #  Add a subtree to a newick tree node:
+ #
+ #  $node = newick_insert_at_node( $node, $subtree )
+ #-------------------------------------------------------------------------------
+ sub newick_insert_at_node
+ {
+     my ( $node, $subtree ) = @_;
+     array_ref( $node ) && array_ref( $subtree ) or return undef;
+     #  We could check validity of trees, but ....
+     my $dl = newick_desc_ref( $node );
+     if ( array_ref( $dl ) )
+     {
+         push @$dl, $subtree;
+     }
+     else
+     {
+         set_newick_desc_ref( $node, [ $subtree ] );
+     }
+     return $node;
+ }
+ #-------------------------------------------------------------------------------
+ #  Insert a subtree into a newick tree along the path between 2 nodes:
+ #
+ #  $tree = newick_insert_between_nodes( $tree, $subtree, $node1, $node2, $fraction )
+ #-------------------------------------------------------------------------------
+ sub newick_insert_between_nodes
+ {
+     my ( $tree, $subtree, $node1, $node2, $fraction ) = @_;
+     array_ref( $tree ) && array_ref( $subtree ) or return undef;
+     $fraction >= 0 && $fraction <= 1 or return undef;
+     #  Find the paths to the nodes:
+     my @path1 = path_to_node( $tree, $node1 ) or return undef;
+     my @path2 = path_to_node( $tree, $node2 ) or return undef;
+     #  Trim the common prefix:
+     while ( $path1[1] == $path2[1] )
+     {
+         splice( @path1, 0, 2 );
+         splice( @path2, 0, 2 );
+     }
+     my ( @path, $dist );
+     if    ( @path1 < 3 )
+     {
+         @path2 >= 3 or return undef;              # node1 = node2
+         $dist = $fraction* newick_path_length( @path2 );
+         @path = @path2;
+     }
+     elsif ( @path2 < 3 )
+     {
+         $dist = ( 1 - $fraction ) * newick_path_length( @path1 );
+         @path = @path1;
+     }
+     else
+     {
+         my $dist1 = newick_path_length( @path1 );
+         my $dist2 = newick_path_length( @path2 );
+         $dist = $fraction * ( $dist1 + $dist2 ) - $dist1;
+         @path = ( $dist <= 0 ) ? @path1 : @path2;
+         $dist = abs( $dist );
+     }
+     #  Descend tree until we reach the insertion branch:
+     my $x;
+     while ( ( $dist > ( $x = newick_x( $path[2] ) ) ) && ( @path > 3 ) )
+     {
+         $dist -= $x;
+         splice( @path, 0, 2 );
+     }
+     #  Insert the new node:
+     set_newick_desc_i( $path[0], $path[1], [ [ $path[2], $subtree ], undef, $dist ] );
+     set_newick_x( $path[2], ( ( $x > $dist ) ? ( $x - $dist ) : 0 ) );
+     return $tree;
+ }
  #-------------------------------------------------------------------------------
  #  Prune one or more tips from a tree:

 Legend:



Removed from v.1.7
 


changed lines


 
Added in v.1.8
 Legend:



Removed from v.1.7
 


changed lines


 
Added in v.1.8
-Removed from v.1.7
+Added in v.1.8

MCS Webmaster	ViewVC Help
Powered by ViewVC 1.0.3