1 # -*-Perl-*- Test Harness script for Bioperl
9 test_begin(-tests => 66);
10 use_ok('Bio::TreeIO');
13 my $verbose = test_debug();
15 my $treeio = Bio::TreeIO->new(-verbose => $verbose,
17 -file => test_input_file('test.nhx'));
18 my $tree = $treeio->next_tree;
21 ok ! $tree->has_tag('test');
22 is $tree->add_tag_value('test','a'), 1;
23 ok $tree->has_tag('test');
24 is $tree->add_tag_value('test','b'), 2;
25 my @tags = $tree->get_tag_values('test');
27 is scalar $tree->get_tag_values('test'), 'a', 'retrieve the first value';
28 is $tree->remove_tag('test2'), 0;
29 is $tree->remove_tag('test'), 1;
30 ok ! $tree->has_tag('test');
31 is $tree->set_tag_value('test',('a','b','c')), 3;
32 is $tree->remove_all_tags(), undef;
33 ok ! $tree->has_tag('test');
36 my @nodes = $tree->find_node('ADH2');
37 is(@nodes, 2,'Number of nodes that have ADH2 as name');
40 $treeio = Bio::TreeIO->new(-verbose => $verbose,
43 $treeio->write_tree($tree);
44 print "nodes are: \n",
45 join(", ", map { $_->id . ":". (defined $_->branch_length ?
46 $_->branch_length : '' ) } @nodes), "\n";
49 $treeio = Bio::TreeIO->new(-format => 'newick',
50 -file => test_input_file('test.nh'));
51 $tree = $treeio->next_tree;
55 my $out = Bio::TreeIO->new(-format => 'tabtree');
57 $out->write_tree($tree);
60 my @hADH = ( $tree->find_node('hADH1'),
61 $tree->find_node('hADH2') );
62 my ($n4) = $tree->find_node('yADH4');
64 is($tree->is_monophyletic(-nodes => \@hADH,
65 -outgroup => $n4),1,'Test Monophyly');
67 my @mixgroup = ( $tree->find_node('hADH1'),
68 $tree->find_node('yADH2'),
69 $tree->find_node('yADH3'),
72 my ($iADHX) = $tree->find_node('iADHX');
75 is($iADHX->height, 0,'Height');
76 is($iADHX->depth,0.22,'Depth');
77 isnt( $tree->is_monophyletic(-nodes => \@mixgroup,
78 -outgroup=> $iADHX),1, 'non-monophyletic group');
81 is $tree->is_binary, 0, 'not a binary tree';
82 is scalar $tree->get_nodes, 12, '12 nodes';
85 is $tree->is_binary, 1, 'after force_binary() it is';
86 is scalar $tree->get_nodes, 17, 'and there are more nodes (17)';
88 my $in = Bio::TreeIO->new(-format => 'newick',
90 $tree = $in->next_tree;
91 my ($a,$b,$c,$d) = ( $tree->find_node('A'),
92 $tree->find_node('B'),
93 $tree->find_node('C'),
94 $tree->find_node('D'));
96 is($tree->is_monophyletic(-nodes => [$b,$c],
97 -outgroup => $d),1, 'B,C are Monophyletic');
99 is($tree->is_monophyletic(-nodes => [$b,$a],
100 -outgroup => $d),1,'A,B are Monophyletic');
102 $tree = $in->next_tree;
104 ($a,$b,$c,$d,$e,$f,$i) = ( $tree->find_node('A'),
105 $tree->find_node('B'),
106 $tree->find_node('C'),
107 $tree->find_node('D'),
108 $tree->find_node('E'),
109 $tree->find_node('F'),
110 $tree->find_node('I'),
112 isnt( $tree->is_monophyletic(-nodes => [$b,$f],
113 -outgroup => $d),1,'B,F are not Monophyletic' );
115 is($tree->is_monophyletic(-nodes => [$b,$a],
116 -outgroup => $f),1, 'A,B are Monophyletic');
120 isnt( $tree->is_paraphyletic(-nodes => [$a,$b,$c],
121 -outgroup => $d), 1,'A,B,C are not Monophyletic w D as outgroup');
123 is( $tree->is_paraphyletic(-nodes => [$a,$f,$e],
124 -outgroup => $i), 1, 'A,F,E are monophyletic with I as outgroup');
127 # test for rerooting the tree
128 my $out = Bio::TreeIO->new(-format => 'newick',
131 $tree = $in->next_tree;
132 $tree->verbose( -1 ) unless $verbose;
133 my $node_cnt_orig = scalar($tree->get_nodes);
134 # reroot on an internal node: should work fine
135 $a = $tree->find_node('A');
136 # removing node_count checks because re-rooting can change the
137 # number of internal nodes (if it is done correctly)
138 my $total_length_orig = $tree->total_branch_length;
139 is $tree->total_branch_length, $tree->subtree_length,
140 "subtree_length() without attributes is an alias to total_branch_lenght()";
141 cmp_ok($total_length_orig, '>',$tree->subtree_length($a->ancestor),
142 'Length of the tree is larger that lenght of a subtree');
143 $out->write_tree($tree) if $verbose;
144 is($tree->reroot($a),1, 'Can re-root with A as outgroup');
145 $out->write_tree($tree) if $verbose;
146 is($node_cnt_orig, scalar($tree->get_nodes), 'Count the number of nodes');
147 my $total_length_new = $tree->total_branch_length;
148 my $eps = 0.001 * $total_length_new; # tolerance for checking length
149 warn("orig total len ", $total_length_orig, "\n") if $verbose;
150 warn("new total len ", $tree->total_branch_length,"\n") if $verbose;
151 # according to retree in phylip these branch lengths actually get larger
153 # this should be fixed now/maj
154 ok(($total_length_orig >= $tree->total_branch_length - $eps) &&
155 ($total_length_orig <= $tree->total_branch_length + $eps),'same length');
157 # prob with below: rerooted tree on node A at line 146; so $a IS root
158 #/maj is($tree->get_root_node, $a->ancestor, "Root node is A's ancestor");
159 is($tree->get_root_node, $a, "Root node is A");
161 # former test expected the old behavior of reroot; here is the new
163 my $desc = ($a->each_Descendent)[0];
164 my $newroot = $desc->create_node_on_branch(-FRACTION=>0.5, -ANNOT=>{-id=>'newroot'});
165 $tree->reroot($newroot);
166 is($tree->get_root_node, $a->ancestor, "Root node is A's ancestor");
168 # try to reroot on an internal, will result in there being 1 less node
169 # Rerooting should be an invariant operation with respect to node number!/maj
170 # the test show that it now is, because the secret removal of nodes
173 $a = $tree->find_node('C')->ancestor;
174 $out->write_tree($tree) if $verbose;
175 is($tree->reroot($a),1, "Can reroot with C's ancsestor");
176 $out->write_tree($tree) if $verbose;
177 #/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');
178 # but we did add a new node at line 166, so
179 is($node_cnt_orig+1, scalar($tree->get_nodes), 'Node count correct');
180 warn("orig total len ", $total_length_orig, "\n") if $verbose;
181 warn("new total len ", $tree->total_branch_length,"\n") if $verbose;
182 cmp_ok($total_length_orig, '>=', $tree->total_branch_length - $eps,
183 'Total original branch length is what it is supposed to be');
184 # branch length should also be invariant w/r to rerooting...
185 cmp_ok($total_length_orig, '<=',$tree->total_branch_length + $eps,
186 'Updated total branch length after the reroot');
187 # again, we rerooted ON THE NODE, so $a IS the root./maj
188 is($tree->get_root_node, $a, 'Make sure root is really what we asked for');
190 # try to reroot on new root: should fail
191 #/maj $a = $tree->get_root_node;
192 isnt( $tree->reroot($a),1, 'Testing for failed re-rerooting');
194 # try a more realistic tree
195 $tree = $in->next_tree;
196 $a = $tree->find_node('VV');
197 $node_cnt_orig = scalar($tree->get_nodes);
198 $total_length_orig = $tree->total_branch_length;
199 $out->write_tree($tree) if $verbose;
200 is($tree->reroot($a),1, 'Test that rooting succeeded'); #mod /maj
201 $out->write_tree($tree) if $verbose;
202 # node number should be invariant after reroot/maj
203 is($node_cnt_orig, scalar($tree->get_nodes), 'Test that re-rooted tree has proper number of nodes after re-rooting'); #mod /maj
204 $total_length_new = $tree->total_branch_length;
205 $eps = 0.001 * $total_length_new; # tolerance for checking length
206 cmp_ok($total_length_orig, '>=', $tree->total_branch_length - $eps, 'Branch length before rerooting');
207 cmp_ok($total_length_orig, '<=', $tree->total_branch_length + $eps,
208 'Branch length after rerooting');
209 is($tree->get_root_node, $a,'Root is really the ancestor we asked for'); #mod /maj
211 # BFS and DFS search testing
212 $treeio = Bio::TreeIO->new(-verbose => $verbose,
214 -file => test_input_file('test.nh'));
215 $tree = $treeio->next_tree;
218 for $n ( $tree->get_leaf_nodes ) {
222 for $n ( grep {! $_->is_Leaf } $tree->get_nodes ) {
225 # enable for debugging
226 Bio::TreeIO->new(-format => 'newick')->write_tree($tree) if( $verbose );
228 my $BFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'b')));
229 is($BFSorder, '0,1,3,2,C,D,E,F,G,H,A,B', 'BFS traversal order');
230 my $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
231 is($DFSorder, '0,1,2,A,B,C,D,3,E,F,G,H', 'DFS travfersal order');
234 # test some Bio::Tree::TreeFunctionI methods
235 #find_node tested extensively already
236 $tree->remove_Node('H');
237 $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
238 is($DFSorder, '0,1,2,A,B,C,D,3,E,F,G', 'DFS traversal after removing H');
239 $tree->splice(-remove_id => 'G');
240 $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
241 is($DFSorder, '0,1,2,A,B,C,D,3,E,F', 'DFS traversal after removing G');
242 $tree->splice(-remove_id => [('E', 'F')], -keep_id => 'F');
243 $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
244 # the node '3' is not explicitly removed, so it should still be there
245 # I suspect that it disappeared before was due to the previously
246 # automatic removal of internal degree 2 nodes../maj
247 is($DFSorder, '0,1,2,A,B,C,D,3,F', 'DFS traversal after removing E');
248 $tree->splice(-keep_id => [qw(0 1 2 A B C D)]);
249 $DFSorder = join(",", map { $_->id } ( $tree->get_nodes(-order => 'd')));
250 is($DFSorder, '0,1,2,A,B,C,D', 'DFS after removing all but 0,1,2,A,B,C,D');
251 #get_lineage_nodes, get_lineage_string, get_lca, merge_lineage, contract_linear_paths tested in Taxonomy.t
254 # try out the id to bootstrap copy method
255 $treeio = Bio::TreeIO->new(-format => 'newick',
256 -file => test_input_file('bootstrap.tre'));
257 $tree = $treeio->next_tree;
258 my ($test_node) = $tree->find_node(-id => 'A');
259 is($test_node->ancestor->id, 90,'Testing bootstrap copy');
260 is($test_node->ancestor->ancestor->id, '25','Testing bootstrap copy');
261 is($test_node->ancestor->ancestor->ancestor->id, '0','Testing bootstrap copy');
262 $tree->move_id_to_bootstrap;
263 is($test_node->ancestor->id, '','Testing bootstrap copy');
264 is($test_node->ancestor->bootstrap, '90', 'Testing bootstrap copy');
265 is($test_node->ancestor->ancestor->id, '', 'Testing bootstrap copy');
266 is($test_node->ancestor->ancestor->bootstrap, '25', 'Testing bootstrap copy');
267 is($test_node->ancestor->ancestor->ancestor->bootstrap, '0','Testing bootstrap copy');
269 # change TreeIO to parse
270 $treeio = Bio::TreeIO->new(-format => 'newick',
271 -file => test_input_file('bootstrap.tre'),
272 -internal_node_id => 'bootstrap');
273 $tree = $treeio->next_tree;
274 ($test_node) = $tree->find_node(-id => 'A');
275 is($test_node->ancestor->id, '','Testing auto-boostrap copy during parse');
276 is($test_node->ancestor->ancestor->id, '',
277 'Testing auto-boostrap copy during parse');
278 is($test_node->ancestor->bootstrap, '90',
279 'Testing auto-boostrap copy during parse');
280 is($test_node->ancestor->ancestor->bootstrap, '25',
281 'Testing auto-boostrap copy during parse');
283 # return an empty array when no nodes are found
284 ok $tree = Bio::Tree::Tree->new();
285 @nodes = $tree->get_nodes;
291 (I,((D,(C,(A,B)x)y),(E,(F,G))));
292 (((A:0.3,B:2.1):0.45,C:0.7),D:4);
293 (A:0.031162,((((((B:0.022910,C:0.002796):0.010713,(D:0.015277,E:0.020484):0.005336):0.005588,((F:0.013293,(G:0.018374,H:0.003108):0.005318):0.006047,I:0.014607):0.001677):0.004196,(((((J:0.003307,K:0.001523):0.011884,L:0.006960):0.006514,((M:0.001683,N:0.000100):0.002226,O:0.007085):0.014649):0.008004,P:0.037422):0.005201,(Q:0.000805,R:0.000100):0.015280):0.005736):0.004612,S:0.042283):0.017979,(T:0.006883,U:0.016655):0.040226):0.014239,((((((V:0.000726,W:0.000100):0.028490,((((X:0.011182,Y:0.001407):0.005293,Z:0.011175):0.004701,AA:0.007825):0.016256,BB:0.029618):0.008146):0.004279,CC:0.035012):0.060215,((((((DD:0.014933,(EE:0.008148,FF:0.000100):0.015458):0.003891,GG:0.010996):0.001489,(HH:0.000100,II:0.000100):0.054265):0.003253,JJ:0.019722):0.013796,((KK:0.001960,LL:0.004924):0.013034,MM:0.010071):0.043273):0.011912,(NN:0.031543,OO:0.018307):0.059182):0.026517):0.011087,((PP:0.000100,QQ:0.002916):0.067214,(RR:0.064486,SS:0.013444):0.011613):0.050846):0.015644,((TT:0.000100,UU:0.009287):0.072710,(VV:0.009242,WW:0.009690):0.035346):0.042993):0.060365);