Bio/TreeIO.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::TreeIO
   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 - Parser for Tree files
  16
  17 =head1 SYNOPSIS
  18
  19   {
  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";
  25       }
  26   }
  27
  28 =head1 DESCRIPTION
  29
  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.
  33
  34 =head1 FEEDBACK
  35
  36 =head2 Mailing Lists
  37
  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.
  41
  42   bioperl-l@bioperl.org                  - General discussion
  43   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  44
  45 =head2 Reporting Bugs
  46
  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:
  50
  51   http://bugzilla.open-bio.org/
  52
  53 =head1 AUTHOR - Jason Stajich
  54
  55 Email jason-at-bioperl-dot-org
  56
  57 =head1 CONTRIBUTORS
  58
  59 Allen Day E<lt>allenday@ucla.eduE<gt>
  60
  61 =head1 APPENDIX
  62
  63 The rest of the documentation details each of the object methods.
  64 Internal methods are usually preceded with a _
  65
  66 =cut
  67
  68
  69 # Let the code begin...
  70
  71
  72 package Bio::TreeIO;
  73 use strict;
  74
  75 # Object preamble - inherits from Bio::Root::Root
  76
  77 use Bio::TreeIO::TreeEventBuilder;
  78
  79 use base qw(Bio::Root::Root Bio::Root::IO Bio::Event::EventGeneratorI Bio::Factory::TreeFactoryI);
  80
  81 use constant INTERNAL_NODE_ID => 'id'; # id or bootstrap, default is 'id'
  82
  83 =head2 new
  84
  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:
  91
  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'
 101
 102 =cut
 103
 104 sub new {
 105   my($caller,@args) = @_;
 106   my $class = ref($caller) || $caller;
 107
 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 {
 115
 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
 122
 123         # normalize capitalization
 124         return unless( $class->_load_format_module($format) );
 125         return "Bio::TreeIO::$format"->new(@args);
 126     }
 127 }
 128
 129
 130 =head2 next_tree
 131
 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
 137
 138 =cut
 139
 140 sub next_tree{
 141    my ($self) = @_;
 142    $self->throw("Cannot call method next_tree on Bio::TreeIO object must use a subclass");
 143 }
 144
 145 =head2 write_tree
 146
 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
 152
 153
 154 =cut
 155
 156 sub write_tree{
 157    my ($self,$tree) = @_;
 158    $self->throw("Cannot call method write_tree on Bio::TreeIO object must use a subclass");
 159 }
 160
 161
 162 =head2 attach_EventHandler
 163
 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
 169
 170 =cut
 171
 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');
 177     }
 178     $self->{'_handler'} = $handler;
 179     return;
 180 }
 181
 182 =head2 _eventHandler
 183
 184  Title   : _eventHandler
 185  Usage   : private
 186  Function: Get the EventHandler
 187  Returns : Bio::Event::EventHandlerI
 188  Args    : none
 189
 190
 191 =cut
 192
 193 sub _eventHandler{
 194    my ($self) = @_;
 195    return $self->{'_handler'};
 196 }
 197
 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);
 205
 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;
 211 }
 212
 213 =head2 _load_format_module
 214
 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    :
 221
 222 =cut
 223
 224 sub _load_format_module {
 225   my ($self,$format) = @_;
 226   my $module = "Bio::TreeIO::" . $format;
 227   my $ok;
 228
 229   eval {
 230       $ok = $self->_load_module($module);
 231   };
 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
 238 END
 239   ;
 240   }
 241   return $ok;
 242 }
 243
 244 =head2 newline_each_node
 245
 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)
 253
 254
 255 =cut
 256
 257 sub newline_each_node{
 258     my $self = shift;
 259     return $self->{'newline_each_node'} = shift if @_;
 260     return $self->{'newline_each_node'};
 261 }
 262
 263 =head2 internal_node_id
 264
 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)
 271
 272
 273 =cut
 274
 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");
 285         }
 286         return $self->{'internal_node_id'} = $val;
 287     }
 288     return $self->{'internal_node_id'};
 289 }
 290
 291
 292 =head2 _guess_format
 293
 294  Title   : _guess_format
 295  Usage   : $obj->_guess_format($filename)
 296  Function:
 297  Example :
 298  Returns : guessed format of filename (lower case)
 299  Args    :
 300
 301 =cut
 302
 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 );
 311 }
 312
 313 sub DESTROY {
 314     my $self = shift;
 315
 316     $self->close();
 317 }
 318
 319 sub TIEHANDLE {
 320   my $class = shift;
 321   return bless {'treeio' => shift},$class;
 322 }
 323
 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;
 330 }
 331
 332 sub PRINT {
 333   my $self = shift;
 334   $self->{'treeio'}->write_tree(@_);
 335 }
 336
 337 1;