|
0
|
1 # $Id: Tree.pm,v 1.13.2.2 2003/09/14 20:22:31 jason Exp $
|
|
|
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
|
|
|
91 =cut
|
|
|
92
|
|
|
93 sub new {
|
|
|
94 my($class,@args) = @_;
|
|
|
95
|
|
|
96 my $self = $class->SUPER::new(@args);
|
|
|
97 $self->{'_rootnode'} = undef;
|
|
|
98 $self->{'_maxbranchlen'} = 0;
|
|
|
99 $self->_register_for_cleanup(\&cleanup_tree);
|
|
|
100 my ($root,$nodel)= $self->_rearrange([qw(ROOT NODELETE)], @args);
|
|
|
101 if( $root ) { $self->set_root_node($root); }
|
|
|
102 $self->nodelete($nodel || 0);
|
|
|
103 return $self;
|
|
|
104 }
|
|
|
105
|
|
|
106
|
|
|
107 =head2 nodelete
|
|
|
108
|
|
|
109 Title : nodelete
|
|
|
110 Usage : $obj->nodelete($newval)
|
|
|
111 Function: Get/Set Boolean whether or not to delete the underlying
|
|
|
112 nodes when it goes out of scope. By default this is false
|
|
|
113 meaning trees are cleaned up.
|
|
|
114 Returns : boolean
|
|
|
115 Args : on set, new boolean value
|
|
|
116
|
|
|
117
|
|
|
118 =cut
|
|
|
119
|
|
|
120 sub nodelete{
|
|
|
121 my $self = shift;
|
|
|
122 return $self->{'nodelete'} = shift if @_;
|
|
|
123 return $self->{'nodelete'};
|
|
|
124 }
|
|
|
125
|
|
|
126 =head2 get_nodes
|
|
|
127
|
|
|
128 Title : get_nodes
|
|
|
129 Usage : my @nodes = $tree->get_nodes()
|
|
|
130 Function: Return list of Tree::NodeI objects
|
|
|
131 Returns : array of Tree::NodeI objects
|
|
|
132 Args : (named values) hash with one value
|
|
|
133 order => 'b|breadth' first order or 'd|depth' first order
|
|
|
134
|
|
|
135 =cut
|
|
|
136
|
|
|
137 sub get_nodes{
|
|
|
138 my ($self, @args) = @_;
|
|
|
139
|
|
|
140 my ($order, $sortby) = $self->_rearrange([qw(ORDER SORTBY)],@args);
|
|
|
141 $order ||= 'depth';
|
|
|
142 $sortby ||= 'height';
|
|
|
143 return () unless defined $self->get_root_node;
|
|
|
144 if ($order =~ m/^b|(breadth)$/oi) {
|
|
|
145 my $node = $self->get_root_node;
|
|
|
146 my @children = ($node);
|
|
|
147 for (@children) {
|
|
|
148 push @children, $_->each_Descendent($sortby);
|
|
|
149 }
|
|
|
150 return @children;
|
|
|
151 }
|
|
|
152
|
|
|
153 if ($order =~ m/^d|(depth)$/oi) {
|
|
|
154 # this is depth-first search I believe
|
|
|
155 my $node = $self->get_root_node;
|
|
|
156 my @children = ($node,$node->get_Descendents($sortby));
|
|
|
157 return @children;
|
|
|
158 }
|
|
|
159 }
|
|
|
160
|
|
|
161 =head2 get_root_node
|
|
|
162
|
|
|
163 Title : get_root_node
|
|
|
164 Usage : my $node = $tree->get_root_node();
|
|
|
165 Function: Get the Top Node in the tree, in this implementation
|
|
|
166 Trees only have one top node.
|
|
|
167 Returns : Bio::Tree::NodeI object
|
|
|
168 Args : none
|
|
|
169
|
|
|
170 =cut
|
|
|
171
|
|
|
172
|
|
|
173 sub get_root_node{
|
|
|
174 my ($self) = @_;
|
|
|
175 return $self->{'_rootnode'};
|
|
|
176 }
|
|
|
177
|
|
|
178 =head2 set_root_node
|
|
|
179
|
|
|
180 Title : set_root_node
|
|
|
181 Usage : $tree->set_root_node($node)
|
|
|
182 Function: Set the Root Node for the Tree
|
|
|
183 Returns : Bio::Tree::NodeI
|
|
|
184 Args : Bio::Tree::NodeI
|
|
|
185
|
|
|
186 =cut
|
|
|
187
|
|
|
188 sub set_root_node{
|
|
|
189 my $self = shift;
|
|
|
190 if( @_ ) {
|
|
|
191 my $value = shift;
|
|
|
192 if( defined $value &&
|
|
|
193 ! $value->isa('Bio::Tree::NodeI') ) {
|
|
|
194 $self->warn("Trying to set the root node to $value which is not a Bio::Tree::NodeI");
|
|
|
195 return $self->get_root_node;
|
|
|
196 }
|
|
|
197 $self->{'_rootnode'} = $value;
|
|
|
198 }
|
|
|
199 return $self->get_root_node;
|
|
|
200 }
|
|
|
201
|
|
|
202 =head2 total_branch_length
|
|
|
203
|
|
|
204 Title : total_branch_length
|
|
|
205 Usage : my $size = $tree->total_branch_length
|
|
|
206 Function: Returns the sum of the length of all branches
|
|
|
207 Returns : integer
|
|
|
208 Args : none
|
|
|
209
|
|
|
210 =cut
|
|
|
211
|
|
|
212 sub total_branch_length {
|
|
|
213 my ($self) = @_;
|
|
|
214 my $sum = 0;
|
|
|
215 if( defined $self->get_root_node ) {
|
|
|
216 for ( $self->get_root_node->get_Descendents() ) {
|
|
|
217 $sum += $_->branch_length || 0;
|
|
|
218 }
|
|
|
219 }
|
|
|
220 return $sum;
|
|
|
221 }
|
|
|
222
|
|
|
223 =head2 id
|
|
|
224
|
|
|
225 Title : id
|
|
|
226 Usage : my $id = $tree->id();
|
|
|
227 Function: An id value for the tree
|
|
|
228 Returns : scalar
|
|
|
229 Args : [optional] new value to set
|
|
|
230
|
|
|
231
|
|
|
232 =cut
|
|
|
233
|
|
|
234 sub id{
|
|
|
235 my ($self,$val) = @_;
|
|
|
236 if( defined $val ) {
|
|
|
237 $self->{'_treeid'} = $val;
|
|
|
238 }
|
|
|
239 return $self->{'_treeid'};
|
|
|
240 }
|
|
|
241
|
|
|
242 =head2 score
|
|
|
243
|
|
|
244 Title : score
|
|
|
245 Usage : $obj->score($newval)
|
|
|
246 Function: Sets the associated score with this tree
|
|
|
247 This is a generic slot which is probably best used
|
|
|
248 for log likelihood or other overall tree score
|
|
|
249 Returns : value of score
|
|
|
250 Args : newvalue (optional)
|
|
|
251
|
|
|
252
|
|
|
253 =cut
|
|
|
254
|
|
|
255 sub score{
|
|
|
256 my ($self,$val) = @_;
|
|
|
257 if( defined $val ) {
|
|
|
258 $self->{'_score'} = $val;
|
|
|
259 }
|
|
|
260 return $self->{'_score'};
|
|
|
261 }
|
|
|
262
|
|
|
263
|
|
|
264 # decorated interface TreeI Implements this
|
|
|
265
|
|
|
266 =head2 height
|
|
|
267
|
|
|
268 Title : height
|
|
|
269 Usage : my $height = $tree->height
|
|
|
270 Function: Gets the height of tree - this LOG_2($number_nodes)
|
|
|
271 WARNING: this is only true for strict binary trees. The TreeIO
|
|
|
272 system is capable of building non-binary trees, for which this
|
|
|
273 method will currently return an incorrect value!!
|
|
|
274 Returns : integer
|
|
|
275 Args : none
|
|
|
276
|
|
|
277 =head2 number_nodes
|
|
|
278
|
|
|
279 Title : number_nodes
|
|
|
280 Usage : my $size = $tree->number_nodes
|
|
|
281 Function: Returns the number of nodes
|
|
|
282 Example :
|
|
|
283 Returns :
|
|
|
284 Args :
|
|
|
285
|
|
|
286
|
|
|
287 =cut
|
|
|
288
|
|
|
289
|
|
|
290 # -- private internal methods --
|
|
|
291
|
|
|
292 sub cleanup_tree {
|
|
|
293 my $self = shift;
|
|
|
294 unless( $self->nodelete ) {
|
|
|
295 foreach my $node ( $self->get_nodes ) {
|
|
|
296 $node->ancestor(undef);
|
|
|
297 $node = undef;
|
|
|
298 }
|
|
|
299 }
|
|
|
300 $self->{'_rootnode'} = undef;
|
|
|
301 }
|
|
|
302 1;
|
