|
0
|
1 # $Id: TreeEventBuilder.pm,v 1.11.2.1 2003/09/13 21:51:05 jason Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::TreeIO::TreeEventBuilder
|
|
|
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::TreeIO::TreeEventBuilder - Build Bio::Tree::Tree's and
|
|
|
16 Bio::Tree::Node's from Events
|
|
|
17
|
|
|
18 =head1 SYNOPSIS
|
|
|
19
|
|
|
20 # internal use only
|
|
|
21
|
|
|
22 =head1 DESCRIPTION
|
|
|
23
|
|
|
24 This object will take events and build a Bio::Tree::TreeI compliant
|
|
|
25 object makde up of Bio::Tree::NodeI objects.
|
|
|
26
|
|
|
27 =head1 FEEDBACK
|
|
|
28
|
|
|
29 =head2 Mailing Lists
|
|
|
30
|
|
|
31 User feedback is an integral part of the evolution of this and other
|
|
|
32 Bioperl modules. Send your comments and suggestions preferably to
|
|
|
33 the Bioperl mailing list. Your participation is much appreciated.
|
|
|
34
|
|
|
35 bioperl-l@bioperl.org - General discussion
|
|
|
36 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
37
|
|
|
38 =head2 Reporting Bugs
|
|
|
39
|
|
|
40 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
41 of the bugs and their resolution. Bug reports can be submitted via
|
|
|
42 email or the web:
|
|
|
43
|
|
|
44 bioperl-bugs@bioperl.org
|
|
|
45 http://bugzilla.bioperl.org/
|
|
|
46
|
|
|
47 =head1 AUTHOR - Jason Stajich
|
|
|
48
|
|
|
49 Email jason@bioperl.org
|
|
|
50
|
|
|
51 Describe contact details here
|
|
|
52
|
|
|
53 =head1 CONTRIBUTORS
|
|
|
54
|
|
|
55 Additional contributors names and emails here
|
|
|
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::TreeIO::TreeEventBuilder;
|
|
|
69 use vars qw(@ISA);
|
|
|
70 use strict;
|
|
|
71
|
|
|
72 use Bio::Root::Root;
|
|
|
73 use Bio::Event::EventHandlerI;
|
|
|
74 use Bio::Tree::Tree;
|
|
|
75 use Bio::Tree::Node;
|
|
|
76
|
|
|
77 @ISA = qw(Bio::Root::Root Bio::Event::EventHandlerI);
|
|
|
78
|
|
|
79 =head2 new
|
|
|
80
|
|
|
81 Title : new
|
|
|
82 Usage : my $obj = new Bio::TreeIO::TreeEventBuilder();
|
|
|
83 Function: Builds a new Bio::TreeIO::TreeEventBuilder object
|
|
|
84 Returns : Bio::TreeIO::TreeEventBuilder
|
|
|
85 Args :
|
|
|
86
|
|
|
87
|
|
|
88 =cut
|
|
|
89
|
|
|
90 sub new {
|
|
|
91 my($class,@args) = @_;
|
|
|
92
|
|
|
93 my $self = $class->SUPER::new(@args);
|
|
|
94 my ($treetype, $nodetype) = $self->_rearrange([qw(TREETYPE
|
|
|
95 NODETYPE)], @args);
|
|
|
96 $treetype ||= 'Bio::Tree::Tree';
|
|
|
97 $nodetype ||= 'Bio::Tree::Node';
|
|
|
98
|
|
|
99 eval {
|
|
|
100 $self->_load_module($treetype);
|
|
|
101 $self->_load_module($nodetype);
|
|
|
102 };
|
|
|
103
|
|
|
104 if( $@ ) {
|
|
|
105 $self->throw("Could not load module $treetype or $nodetype. \n$@\n")
|
|
|
106 }
|
|
|
107 $self->treetype($treetype);
|
|
|
108 $self->nodetype($nodetype);
|
|
|
109 $self->{'_treelevel'} = 0;
|
|
|
110
|
|
|
111 return $self;
|
|
|
112 }
|
|
|
113
|
|
|
114 =head2 treetype
|
|
|
115
|
|
|
116 Title : treetype
|
|
|
117 Usage : $obj->treetype($newval)
|
|
|
118 Function:
|
|
|
119 Returns : value of treetype
|
|
|
120 Args : newvalue (optional)
|
|
|
121
|
|
|
122
|
|
|
123 =cut
|
|
|
124
|
|
|
125 sub treetype{
|
|
|
126 my ($self,$value) = @_;
|
|
|
127 if( defined $value) {
|
|
|
128 $self->{'treetype'} = $value;
|
|
|
129 }
|
|
|
130 return $self->{'treetype'};
|
|
|
131 }
|
|
|
132
|
|
|
133 =head2 nodetype
|
|
|
134
|
|
|
135 Title : nodetype
|
|
|
136 Usage : $obj->nodetype($newval)
|
|
|
137 Function:
|
|
|
138 Returns : value of nodetype
|
|
|
139 Args : newvalue (optional)
|
|
|
140
|
|
|
141
|
|
|
142 =cut
|
|
|
143
|
|
|
144 sub nodetype{
|
|
|
145 my ($self,$value) = @_;
|
|
|
146 if( defined $value) {
|
|
|
147 $self->{'nodetype'} = $value;
|
|
|
148 }
|
|
|
149 return $self->{'nodetype'};
|
|
|
150 }
|
|
|
151
|
|
|
152
|
|
|
153 =head2 SAX methods
|
|
|
154
|
|
|
155 =cut
|
|
|
156
|
|
|
157 =head2 start_document
|
|
|
158
|
|
|
159 Title : start_document
|
|
|
160 Usage : $handler->start_document
|
|
|
161 Function: Begins a Tree event cycle
|
|
|
162 Returns : none
|
|
|
163 Args : none
|
|
|
164
|
|
|
165 =cut
|
|
|
166
|
|
|
167 sub start_document {
|
|
|
168 my ($self) = @_;
|
|
|
169 $self->{'_lastitem'} = {};
|
|
|
170 $self->{'_currentitems'} = [];
|
|
|
171 $self->{'_currentnodes'} = [];
|
|
|
172 return;
|
|
|
173 }
|
|
|
174
|
|
|
175 =head2 end_document
|
|
|
176
|
|
|
177 Title : end_document
|
|
|
178 Usage : my @trees = $parser->end_document
|
|
|
179 Function: Finishes a Phylogeny cycle
|
|
|
180 Returns : An array Bio::Tree::TreeI
|
|
|
181 Args : none
|
|
|
182
|
|
|
183 =cut
|
|
|
184
|
|
|
185 sub end_document {
|
|
|
186 my ($self) = @_;
|
|
|
187 my $vb = $self->verbose;
|
|
|
188 my $root = $self->nodetype->new(-verbose => $vb);
|
|
|
189 # aggregate the nodes into trees basically ad-hoc.
|
|
|
190 while ( @{$self->{'_currentnodes'}} ) {
|
|
|
191 my ($node) = ( shift @{$self->{'_currentnodes'}});
|
|
|
192 $root->add_Descendent($node);
|
|
|
193 }
|
|
|
194
|
|
|
195 $self->debug("Root node is " . $root->to_string()."\n");
|
|
|
196 if( $self->verbose > 0 ) {
|
|
|
197 foreach my $node ( $root->get_Descendents ) {
|
|
|
198 $self->debug("node is ". $node->to_string(). "\n");
|
|
|
199 }
|
|
|
200 }
|
|
|
201 my $tree = $self->treetype->new(-root => $root,
|
|
|
202 -verbose => $vb);
|
|
|
203 return $tree;
|
|
|
204 }
|
|
|
205
|
|
|
206 =head2 start_element
|
|
|
207
|
|
|
208 Title : start_element
|
|
|
209 Usage :
|
|
|
210 Function:
|
|
|
211 Example :
|
|
|
212 Returns :
|
|
|
213 Args : $data => hashref with key 'Name'
|
|
|
214
|
|
|
215 =cut
|
|
|
216
|
|
|
217 sub start_element{
|
|
|
218 my ($self,$data) =@_;
|
|
|
219 $self->{'_lastitem'}->{$data->{'Name'}}++;
|
|
|
220
|
|
|
221 $self->debug("starting element: $data->{Name}\n");
|
|
|
222
|
|
|
223 push @{$self->{'_lastitem'}->{'current'}},$data->{'Name'};
|
|
|
224
|
|
|
225 my %data;
|
|
|
226
|
|
|
227 if( $data->{'Name'} eq 'node' ) {
|
|
|
228 push @{$self->{'_currentitems'}}, \%data;
|
|
|
229 } elsif ( $data->{Name} eq 'tree' ) {
|
|
|
230 $self->{'_treelevel'}++;
|
|
|
231 }
|
|
|
232 }
|
|
|
233
|
|
|
234 =head2 end_element
|
|
|
235
|
|
|
236 Title : end_element
|
|
|
237 Usage :
|
|
|
238 Function:
|
|
|
239 Returns : none
|
|
|
240 Args : $data => hashref with key 'Name'
|
|
|
241
|
|
|
242 =cut
|
|
|
243
|
|
|
244 sub end_element{
|
|
|
245 my ($self,$data) = @_;
|
|
|
246
|
|
|
247 $self->debug("end of element: $data->{Name}\n");
|
|
|
248
|
|
|
249 if( $data->{'Name'} eq 'node' ) {
|
|
|
250 my $tnode;
|
|
|
251 my $node = pop @{$self->{'_currentitems'}};
|
|
|
252
|
|
|
253 $tnode = $self->nodetype->new(-verbose => $self->verbose,
|
|
|
254 %{$node});
|
|
|
255 unless ( $node->{'-leaf'} ) {
|
|
|
256 for ( splice( @{$self->{'_currentnodes'}},
|
|
|
257 - $self->{'_nodect'}->[$self->{'_treelevel'}+1])) {
|
|
|
258
|
|
|
259 $self->debug("adding desc: " . $_->to_string . "\n");
|
|
|
260 $tnode->add_Descendent($_);
|
|
|
261 }
|
|
|
262 $self->{_nodect}->[$self->{_treelevel}+1] = 0;
|
|
|
263 }
|
|
|
264 push @{$self->{'_currentnodes'}}, $tnode;
|
|
|
265 $self->{_nodect}->[$self->{'_treelevel'}]++;
|
|
|
266 $self->debug ("added node: nodes in stack is ". scalar @{$self->{'_currentnodes'}} . ", treelevel: $self->{_treelevel}, nodect: $self->{_nodect}->[$self->{_treelevel}]\n");
|
|
|
267 } elsif( $data->{'Name'} eq 'tree' ) {
|
|
|
268 $self->debug("end of tree: nodes in stack is ". scalar @{$self->{'_currentnodes'}}. "\n");
|
|
|
269 $self->{'_treelevel'}--;
|
|
|
270 }
|
|
|
271 $self->{'_lastitem'}->{ $data->{'Name'} }--;
|
|
|
272
|
|
|
273 pop @{$self->{'_lastitem'}->{'current'}};
|
|
|
274 }
|
|
|
275
|
|
|
276
|
|
|
277 =head2 in_element
|
|
|
278
|
|
|
279 Title : in_element
|
|
|
280 Usage :
|
|
|
281 Function:
|
|
|
282 Example :
|
|
|
283 Returns :
|
|
|
284 Args :
|
|
|
285
|
|
|
286
|
|
|
287 =cut
|
|
|
288
|
|
|
289 sub in_element{
|
|
|
290 my ($self,$e) = @_;
|
|
|
291
|
|
|
292 return 0 if ! defined $self->{'_lastitem'} ||
|
|
|
293 ! defined $self->{'_lastitem'}->{'current'}->[-1];
|
|
|
294 return ($e eq $self->{'_lastitem'}->{'current'}->[-1]);
|
|
|
295
|
|
|
296 }
|
|
|
297
|
|
|
298 =head2 within_element
|
|
|
299
|
|
|
300 Title : within_element
|
|
|
301 Usage :
|
|
|
302 Function:
|
|
|
303 Example :
|
|
|
304 Returns :
|
|
|
305 Args :
|
|
|
306
|
|
|
307
|
|
|
308 =cut
|
|
|
309
|
|
|
310 sub within_element{
|
|
|
311 my ($self,$e) = @_;
|
|
|
312 return $self->{'_lastitem'}->{$e};
|
|
|
313 }
|
|
|
314
|
|
|
315 =head2 characters
|
|
|
316
|
|
|
317 Title : characters
|
|
|
318 Usage : $handler->characters($text);
|
|
|
319 Function: Processes characters
|
|
|
320 Returns : none
|
|
|
321 Args : text string
|
|
|
322
|
|
|
323
|
|
|
324 =cut
|
|
|
325
|
|
|
326 sub characters{
|
|
|
327 my ($self,$ch) = @_;
|
|
|
328 if( $self->within_element('node') ) {
|
|
|
329 my $hash = pop @{$self->{'_currentitems'}};
|
|
|
330 if( $self->in_element('bootstrap') ) {
|
|
|
331 $hash->{'-bootstrap'} = $ch;
|
|
|
332 } elsif( $self->in_element('branch_length') ) {
|
|
|
333 $hash->{'-branch_length'} = $ch;
|
|
|
334 } elsif( $self->in_element('id') ) {
|
|
|
335 $hash->{'-id'} = $ch;
|
|
|
336 } elsif( $self->in_element('description') ) {
|
|
|
337 $hash->{'-desc'} = $ch;
|
|
|
338 } elsif ( $self->in_element('tag_name') ) {
|
|
|
339 $hash->{'-NHXtagname'} = $ch;
|
|
|
340 } elsif ( $self->in_element('tag_value') ) {
|
|
|
341 $hash->{'-nhx'}->{$hash->{'-NHXtagname'}} = $ch;
|
|
|
342 delete $hash->{'-NHXtagname'};
|
|
|
343 } elsif( $self->in_element('leaf') ) {
|
|
|
344 $hash->{'-leaf'} = $ch;
|
|
|
345 }
|
|
|
346 push @{$self->{'_currentitems'}}, $hash;
|
|
|
347 }
|
|
|
348 $self->debug("chars: $ch\n");
|
|
|
349 }
|
|
|
350
|
|
|
351
|
|
|
352 1;
|
