[Bioperl-guts-l] [15615] bioperl-live/trunk: [bug 2456]

Christopher John Fields cjfields at dev.open-bio.org
Fri Mar 27 17:08:59 EDT 2009


Revision: 15615
Author:   cjfields
Date:     2009-03-27 17:08:59 -0400 (Fri, 27 Mar 2009)

Log Message:
-----------
[bug 2456]
* Mark's patches
* See archived examples of trees with the bug report for confirmation of test data changes

Modified Paths:
--------------
    bioperl-live/trunk/Bio/Tree/Node.pm
    bioperl-live/trunk/Bio/Tree/TreeFunctionsI.pm
    bioperl-live/trunk/t/Tree/Tree.t
    bioperl-live/trunk/t/Tree/TreeIO/lintree.t
    bioperl-live/trunk/t/Tree/TreeIO/tabtree.t
    bioperl-live/trunk/t/Tree/TreeIO.t

Modified: bioperl-live/trunk/Bio/Tree/Node.pm
===================================================================
--- bioperl-live/trunk/Bio/Tree/Node.pm	2009-03-27 20:30:06 UTC (rev 15614)
+++ bioperl-live/trunk/Bio/Tree/Node.pm	2009-03-27 21:08:59 UTC (rev 15615)
@@ -148,6 +148,65 @@
   return $self;
 }
 
+=head2 create_node_on_branch
+
+ Title   : create_node_on_branch
+ Usage   : $node->create_node_on_branch($at_length)
+ Function: Create a node on the ancestral branch of the calling
+           object. 
+ Example :
+ Returns : the created node
+ Args    : -POSITION=>$absolute_branch_length_from_caller (default)
+           -FRACTION=>$fraction_of_branch_length_from_caller
+           -ANNOT=>{ -id => "the id", -desc => "the description" }
+           -FORCE, set to allow nodes with zero branch lengths
+
+=cut
+
+sub create_node_on_branch{
+   my ($self, at args) = @_;
+   my ($pos, $frac, $annot, $force) = $self->_rearrange([qw(POSITION FRACTION ANNOT FORCE)], @args);
+   my ($newpos);
+   my $blen = $self->branch_length;
+   # arg checks
+   $force||=0;
+   $annot||={};
+
+   unless ($self->ancestor) {
+       $self->throw("Refusing to create nodes above the root--exiting");
+   }
+   unless ($blen) {
+       $self->throw("Calling node's branch length is zero") unless $force;
+   }
+   unless ((defined $pos && !defined $frac)||(defined $frac && !defined $pos)) {
+       $self->throw("Either position or fraction must be specified, but not both");
+   }
+   if (defined $frac) {
+       $self->throw("FRACTION arg must be in the range [0,1]") unless ( (0 <= $frac) && ($frac <= 1) );
+       $newpos = $frac*$blen;
+   }
+   elsif (defined $pos) {
+       $self->throw("POSITION arg must be in the range [0,$blen]") unless ( (0 <= $pos) && ($pos <= $blen) );
+       $newpos = $pos;
+   }
+   else {
+       $self->throw("How did I get here?");
+   }
+   $self->throw("Calling node's branch length will be zero (set -FORCE to force)--exiting") unless ($newpos > 0) || $force;
+   $self->throw("Created nodes branch length would be zero (set -FORCE to force)--exiting") unless ($newpos < $blen) || $force;
+
+   #guts
+   $annot->{'-branch_length'} = $blen-$newpos;
+   my $node = Bio::Tree::Node->new(%$annot);
+   my $anc = $self->ancestor;
+   # null anc check is above
+   $node->add_Descendent($self);
+   $anc->add_Descendent($node);
+   $anc->remove_Descendent($self);
+   $self->branch_length($newpos);
+   return $node;
+}
+
 =head2 add_Descendent
 
  Title   : add_Descendent
@@ -281,7 +340,6 @@
 	   }
        }
    }
-
    $c;
 }
 

Modified: bioperl-live/trunk/Bio/Tree/TreeFunctionsI.pm
===================================================================
--- bioperl-live/trunk/Bio/Tree/TreeFunctionsI.pm	2009-03-27 20:30:06 UTC (rev 15614)
+++ bioperl-live/trunk/Bio/Tree/TreeFunctionsI.pm	2009-03-27 21:08:59 UTC (rev 15615)
@@ -939,33 +939,21 @@
         return 0;
     }
 
