lib/Bio/TreeIO/newick.pm

   1 #
   2 # BioPerl module for Bio::TreeIO::newick
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Jason Stajich <jason@bioperl.org>
   7 #
   8 # Copyright Jason Stajich
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::TreeIO::newick - parsing and writing of Newick/PHYLIP/New Hampshire format
  17
  18 =head1 SYNOPSIS
  19
  20   # do not use this module directly
  21   use Bio::TreeIO;
  22
  23   my $treeio = Bio::TreeIO->new(-format => 'newick',
  24                                -file => 't/data/LOAD_Ccd1.dnd');
  25   my $tree = $treeio->next_tree;
  26
  27 =head1 DESCRIPTION
  28
  29 This module handles parsing and writing of Newick/PHYLIP/New Hampshire format.
  30
  31 =head1 FEEDBACK
  32
  33 =head2 Mailing Lists
  34
  35 User feedback is an integral part of the evolution of this and other
  36 Bioperl modules. Send your comments and suggestions preferably to the
  37 Bioperl mailing list.  Your participation is much appreciated.
  38
  39   bioperl-l@bioperl.org                  - General discussion
  40   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  41
  42 =head2 Support
  43
  44 Please direct usage questions or support issues to the mailing list:
  45
  46 I<bioperl-l@bioperl.org>
  47
  48 rather than to the module maintainer directly. Many experienced and
  49 reponsive experts will be able look at the problem and quickly
  50 address it. Please include a thorough description of the problem
  51 with code and data examples if at all possible.
  52
  53 =head2 Reporting Bugs
  54
  55 Report bugs to the Bioperl bug tracking system to help us keep track
  56 of the bugs and their resolution. Bug reports can be submitted via the
  57 web:
  58
  59   https://github.com/bioperl/bioperl-live/issues
  60
  61 =head1 AUTHOR - Jason Stajich
  62
  63 Email jason-at-bioperl-dot-org
  64
  65 =head1 APPENDIX
  66
  67 The rest of the documentation details each of the object methods.
  68 Internal methods are usually preceded with a _
  69
  70 =cut
  71
  72 # Let the code begin...
  73
  74 package Bio::TreeIO::newick;
  75
  76 use strict;
  77
  78 use Bio::Event::EventGeneratorI;
  79
  80 use base qw(Bio::TreeIO Bio::TreeIO::NewickParser);
  81
  82 =head2 new
  83
  84 Title   : new
  85 Args    : -print_count     => boolean  default is false
  86            -bootstrap_style => set the bootstrap style (one of nobranchlength,
  87                                                         molphy, traditional)
  88            -order_by => set the order by sort method
  89
  90 See L<Bio::Node::Node::each_Descendent()>
  91
  92 =cut
  93
  94 sub _initialize {
  95     my $self = shift;
  96     $self->SUPER::_initialize(@_);
  97     my ( $print_count ) = $self->_rearrange(
  98         [
  99             qw(PRINT_COUNT)
 100         ],
 101         @_
 102     );
 103     $self->print_tree_count( $print_count || 0 );
 104     return;
 105 }
 106
 107 =head2 next_tree
 108
 109 Title   : next_tree
 110 Usage   : my $tree = $treeio->next_tree
 111 Function: Gets the next tree in the stream
 112 Returns : L<Bio::Tree::TreeI>
 113 Args    : none
 114
 115 =cut
 116
 117 sub next_tree {
 118     my ($self) = @_;
 119     local $/ = ";\n";
 120     return unless $_ = $self->_readline;
 121
 122     s/[\r\n]//gs;
 123     my $score;
 124     my $despace = sub { my $dirty = shift; $dirty =~ s/\s+//gs; return $dirty };
 125     my $dequote = sub {
 126         my $dirty = shift;
 127         $dirty =~ s/^"?\s*(.+?)\s*"?$/$1/;
 128         return $dirty;
 129     };
 130 s/([^"]*)(".+?")([^"]*)/$despace->($1) . $dequote->($2) . $despace->($3)/egsx;
 131
 132     if (s/^\s*\[([^\]]+)\]//) {
 133         my $match = $1;
 134         $match =~ s/\s//g;
 135         $match =~ s/lh\=//;
 136         if ( $match =~ /([-\d\.+]+)/ ) {
 137             $score = $1;
 138         }
 139     }
 140
 141     $self->_eventHandler->start_document;
 142
 143     # Call the parse_newick method as defined in NewickParser.pm
 144     $self->parse_newick($_);
 145
 146     my $tree = $self->_eventHandler->end_document;
 147
 148     # Add the tree score afterwards if it exists.
 149     if (defined $tree) {
 150       $tree->score($score);
 151       return $tree;
 152     }
 153 }
 154
 155 # Returns the default set of parsing & writing parameters for the Newick format.
 156 sub get_default_params {
 157   my $self = shift;
 158
 159   return {
 160     newline_each_node => 0,
 161     order_by => '', # ???
 162     bootstrap_style => 'traditional', # Can be 'traditional', 'molphy', 'nobranchlength'
 163     internal_node_id => 'id', # Can be 'id' or 'bootstrap'
 164
 165     no_branch_lengths => 0,
 166     no_bootstrap_values => 0,
 167     no_internal_node_labels => 0
 168   };
 169 }
 170
 171
 172 =head2 write_tree
 173
 174 Title   : write_tree
 175 Usage   : $treeio->write_tree($tree);
 176 Function: Write a tree out to data stream in newick/phylip format
 177 Returns : none
 178 Args    : L<Bio::Tree::TreeI> object
 179
 180 =cut
 181
 182 sub write_tree {
 183     my ( $self, @trees ) = @_;
 184     if ( $self->print_tree_count ) {
 185         $self->_print( sprintf( " %d\n", scalar @trees ) );
 186     }
 187
 188     my $params = $self->get_params;
 189
 190     foreach my $tree (@trees) {
 191       if (  !defined $tree
 192             || ref($tree) =~ /ARRAY/i
 193             || !$tree->isa('Bio::Tree::TreeI') )
 194       {
 195         $self->throw(
 196                      "Calling write_tree with non Bio::Tree::TreeI object\n");
 197       }
 198       my @data = $self->_write_tree_Helper( $tree->get_root_node, $params);
 199       $self->_print( join( ',', @data ).";" );
 200     }
 201
 202     $self->flush if $self->_flush_on_write && defined $self->_fh;
 203     return;
 204 }
 205
 206 sub _write_tree_Helper {
 207   my $self = shift;
 208     my ( $node, $params ) = @_;
 209     my @data;
 210
 211     foreach my $n ( $node->each_Descendent($params->{order_by}) ) {
 212         push @data, $self->_write_tree_Helper( $n, $params );
 213     }
 214
 215     my $label = $self->_node_as_string($node,$params);
 216
 217     if ( scalar(@data) >= 1) {
 218       $data[0] = "(" . $data[0];
 219       $data[-1] .= ")";
 220       $data[-1] .= $label;
 221     } else {
 222       push @data, $label;
 223     }
 224
 225     return @data;
 226 }
 227
 228 sub _node_as_string {
 229   my $self = shift;
 230   my $node = shift;
 231   my $params = shift;
 232
 233   my $label_stringbuffer = '';
 234
 235   if ($params->{no_bootstrap_values} != 1 &&
 236       !$node->is_Leaf &&
 237       defined $node->bootstrap &&
 238       $params->{bootstrap_style} eq 'traditional' &&
 239       $params->{internal_node_id} eq 'bootstrap') {
 240     # If we're an internal node and we're using 'traditional' bootstrap style,
 241     # we output the bootstrap instead of any label.
 242     my $bootstrap = $node->bootstrap;
 243     $label_stringbuffer .= $bootstrap if (defined $bootstrap);
 244   } elsif ($params->{no_internal_node_labels} != 1) {
 245     my $id = $node->id;
 246     $label_stringbuffer .= $id  if( defined $id );
 247   }
 248
 249   if ($params->{no_branch_lengths} != 1) {
 250     my $blen  = $node->branch_length;
 251     $label_stringbuffer .= ":". $blen if (defined $blen);
 252   }
 253
 254   if ($params->{bootstrap_style} eq 'molphy') {
 255     my $bootstrap = $node->bootstrap;
 256     $label_stringbuffer .= "[$bootstrap]" if (defined $bootstrap);
 257   }
 258
 259   if ($params->{newline_each_node} == 1) {
 260     $label_stringbuffer .= "\n";
 261   }
 262
 263   return $label_stringbuffer;
 264 }
 265
 266
 267 =head2 print_tree_count
 268
 269 Title   : print_tree_count
 270 Usage   : $obj->print_tree_count($newval)
 271 Function: Get/Set flag for printing out the tree count (paml,protml way)
 272 Returns : value of print_tree_count (a scalar)
 273 Args    : on set, new value (a scalar or undef, optional)
 274
 275 =cut
 276
 277 sub print_tree_count {
 278     my $self = shift;
 279     return $self->{'_print_tree_count'} = shift if @_;
 280     return $self->{'_print_tree_count'} || 0;
 281 }
 282
 283 =head2 bootstrap_style
 284
 285 Title   : bootstrap_style
 286 Usage   : $obj->bootstrap_style($newval)
 287 Function: A description of how bootstraps and branch lengths are
 288            written, as the ID part of the internal node or else in []
 289            in the branch length (Molphy-like; I am sure there is a
 290            better name for this but am not sure where to go for some
 291            sort of format documentation)
 292
 293            If no branch lengths are requested then no bootstraps are usually
 294            written (unless someone REALLY wants this functionality...)
 295
 296            Can take on strings which contain the possible values of
 297            'nobranchlength'   --> don't draw any branch lengths - this
 298                                   is helpful if you don't want to have to
 299                                   go through and delete branch len on all nodes
 300            'molphy' --> draw bootstraps (100) like
 301                                   (A:0.11,B:0.22):0.33[100];
 302            'traditional' --> draw bootstraps (100) like
 303                                   (A:0.11,B:0.22)100:0.33;
 304 Returns : value of bootstrap_style (a scalar)
 305 Args    : on set, new value (a scalar or undef, optional)
 306
 307 =cut
 308
 309 sub bootstrap_style {
 310     my $self = shift;
 311     my $val  = shift;
 312     if ( defined $val ) {
 313
 314         if ( $val !~ /^nobranchlength|molphy|traditional/i ) {
 315             $self->warn(
 316 "requested an unknown bootstrap style $val, expect one of nobranchlength,molphy,traditional, not updating value.\n"
 317             );
 318         }
 319         else {
 320             $self->{'_bootstrap_style'} = $val;
 321         }
 322     }
 323     return $self->{'_bootstrap_style'} || 'traditional';
 324 }
 325
 326 =head2 order_by
 327
 328 Title   : order_by
 329 Usage   : $obj->order_by($newval)
 330 Function: Allow node order to be specified (typically "alpha")
 331            See L<Bio::Node::Node::each_Descendent()>
 332 Returns : value of order_by (a scalar)
 333 Args    : on set, new value (a scalar or undef, optional)
 334
 335 =cut
 336
 337 sub order_by {
 338     my $self = shift;
 339
 340     return $self->{'order_by'} = shift if @_;
 341     return $self->{'order_by'};
 342 }
 343
 344 1;