Bio/Taxonomy/Tree.pm

   1 #
   2 # BioPerl module for Bio::Taxonomy::Tree
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Dan Kortschak but pilfered extensively from Bio::Tree::Tree by Jason Stajich
   7 #
   8 # You may distribute this module under the same terms as perl itself
   9
  10 # POD documentation - main docs before the code
  11
  12 =head1 NAME
  13
  14 Bio::Taxonomy::Tree - An Organism Level Implementation of TreeI interface.
  15
  16 =head1 SYNOPSIS
  17
  18     # NB: This module is deprecated. Use Bio::Taxon in combination with
  19     # Bio::Tree::Tree instead
  20
  21     # like from a TreeIO
  22     my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'treefile.dnd');
  23     my $tree = $treeio->next_tree;
  24     my @nodes = $tree->get_nodes;
  25     my $root = $tree->get_root_node;
  26     my @leaves = $tree->get_leaves;
  27
  28
  29 =head1 DESCRIPTION
  30
  31 This object holds handles to Taxonomic Nodes which make up a tree.
  32
  33 =head1 EXAMPLES
  34
  35   use Bio::Species;
  36   use Bio::Taxonomy::Tree;
  37
  38   my $human=Bio::Species->new();
  39   my $chimp=Bio::Species->new();
  40   my $bonobo=Bio::Species->new();
  41
  42   $human->classification(qw( sapiens Homo Hominidae
  43                              Catarrhini Primates Eutheria
  44                              Mammalia Euteleostomi Vertebrata
  45                              Craniata Chordata
  46                              Metazoa Eukaryota ));
  47   $chimp->classification(qw( troglodytes Pan Hominidae
  48                              Catarrhini Primates Eutheria
  49                              Mammalia Euteleostomi Vertebrata
  50                              Craniata Chordata
  51                              Metazoa Eukaryota ));
  52   $bonobo->classification(qw( paniscus Pan Hominidae
  53                               Catarrhini Primates Eutheria
  54                               Mammalia Euteleostomi Vertebrata
  55                               Craniata Chordata
  56                               Metazoa Eukaryota ));
  57
  58   # ranks passed to $taxonomy match ranks of species
  59   my @ranks = ('superkingdom','kingdom','phylum','subphylum',
  60                'no rank 1','no rank 2','class','no rank 3','order',
  61                'suborder','family','genus','species');
  62
  63   my $taxonomy=Bio::Taxonomy->new(-ranks => \@ranks,
  64                                  -method => 'trust',
  65                                  -order => -1);
  66
  67
  68   my $tree1=Bio::Taxonomy::Tree->new();
  69   my $tree2=Bio::Taxonomy::Tree->new();
  70
  71   $tree1->make_species_branch($human,$taxonomy);
  72   $tree2->make_species_branch($chimp,$taxonomy);
  73
  74   my ($homo_sapiens)=$tree1->get_leaves;
  75
  76   $tree1->splice($tree2);
  77
  78   $tree1->add_species($bonobo,$taxonomy);
  79
  80   my @taxa;
  81   foreach my $leaf ($tree1->get_leaves) {
  82      push @taxa,$leaf->taxon;
  83   }
  84   print join(", ",@taxa)."\n";
  85
  86   @taxa=();
  87   $tree1->remove_branch($homo_sapiens);
  88   foreach my $leaf ($tree1->get_leaves) {
  89      push @taxa,$leaf->taxon;
  90   }
  91   print join(", ",@taxa)."\n";
  92
  93 =head1 FEEDBACK
  94
  95 See AUTHOR
  96
  97 =head1 AUTHOR - Dan Kortschak
  98
  99 Email kortschak@rsbs.anu.edu.au
 100
 101 =head1 CONTRIBUTORS
 102
 103 Mainly Jason Stajich
 104
 105 =head1 APPENDIX
 106
 107 The rest of the documentation details each of the object methods.
 108 Internal methods are usually preceded with a _
 109
 110 =cut
 111
 112
 113 # Code begins...
 114
 115
 116 package Bio::Taxonomy::Tree;
 117 use strict;
 118
 119 # Object preamble - inherits from Bio::Root::Root
 120
 121 use Bio::Taxonomy::Taxon;
 122
 123 # Import rank information from Bio::Taxonomy.pm
 124 use vars qw(@RANK %RANK);
 125
 126 use base qw(Bio::Root::Root Bio::Tree::TreeI Bio::Tree::TreeFunctionsI);
 127
 128 =head2 new
 129
 130  Title   : new
 131  Usage   : my $obj = Bio::Taxonomy::Tree->new();
 132  Function: Builds a new Bio::Taxonomy::Tree object
 133  Returns : Bio::Taxonomy::Tree
 134  Args    :
 135
 136
 137 =cut
 138
 139 sub new {
 140   my($class,@args) = @_;
 141
 142   my $self = $class->SUPER::new(@args);
 143   $self->warn("Bio::Taxonomy::Tree is deprecated. Use Bio::Taxon in combination with Bio::Tree::Tree instead.");
 144
 145   $self->{'_rootnode'} = undef;
 146   $self->{'_maxbranchlen'} = 0;
 147
 148   my ($root)= $self->_rearrange([qw(ROOT)], @args);
 149   if( $root ) { $self->set_root_node($root); }
 150   return $self;
 151 }
 152
 153
 154 =head2 get_nodes
 155
 156  Title   : get_nodes
 157  Usage   : my @nodes = $tree->get_nodes()
 158  Function: Return list of Bio::Taxonomy::Taxon objects
 159  Returns : array of Bio::Taxonomy::Taxon objects
 160  Args    : (named values) hash with one value
 161            order => 'b|breadth' first order or 'd|depth' first order
 162
 163 =cut
 164
 165 sub get_nodes{
 166    my ($self, @args) = @_;
 167
 168    my ($order, $sortby) = $self->_rearrange([qw(ORDER SORTBY)],@args);
 169    $order ||= 'depth';
 170    $sortby ||= 'height';
 171
 172    if ($order =~ m/^b|(breadth)$/oi) {
 173       my $node = $self->get_root_node;
 174       my @children = ($node);
 175       for (@children) {
 176            push @children, $_->each_Descendent($sortby);
 177       }
 178       return @children;
 179    }
 180
 181    if ($order =~ m/^d|(depth)$/oi) {
 182        # this is depth-first search I believe
 183        my $node = $self->get_root_node;
 184        my @children = ($node,$node->get_Descendents($sortby));
 185        return @children;
 186    }
 187 }
 188
 189 =head2 get_root_node
 190
 191  Title   : get_root_node
 192  Usage   : my $node = $tree->get_root_node();
 193  Function: Get the Top Node in the tree, in this implementation
 194            Trees only have one top node.
 195  Returns : Bio::Taxonomy::Taxon object
 196  Args    : none
 197
 198 =cut
 199
 200
 201 sub get_root_node{
 202    my ($self) = @_;
 203    return $self->{'_rootnode'};
 204 }
 205
 206 =head2 set_root_node
 207
 208  Title   : set_root_node
 209  Usage   : $tree->set_root_node($node)
 210  Function: Set the Root Node for the Tree
 211  Returns : Bio::Taxonomy::Taxon
 212  Args    : Bio::Taxonomy::Taxon
 213
 214 =cut
 215
 216
 217 sub set_root_node{
 218    my ($self,$value) = @_;
 219    if( defined $value ) {
 220       if( ! $value->isa('Bio::Taxonomy::Taxon') ) {
 221            $self->warn("Trying to set the root node to $value which is not a Bio::Taxonomy::Taxon");
 222            return $self->get_root_node;
 223       }
 224       $self->{'_rootnode'} = $value;
 225    }
 226    return $self->get_root_node;
 227 }
 228
 229
 230 =head2 get_leaves
 231
 232  Title   : get_leaves
 233  Usage   : my @nodes = $tree->get_leaves()
 234  Function: Return list of Bio::Taxonomy::Taxon objects
 235  Returns : array of Bio::Taxonomy::Taxon objects
 236  Args    :
 237
 238 =cut
 239
 240
 241 sub get_leaves{
 242    my ($self) = @_;
 243
 244    my $node = $self->get_root_node;
 245    my @leaves;
 246    my @children = ($node);
 247    for (@children) {
 248       push @children, $_->each_Descendent();
 249    }
 250    for (@children) {
 251       push @leaves, $_ if $_->is_Leaf;
 252    }
 253    return @leaves;
 254 }
 255
 256 =head2 make_species_branch
 257
 258  Title   : make_species_branch
 259  Usage   : @nodes = $tree->make_species_branch($species,$taxonomy)
 260  Function: Return list of Bio::Taxonomy::Taxon objects based on a Bio::Species object
 261  Returns : array of Bio::Taxonomy::Taxon objects
 262  Args    : Bio::Species and Bio::Taxonomy objects
 263
 264 =cut
 265
 266 # I'm not happy that make_species_branch and make_branch are seperate routines
 267 # should be able to just make_branch and have it sort things out
 268
 269 sub make_species_branch{
 270    my ($self,$species,$taxonomy) = @_;
 271
 272    if (! $species->isa('Bio::Species') ) {
 273       $self->throw("Trying to classify $species which is not a Bio::Species object");
 274    }
 275    if (! $taxonomy->isa('Bio::Taxonomy') ) {
 276       $self->throw("Trying to classify with $taxonomy which is not a Bio::Taxonomy object");
 277    }
 278
 279    # this is done to make sure we aren't duplicating a path (let God sort them out)
 280    if (defined $self->get_root_node) {
 281       $self->get_root_node->remove_all_Descendents;
 282    }
 283
 284    my @nodes;
 285
 286    # nb taxa in [i][0] and ranks in [i][1]
 287    my @taxa=$taxonomy->classify($species);
 288
 289    for (my $i = 0; $i < @taxa; $i++) {
 290       $nodes[$i]=Bio::Taxonomy::Taxon->new(-taxon => $taxa[$i][0],
 291                                            -rank  => $taxa[$i][1]);
 292    }
 293
 294    for (my $i = 0; $i < @taxa-1; $i++) {
 295       $nodes[$i]->add_Descendent($nodes[$i+1]);
 296    }
 297
 298    $self->set_root_node($nodes[0]);
 299
 300    return @nodes;
 301 }
 302
 303
 304 =head2 make_branch
 305
 306  Title   : make_branch
 307  Usage   : $tree->make_branch($node)
 308  Function: Make a linear Bio::Taxonomy::Tree object from a leafish node
 309  Returns :
 310  Args    : Bio::Taxonomy::Taxon object
 311
 312 =cut
 313
 314
 315 sub make_branch{
 316    my ($self,$node) = @_;
 317
 318    # this is done to make sure we aren't duplicating a path (let God sort them out)
 319    # note that if you are using a linked set of node which include node
 320    # already in the tree, this will break
 321    $self->get_root_node->remove_all_Descendents;
 322
 323    while (defined $node->ancestor) {
 324       $self->set_root_node($node);
 325       $node=$node->ancestor;
 326    }
 327 }
 328
 329
 330 =head2 splice
 331
 332  Title   : splice
 333  Usage   : @nodes = $tree->splice($tree)
 334  Function: Return a of Bio::Taxonomy::Tree object that is a fusion of two
 335  Returns : array of Bio::Taxonomy::Taxon added to tree
 336  Args    : Bio::Taxonomy::Tree object
 337
 338 =cut
 339
 340
 341 sub splice{
 342    my ($self,$tree) = @_;
 343
 344    my @nodes;
 345
 346    my @newleaves = $tree->get_leaves;
 347    foreach my $leaf (@newleaves) {
 348       push @nodes,$self->add_branch($leaf);
 349    }
 350
 351    return @nodes;
 352 }
 353
 354 =head2 add_species
 355
 356  Title   : add_species
 357  Usage   : @nodes = $tree->add_species($species,$taxonomy)
 358  Function: Return a of Bio::Taxonomy::Tree object with a new species added
 359  Returns : array of Bio::Taxonomy::Taxon added to tree
 360  Args    : Bio::Species object
 361
 362 =cut
 363
 364
 365 sub add_species{
 366    my ($self,$species,$taxonomy) = @_;
 367
 368    my $branch=Bio::Taxonomy::Tree->new;
 369    my @nodes=$branch->make_species_branch($species,$taxonomy);
 370
 371    my ($newleaf)=$branch->get_leaves;
 372
 373    return $self->add_branch($newleaf);
 374 }
 375
 376 =head2 add_branch
 377
 378  Title   : add_branch
 379  Usage   : $tree->add_branch($node,boolean)
 380  Function: Return a of Bio::Taxonomy::Tree object with a new branch added
 381  Returns : array of Bio::Taxonomy::Taxon objects of the resulting tree
 382  Args    : Bio::Taxonomy::Taxon object
 383            boolean flag to force overwrite of descendent
 384              (see Bio::Node->add_Descendent)
 385
 386 =cut
 387
 388
 389 sub add_branch {
 390    my ($self,$node,$force) = @_;
 391
 392    my $best_node_level=0;
 393    my ($best_node,@nodes,$common);
 394
 395    my @leaves=$self->get_leaves;
 396    foreach my $leaf (@leaves) {
 397       $common=$node->recent_common_ancestor($leaf); # the root of the part to add
 398       if (defined $common && ($common->distance_to_root > $best_node_level)) {
 399          $best_node_level = $common->distance_to_root;
 400          $best_node = $common;
 401       }
 402    }
 403
 404    return unless defined $best_node;
 405
 406    push @nodes,($self->get_root_node,$self->get_root_node->get_Descendents);
 407    foreach my $node (@nodes) {
 408       if ((defined $best_node->id && $best_node->id == $node->id) ||
 409          ($best_node->rank eq $node->rank && $best_node->taxon eq $node->taxon) &&
 410          ($best_node->rank ne 'no rank')) {
 411          foreach my $descendent ($common->each_Descendent) {
 412             $node->add_Descendent($descendent,$force);
 413          }
 414       }
 415
 416       $self->set_root_node($node) if $node->distance_to_root==0;
 417    }
 418
 419    return ($common->get_Descendents);
 420 }
 421
 422 =head2 remove_branch
 423
 424  Title   : remove_branch
 425  Usage   : $tree->remove_branch($node)
 426  Function: remove a branch up to the next multifurcation
 427  Returns :
 428  Args    : Bio::Taxonomy::Taxon object
 429
 430 =cut
 431
 432
 433 sub remove_branch{
 434    my ($self,$node) = @_;
 435
 436    # we can define a branch at any point along it
 437
 438    while (defined $node->ancestor) {
 439       last if $node->ancestor->each_Descendent > 1;
 440       $node=$node->ancestor;
 441    }
 442    $node->remove_all_Descendents; # I'm not sure if this is necessary,
 443                                   # but I don't see that remove_Descendent
 444                                   # has the side effect of deleting
 445                                   # descendent nodes of the deletee
 446    $node->ancestor->remove_Descendent($node);
 447 }
 448
 449
 450
 451 1;