-    {
+	my $old_root = $self->get_root_node;
+	if( $new_root == $old_root ) {
+	    $self->warn("Node requested for reroot is already the root node!");
+	    return 0;
+	}
         my $anc = $new_root->ancestor;
         unless( $anc ) {
-            return 0;
+	    # this is already the root
+	    $self->warn("Node requested for reroot is already the root node!");            return 0;
         }
-        my $blen;
-        if( $new_root->is_Leaf() ) {
-            $blen = $new_root->branch_length;
-        } else {
-            $blen = ($new_root->branch_length() || 0) / 2;
-        }
-        my $node = $anc->new(-branch_length => $blen);
-        $new_root->branch_length($blen);
-        $anc->add_Descendent($node);
-        $anc->remove_Descendent($new_root);
-        $node->add_Descendent($new_root);
-        $new_root = $node;
-    }
+        my $tmp_node = $new_root->create_node_on_branch(-position=>0,-force=>1);
 
-    my $old_root = $self->get_root_node;
-    if( $new_root == $old_root ) {
-        $self->warn("Node requested for reroot is already the root node!");
-        return 0;
-    }
-
     # reverse the ancestor & children pointers
-    my @path_from_oldroot = ($self->get_lineage_nodes($new_root), $new_root);
+    my $former_anc = $tmp_node->ancestor;
+    my @path_from_oldroot = ($self->get_lineage_nodes($tmp_node), $tmp_node);
     for (my $i = 0; $i < @path_from_oldroot - 1; $i++) {
         my $current = $path_from_oldroot[$i];
         my $next = $path_from_oldroot[$i + 1];
@@ -973,16 +961,12 @@
         $current->branch_length($next->branch_length);
         $next->add_Descendent($current);
     }
-    # root node can be an artifical node which needs to be removed here
-    # when we are re-rooting.  We can only get its ancestor
-    # after we've reversed the path
-    my $anc = $old_root->ancestor;
-    my @d = $old_root->each_Descendent;
-    if( @d == 1 ) {
-    	$anc->add_Descendent(shift @d);
-        $anc->remove_Descendent($old_root);
-    }
+
+    $new_root->add_Descendent($former_anc);
+    $tmp_node->remove_Descendent($former_anc);
+    $tmp_node = undef;
     $new_root->branch_length(undef);
+
     $old_root = undef;
     $self->set_root_node($new_root);
 
@@ -1082,7 +1066,6 @@
     return $traits;
 }
 
-
 sub add_trait {
     my $self = shift;
     my $file = shift;

Modified: bioperl-live/trunk/t/Tree/Tree.t
===================================================================
--- bioperl-live/trunk/t/Tree/Tree.t	2009-03-27 20:30:06 UTC (rev 15614)
+++ bioperl-live/trunk/t/Tree/Tree.t	2009-03-27 21:08:59 UTC (rev 15615)
@@ -7,8 +7,8 @@
     use lib '.';
     use Bio::Root::Test;
     
-    test_begin(-tests => 60);
-	
+#/maj    test_begin(-tests => 60);
+    test_begin(-tests => 62);	
     use_ok('Bio::TreeIO');
 }
 
@@ -152,26 +152,45 @@
 warn("new  total len ", $tree->total_branch_length,"\n") if $verbose;
 # according to retree in phylip these branch lengths actually get larger
 # go figure...
-#ok(($total_length_orig >= $tree->total_branch_length - $eps)
-#   and ($total_length_orig <= $tree->total_branch_length + $eps));
+# this should be fixed now/maj
+ok(($total_length_orig >= $tree->total_branch_length - $eps) &&
+   ($total_length_orig <= $tree->total_branch_length + $eps),'same length');
+
+# prob with below: rerooted tree on node A at line 146; so $a IS root
+#/maj is($tree->get_root_node, $a->ancestor, "Root node is A's ancestor");
+is($tree->get_root_node, $a, "Root node is A");
+
+# former test expected the old behavior of reroot; here is the new
+# test/maj
+my $desc = ($a->each_Descendent)[0];
+my $newroot = $desc->create_node_on_branch(-FRACTION=>0.5, -ANNOT=>{id=>'newroot'});
+$tree->reroot($newroot);
 is($tree->get_root_node, $a->ancestor, "Root node is A's ancestor");
 
 # try to reroot on an internal, will result in there being 1 less node
