Bio/Tree/Tree.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Tree::Tree
   4 #
   5 # Cared for by Jason Stajich <jason@bioperl.org>
   6 #
   7 # Copyright Jason Stajich
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10
  11 # POD documentation - main docs before the code
  12
  13 =head1 NAME
  14
  15 Bio::Tree::Tree - An Implementation of TreeI interface.
  16
  17 =head1 SYNOPSIS
  18
  19     # like from a TreeIO
  20     my $treeio = new Bio::TreeIO(-format => 'newick', -file => 'treefile.dnd');
  21     my $tree = $treeio->next_tree;
  22     my @nodes = $tree->get_nodes;
  23     my $root = $tree->get_root_node;
  24
  25
  26 =head1 DESCRIPTION
  27
  28 This object holds handles to Nodes which make up a tree.
  29
  30 =head1 FEEDBACK
  31
  32 =head2 Mailing Lists
  33
  34 User feedback is an integral part of the evolution of this and other
  35 Bioperl modules. Send your comments and suggestions preferably to
  36 the Bioperl mailing list.  Your participation is much appreciated.
  37
  38   bioperl-l@bioperl.org              - General discussion
  39   http://bioperl.org/MailList.shtml  - About the mailing lists
  40
  41 =head2 Reporting Bugs
  42
  43 Report bugs to the Bioperl bug tracking system to help us keep track
  44 of the bugs and their resolution. Bug reports can be submitted via
  45 the web:
  46
  47   http://bugzilla.bioperl.org/
  48
  49 =head1 AUTHOR - Jason Stajich
  50
  51 Email jason@bioperl.org
  52
  53 =head1 CONTRIBUTORS
  54
  55 Aaron Mackey amackey@virginia.edu
  56
  57 =head1 APPENDIX
  58
  59 The rest of the documentation details each of the object methods.
  60 Internal methods are usually preceded with a _
  61
  62 =cut
  63
  64
  65 # Let the code begin...
  66
  67
  68 package Bio::Tree::Tree;
  69 use vars qw(@ISA);
  70 use strict;
  71
  72 # Object preamble - inherits from Bio::Root::Root
  73
  74 use Bio::Root::Root;
  75 use Bio::Tree::TreeFunctionsI;
  76 use Bio::Tree::TreeI;
  77
  78 @ISA = qw(Bio::Root::Root Bio::Tree::TreeI Bio::Tree::TreeFunctionsI   );
  79
  80 =head2 new
  81
  82  Title   : new
  83  Usage   : my $obj = new Bio::Tree::Tree();
  84  Function: Builds a new Bio::Tree::Tree object
  85  Returns : Bio::Tree::Tree
  86  Args    : -root     => L<Bio::Tree::NodeI> object which is the root
  87            -nodelete => boolean, whether or not to try and cleanup all
  88                                  the nodes when this this tree goes out
  89                                  of scope.
  90            -id       => optional tree ID
  91            -score    => optional tree score value
  92
  93 =cut
  94
  95 sub new {
  96   my($class,@args) = @_;
  97
  98   my $self = $class->SUPER::new(@args);
  99   $self->{'_rootnode'} = undef;
 100   $self->{'_maxbranchlen'} = 0;
 101   $self->_register_for_cleanup(\&cleanup_tree);
 102   my ($root,$nodel,$id,$score)= $self->_rearrange([qw(ROOT NODELETE
 103                                                       ID SCORE)], @args);
 104   if( $root ) { $self->set_root_node($root); }
 105   $self->nodelete($nodel || 0);
 106   $self->id($id)       if defined $id;
 107   $self->score($score) if defined $score;
 108   return $self;
 109 }
 110
 111
 112 =head2 nodelete
 113
 114  Title   : nodelete
 115  Usage   : $obj->nodelete($newval)
 116  Function: Get/Set Boolean whether or not to delete the underlying
 117            nodes when it goes out of scope.  By default this is false
 118            meaning trees are cleaned up.
 119  Returns : boolean
 120  Args    : on set, new boolean value
 121
 122
 123 =cut
 124
 125 sub nodelete{
 126     my $self = shift;
 127     return $self->{'nodelete'} = shift if @_;
 128     return $self->{'nodelete'};
 129 }
 130
 131 =head2 get_nodes
 132
 133  Title   : get_nodes
 134  Usage   : my @nodes = $tree->get_nodes()
 135  Function: Return list of Tree::NodeI objects
 136  Returns : array of Tree::NodeI objects
 137  Args    : (named values) hash with one value
 138            order => 'b|breadth' first order or 'd|depth' first order
 139
 140 =cut
 141
 142 sub get_nodes{
 143    my ($self, @args) = @_;
 144
 145    my ($order, $sortby) = $self->_rearrange([qw(ORDER SORTBY)],@args);
 146    $order ||= 'depth';
 147    $sortby ||= 'none';
 148    return () unless defined $self->get_root_node;
 149    if ($order =~ m/^b|(breadth)$/oi) {
 150        my $node = $self->get_root_node;
 151        my @children = ($node);
 152        for (@children) {
 153            push @children, $_->each_Descendent($sortby);
 154        }
 155        return @children;
 156    }
 157
 158    if ($order =~ m/^d|(depth)$/oi) {
 159        # this is depth-first search I believe
 160        my $node = $self->get_root_node;
 161        my @children = ($node,$node->get_all_Descendents($sortby));
 162        return @children;
 163    }
 164 }
 165
 166 =head2 get_root_node
 167
 168  Title   : get_root_node
 169  Usage   : my $node = $tree->get_root_node();
 170  Function: Get the Top Node in the tree, in this implementation
 171            Trees only have one top node.
 172  Returns : Bio::Tree::NodeI object
 173  Args    : none
 174
 175 =cut
 176
 177
 178 sub get_root_node{
 179    my ($self) = @_;
 180    return $self->{'_rootnode'};
 181 }
 182
 183 =head2 set_root_node
 184
 185  Title   : set_root_node
 186  Usage   : $tree->set_root_node($node)
 187  Function: Set the Root Node for the Tree
 188  Returns : Bio::Tree::NodeI
 189  Args    : Bio::Tree::NodeI
 190
 191 =cut
 192
 193 sub set_root_node{
 194    my $self = shift;
 195    if( @_ ) {
 196        my $value = shift;
 197        if( defined $value &&
 198            ! $value->isa('Bio::Tree::NodeI') ) {
 199            $self->warn("Trying to set the root node to $value which is not a Bio::Tree::NodeI");
 200            return $self->get_root_node;
 201        }
 202        $self->{'_rootnode'} = $value;
 203    }
 204    return $self->get_root_node;
 205 }
 206
 207 =head2 total_branch_length
 208
 209  Title   : total_branch_length
 210  Usage   : my $size = $tree->total_branch_length
 211  Function: Returns the sum of the length of all branches
 212  Returns : integer
 213  Args    : none
 214
 215 =cut
 216
 217 sub total_branch_length {
 218    my ($self) = @_;
 219    my $sum = 0;
 220    if( defined $self->get_root_node ) {
 221        for ( $self->get_root_node->get_all_Descendents('none') ) {
 222            $sum += $_->branch_length || 0;
 223        }
 224    }
 225    return $sum;
 226 }
 227
 228 =head2 id
 229
 230  Title   : id
 231  Usage   : my $id = $tree->id();
 232  Function: An id value for the tree
 233  Returns : scalar
 234  Args    : [optional] new value to set
 235
 236
 237 =cut
 238
 239 sub id{
 240    my ($self,$val) = @_;
 241    if( defined $val ) {
 242        $self->{'_treeid'} = $val;
 243    }
 244    return $self->{'_treeid'};
 245 }
 246
 247 =head2 score
 248
 249  Title   : score
 250  Usage   : $obj->score($newval)
 251  Function: Sets the associated score with this tree
 252            This is a generic slot which is probably best used
 253            for log likelihood or other overall tree score
 254  Returns : value of score
 255  Args    : newvalue (optional)
 256
 257
 258 =cut
 259
 260 sub score{
 261    my ($self,$val) = @_;
 262    if( defined $val ) {
 263        $self->{'_score'} = $val;
 264    }
 265    return $self->{'_score'};
 266 }
 267
 268
 269 # decorated interface TreeI Implements this
 270
 271 =head2 height
 272
 273  Title   : height
 274  Usage   : my $height = $tree->height
 275  Function: Gets the height of tree - this LOG_2($number_nodes)
 276            WARNING: this is only true for strict binary trees.  The TreeIO
 277            system is capable of building non-binary trees, for which this
 278            method will currently return an incorrect value!!
 279  Returns : integer
 280  Args    : none
 281
 282 =head2 number_nodes
 283
 284  Title   : number_nodes
 285  Usage   : my $size = $tree->number_nodes
 286  Function: Returns the number of nodes in the tree
 287  Returns : integer
 288  Args    : none
 289
 290
 291 =cut
 292
 293
 294 # -- private internal methods --
 295
 296 sub cleanup_tree {
 297     my $self = shift;
 298     unless( $self->nodelete ) {
 299         for my $node ( $self->get_nodes(-order  => 'b',
 300                                         -sortby => 'none') ) {
 301             $node->ancestor(undef);
 302             $node = undef;
 303         }
 304     }
 305     $self->{'_rootnode'} = undef;
 306 }
 307
 308 1;