[bug 2714]
[bioperl-live.git] / Bio / TreeIO.pm
blobd297026807840096a490a1bfac78f5824eafdebd
1 # $Id$
3 # BioPerl module for Bio::TreeIO
5 # Cared for by Jason Stajich <jason@bioperl.org>
7 # Copyright Jason Stajich
9 # You may distribute this module under the same terms as perl itself
11 # POD documentation - main docs before the code
13 =head1 NAME
15 Bio::TreeIO - Parser for Tree files
17 =head1 SYNOPSIS
20 use Bio::TreeIO;
21 my $treeio = Bio::TreeIO->new('-format' => 'newick',
22 '-file' => 'globin.dnd');
23 while( my $tree = $treeio->next_tree ) {
24 print "Tree is ", $tree->size, "\n";
28 =head1 DESCRIPTION
30 This is the driver module for Tree reading from data streams and
31 flatfiles. This is intended to be able to create Bio::Tree::TreeI
32 objects.
34 =head1 FEEDBACK
36 =head2 Mailing Lists
38 User feedback is an integral part of the evolution of this and other
39 Bioperl modules. Send your comments and suggestions preferably to
40 the Bioperl mailing list. Your participation is much appreciated.
42 bioperl-l@bioperl.org - General discussion
43 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
45 =head2 Reporting Bugs
47 Report bugs to the Bioperl bug tracking system to help us keep track
48 of the bugs and their resolution. Bug reports can be submitted via the
49 web:
51 http://bugzilla.open-bio.org/
53 =head1 AUTHOR - Jason Stajich
55 Email jason-at-bioperl-dot-org
57 =head1 CONTRIBUTORS
59 Allen Day E<lt>allenday@ucla.eduE<gt>
61 =head1 APPENDIX
63 The rest of the documentation details each of the object methods.
64 Internal methods are usually preceded with a _
66 =cut
69 # Let the code begin...
72 package Bio::TreeIO;
73 use strict;
75 # Object preamble - inherits from Bio::Root::Root
77 use Bio::TreeIO::TreeEventBuilder;
79 use base qw(Bio::Root::Root Bio::Root::IO Bio::Event::EventGeneratorI Bio::Factory::TreeFactoryI);
81 use constant INTERNAL_NODE_ID => 'id'; # id or bootstrap, default is 'id'
83 =head2 new
85 Title : new
86 Usage : my $obj = Bio::TreeIO->new();
87 Function: Builds a new Bio::TreeIO object
88 Returns : Bio::TreeIO
89 Args : a hash. useful keys:
90 -format : Specify the format of the file. Supported formats:
92 newick Newick tree format
93 nexus Nexus tree format
94 nhx NHX tree format
95 svggraph SVG graphical representation of tree
96 tabtree ASCII text representation of tree
97 lintree lintree output format
98 -internal_node_id : what is stored in the internal node ids,
99 bootstrap values or ids, coded as
100 'bootstrap' or 'id'
102 =cut
104 sub new {
105 my($caller,@args) = @_;
106 my $class = ref($caller) || $caller;
108 # or do we want to call SUPER on an object if $caller is an
109 # object?
110 if( $class =~ /Bio::TreeIO::(\S+)/ ) {
111 my ($self) = $class->SUPER::new(@args);
112 $self->_initialize(@args);
113 return $self;
114 } else {
116 my %param = @args;
117 @param{ map { lc $_ } keys %param } = values %param; # lowercase keys
118 my $format = $param{'-format'} ||
119 $class->_guess_format( $param{'-file'} || $ARGV[0] ) ||
120 'newick';
121 $format = "\L$format"; # normalize capitalization to lower case
123 # normalize capitalization
124 return unless( $class->_load_format_module($format) );
125 return "Bio::TreeIO::$format"->new(@args);
130 =head2 next_tree
132 Title : next_tree
133 Usage : my $tree = $treeio->next_tree;
134 Function: Gets the next tree off the stream
135 Returns : Bio::Tree::TreeI or undef if no more trees
136 Args : none
138 =cut
140 sub next_tree{
141 my ($self) = @_;
142 $self->throw("Cannot call method next_tree on Bio::TreeIO object must use a subclass");
145 =head2 write_tree
147 Title : write_tree
148 Usage : $treeio->write_tree($tree);
149 Function: Writes a tree onto the stream
150 Returns : none
151 Args : Bio::Tree::TreeI
154 =cut
156 sub write_tree{
157 my ($self,$tree) = @_;
158 $self->throw("Cannot call method write_tree on Bio::TreeIO object must use a subclass");
162 =head2 attach_EventHandler
164 Title : attach_EventHandler
165 Usage : $parser->attatch_EventHandler($handler)
166 Function: Adds an event handler to listen for events
167 Returns : none
168 Args : Bio::Event::EventHandlerI
170 =cut
172 sub attach_EventHandler{
173 my ($self,$handler) = @_;
174 return if( ! $handler );
175 if( ! $handler->isa('Bio::Event::EventHandlerI') ) {
176 $self->warn("Ignoring request to attatch handler ".ref($handler). ' because it is not a Bio::Event::EventHandlerI');
178 $self->{'_handler'} = $handler;
179 return;
182 =head2 _eventHandler
184 Title : _eventHandler
185 Usage : private
186 Function: Get the EventHandler
187 Returns : Bio::Event::EventHandlerI
188 Args : none
191 =cut
193 sub _eventHandler{
194 my ($self) = @_;
195 return $self->{'_handler'};
198 sub _initialize {
199 my($self, @args) = @_;
200 $self->{'_handler'} = undef;
201 my $internal_node_id;
202 $self->{'internal_node_id'} = INTERNAL_NODE_ID;
203 ($self->{'newline_each_node'},$internal_node_id) = $self->_rearrange
204 ([qw(NEWLINE_EACH_NODE INTERNAL_NODE_ID)],@args);
206 # initialize the IO part
207 $self->_initialize_io(@args);
208 $self->attach_EventHandler(Bio::TreeIO::TreeEventBuilder->new
209 (-verbose => $self->verbose(), @args));
210 $self->internal_node_id($internal_node_id) if defined $internal_node_id;
213 =head2 _load_format_module
215 Title : _load_format_module
216 Usage : *INTERNAL TreeIO stuff*
217 Function: Loads up (like use) a module at run time on demand
218 Example :
219 Returns :
220 Args :
222 =cut
224 sub _load_format_module {
225 my ($self,$format) = @_;
226 my $module = "Bio::TreeIO::" . $format;
227 my $ok;
229 eval {
230 $ok = $self->_load_module($module);
232 if ( $@ ) {
233 print STDERR <<END;
234 $self: $format cannot be found
235 Exception $@
236 For more information about the TreeIO system please see the TreeIO docs.
237 This includes ways of checking for formats at compile time, not run time
241 return $ok;
244 =head2 newline_each_node
246 Title : newline_each_node
247 Usage : $obj->newline_each_node($newval)
248 Function: Get/set newline each node flag which is only applicable
249 for writing tree formats for nhx and newick, will
250 print a newline after each node or paren
251 Returns : value of newline_each_node (boolean)
252 Args : on set, new value (a boolean or undef, optional)
255 =cut
257 sub newline_each_node{
258 my $self = shift;
259 return $self->{'newline_each_node'} = shift if @_;
260 return $self->{'newline_each_node'};
263 =head2 internal_node_id
265 Title : internal_node_id
266 Usage : $obj->internal_node_id($newval)
267 Function: Internal Node Id type, coded as 'bootstrap' or 'id'
268 Default is 'id'
269 Returns : value of internal_node_id (a scalar)
270 Args : on set, new value (a scalar or undef, optional)
273 =cut
275 sub internal_node_id{
276 my $self = shift;
277 my $val = shift;
278 if( defined $val ) {
279 if( $val =~ /^b/i ) {
280 $val = 'bootstrap';
281 } elsif( $val =~ /^i/ ) {
282 $val = 'id';
283 } else {
284 $self->warn("Unknown value $val for internal_node_id not resetting value\n");
286 return $self->{'internal_node_id'} = $val;
288 return $self->{'internal_node_id'};
292 =head2 _guess_format
294 Title : _guess_format
295 Usage : $obj->_guess_format($filename)
296 Function:
297 Example :
298 Returns : guessed format of filename (lower case)
299 Args :
301 =cut
303 sub _guess_format {
304 my $class = shift;
305 return unless $_ = shift;
306 return 'newick' if /\.(dnd|newick|nh)$/i;
307 return 'nhx' if /\.(nhx)$/i;
308 return 'phyloxml' if /\.(xml)$/i;
309 return 'svggraph' if /\.svg$/i;
310 return 'lintree' if( /\.(lin|lintree)$/i );
313 sub DESTROY {
314 my $self = shift;
316 $self->close();
319 sub TIEHANDLE {
320 my $class = shift;
321 return bless {'treeio' => shift},$class;
324 sub READLINE {
325 my $self = shift;
326 return $self->{'treeio'}->next_tree() unless wantarray;
327 my (@list,$obj);
328 push @list,$obj while $obj = $self->{'treeio'}->next_tree();
329 return @list;
332 sub PRINT {
333 my $self = shift;
334 $self->{'treeio'}->write_tree(@_);