+# Rerooting should be an invariant operation with respect to node number!/maj
+# the test show that it now is, because the secret removal of nodes 
+# no longer occurs
+
 $a = $tree->find_node('C')->ancestor;
 $out->write_tree($tree) if $verbose;
 is($tree->reroot($a),1, "Can reroot with C's ancsestor");
 $out->write_tree($tree) if $verbose;
-is($node_cnt_orig, scalar($tree->get_nodes), 'Check to see that node count is correct after an internal node was removed after this re-rooting');
+#/maj is($node_cnt_orig, scalar($tree->get_nodes), 'Check to see that node count is correct after an internal node was removed after this re-rooting');
+# but we did add a new node at line 166, so
+is($node_cnt_orig+1, scalar($tree->get_nodes), 'Node count correct');
 warn("orig total len ", $total_length_orig, "\n") if $verbose;
 warn("new  total len ", $tree->total_branch_length,"\n") if $verbose;
 cmp_ok($total_length_orig, '>=', $tree->total_branch_length - $eps, 
        'Total original branch length is what it is supposed to be');
+# branch length should also be invariant w/r to rerooting...
 cmp_ok($total_length_orig, '<=',$tree->total_branch_length + $eps, 
        'Updated total branch length after the reroot');
-is($tree->get_root_node, $a->ancestor, 'Make sure root is really what we asked for');
+# again, we rerooted ON THE NODE, so $a IS the root./maj
+is($tree->get_root_node, $a, 'Make sure root is really what we asked for');
 
-# try to reroot on existing root: should fail
-$a = $tree->get_root_node;
+# try to reroot on new root: should fail
+#/maj  $a = $tree->get_root_node;
 isnt( $tree->reroot($a),1, 'Testing for failed re-rerooting');
 
 # try a more realistic tree
@@ -180,15 +199,16 @@
 $node_cnt_orig = scalar($tree->get_nodes);
 $total_length_orig = $tree->total_branch_length;
 $out->write_tree($tree) if $verbose;
-is($tree->reroot($a->ancestor),1, 'Test that rooting succeeded');
+is($tree->reroot($a),1, 'Test that rooting succeeded'); #mod /maj
 $out->write_tree($tree) if $verbose;
-is($node_cnt_orig+1, scalar($tree->get_nodes), 'Test that re-rooted tree has proper number of nodes after re-rooting');
+# node number should be invariant after reroot/maj
+is($node_cnt_orig, scalar($tree->get_nodes), 'Test that re-rooted tree has proper number of nodes after re-rooting'); #mod /maj
 $total_length_new = $tree->total_branch_length;
 $eps = 0.001 * $total_length_new;    # tolerance for checking length
 cmp_ok($total_length_orig, '>=', $tree->total_branch_length - $eps, 'Branch length before rerooting');
 cmp_ok($total_length_orig, '<=', $tree->total_branch_length + $eps, 
        'Branch length after rerooting');
-is($tree->get_root_node, $a->ancestor->ancestor,'Root is really the ancestor we asked for');
+is($tree->get_root_node, $a,'Root is really the ancestor we asked for'); #mod /maj
 
 # BFS and DFS search testing
 $treeio = Bio::TreeIO->new(-verbose => $verbose,
@@ -224,7 +244,10 @@
 is($DFSorder, '0,1,2,A,B,C,D,3,E,F', 'DFS traversal after removing G');
 $tree->splice(-remove_id => [('E', 'F')], -keep_id => 'F');
 $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
-is($DFSorder, '0,1,2,A,B,C,D,F', 'DFS traversal after removing F');
+# the node '3' is not explicitly removed, so it should still be there
+# I suspect that it disappeared before was due to the previously
+# automatic removal of internal degree 2 nodes../maj

@@ Diff output truncated at 10000 characters. @@



More information about the Bioperl-guts-l mailing list