t/Tree/Node.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2 # $Id$
   3
   4 use strict;
   5
   6 BEGIN {
   7   use lib '.';
   8   use Bio::Root::Test;
   9   use File::Temp qw(tempfile);
  10   test_begin( -tests => 40 );
  11   use_ok('Bio::Tree::Node');
  12   use_ok('Bio::Tree::AlleleNode');
  13   use_ok('Bio::TreeIO');
  14 }
  15
  16 my $node1 = Bio::Tree::Node->new();
  17 my $node2 = Bio::Tree::Node->new();
  18 ok( $node1->is_Leaf() );
  19 is( $node1->ancestor, undef );
  20
  21 # tests for tags
  22 ok !$node1->has_tag('test');
  23 is $node1->add_tag_value( 'test', 'a' ), 1;
  24 ok $node1->has_tag('test');
  25 is $node1->add_tag_value( 'test', 'b' ), 2;
  26 my @tags = $node1->get_tag_values('test');
  27 is scalar @tags, 2;
  28 is scalar $node1->get_tag_values('test'), 'a', 'retrieve the first value';
  29
  30 is $node1->remove_tag('test2'), 0;
  31 is $node1->remove_tag('test'),  1;
  32 ok !$node1->has_tag('test');
  33 is $node1->set_tag_value( 'test', ( 'a', 'b', 'c' ) ), 3;
  34 is $node1->remove_all_tags(), undef;
  35 ok !$node1->has_tag('test');
  36
  37 my $pnode = Bio::Tree::Node->new();
  38 $pnode->add_Descendent($node1);
  39 is( $node1->ancestor, $pnode );
  40 $pnode->add_Descendent($node2);
  41 is( $node2->ancestor, $pnode );
  42
  43 ok( !$pnode->is_Leaf );
  44
  45 my $phylo_node = Bio::Tree::Node->new(
  46   -bootstrap => 0.25,
  47   -id        => 'ADH_BOV',
  48   -desc      => 'Taxon 1'
  49 );
  50 $node1->add_Descendent($phylo_node);
  51 ok( !$node1->is_Leaf );
  52 is( $phylo_node->ancestor,    $node1 );
  53 is( $phylo_node->id,          'ADH_BOV' );
  54 is( $phylo_node->bootstrap,   0.25 );
  55 is( $phylo_node->description, 'Taxon 1' );
  56
  57 is $phylo_node->ancestor($node2), $node2;
  58 ok $node1->is_Leaf;
  59 is my @descs = $node2->each_Descendent, 1;
  60 is $descs[0], $phylo_node;
  61
  62 my $allele_node = Bio::Tree::AlleleNode->new();
  63 $allele_node->add_Genotype(
  64   Bio::PopGen::Genotype->new(
  65     -marker_name => 'm1',
  66     -alleles     => [0]
  67   )
  68 );
  69 $allele_node->add_Genotype(
  70   Bio::PopGen::Genotype->new(
  71     -marker_name => 'm3',
  72     -alleles     => [ 1, 1 ]
  73   )
  74 );
  75 $allele_node->add_Genotype(
  76   Bio::PopGen::Genotype->new(
  77     -marker_name => 'm4',
  78     -alleles     => [ 0, 4 ]
  79   )
  80 );
  81 ok($allele_node);
  82 my @mkrs = $allele_node->get_marker_names;
  83
  84 is( @mkrs, 3 );
  85 my ($m3) = $allele_node->get_Genotypes( -marker => 'm3' );
  86 is( $m3->get_Alleles, 2 );
  87 my ($a1) = $allele_node->get_Genotypes( -marker => 'm1' )->get_Alleles;
  88 is( $a1, 0 );
  89
  90 my ( $a2, $a3 ) = $allele_node->get_Genotypes( -marker => 'm4' )->get_Alleles;
  91 is( $a2, 0 );
  92 is( $a3, 4 );
  93
  94 # bug 2877
  95 my $str = "(A:52,(B:46,C:50):11,D:70)68";
  96 my $in = Bio::TreeIO->new(
  97   -internal_node_id => 'bootstrap',
  98   -format => 'nhx',
  99   -string => $str,
 100 );
 101 my $t = $in->next_tree;
 102   my $s;
 103   my $old_root = $t->get_root_node();
 104   my ($b) = $t->find_node( -id => "B" );
 105   my $b_anc = $b->ancestor;
 106
 107   my $r = $b->create_node_on_branch( -FRACTION => 0.5 );
 108   $r->id('fake');
 109
 110   # before reroot
 111   is( $t->as_text('newick',$in->params), "(A:52,(C:50,(B:23)fake:23):11,D:70)68;", 'with fake node' );
 112
 113   # after reroot
 114   $t->reroot($r);
 115   is( $t->as_text('newick',$in->params), "(B:23,(C:50,(A:52,D:70)68:11):23)fake;",
 116     "after reroot on fake node" );
 117   $t->reroot($b);
 118
 119   is( $t->as_text('newick',$in->params), "(((C:50,(A:52,D:70)68:11):23)fake:23)B;", "reroot on B" );
 120
 121   $t->reroot($b_anc);
 122   $t->splice( -remove_id => 'fake' );
 123
 124   is(
 125     $t->as_text('newick',$in->params),
 126     "(B:23,C:50,(A:52,D:70)68:11);",
 127     "remove fake node, reroot on former B anc"
 128   );
 129   $t->reroot($old_root);
 130   is( $t->as_text('newick',$in->params), "(A:52,(B:23,C:50):11,D:70)68;", "roundtrip" );