[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