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
  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 use strict;
  76
  77 use Bio::Event::EventGeneratorI;
  78
  79 use base qw(Bio::TreeIO Bio::TreeIO::NewickParser);
  80
  81 =head2 new
  82
  83 Title   : new
  84 Args    : -print_count     => boolean  default is false
  85            -bootstrap_style => set the bootstrap style (one of nobranchlength,
  86                                                         molphy, traditional)
  87            -order_by => set the order by sort method
  88
  89 See L<Bio::Node::Node::each_Descendent()>
  90
  91 =cut
  92
  93 sub _initialize {
  94     my $self = shift;
  95     $self->SUPER::_initialize(@_);
  96     my ( $print_count ) = $self->_rearrange(
  97         [
  98             qw(PRINT_COUNT)
  99         ],
 100         @_
 101     );
 102     $self->print_tree_count( $print_count || 0 );
 103     return;
 104 }
 105
 106 =head2 next_tree
 107
 108 Title   : next_tree
 109 Usage   : my $tree = $treeio->next_tree
 110 Function: Gets the next tree in the stream
 111 Returns : L<Bio::Tree::TreeI>
 112 Args    : none
 113
 114 =cut
 115
 116 sub next_tree {
 117     my ($self) = @_;
 118     local $/ = ";\n";
 119     return unless $_ = $self->_readline;
 120
 121     s/[\r\n]//gs;
 122     my $score;
 123     my $despace = sub { my $dirty = shift; $dirty =~ s/\s+//gs; return $dirty };
 124     my $dequote = sub {
 125         my $dirty = shift;
 126         $dirty =~ s/^"?\s*(.+?)\s*"?$/$1/;
 127         return $dirty;
 128     };
 129 s/([^"]*)(".+?")([^"]*)/$despace->($1) . $dequote->($2) . $despace->($3)/egsx;
 130
 131     if (s/^\s*\[([^\]]+)\]//) {
 132         my $match = $1;
 133         $match =~ s/\s//g;
 134         $match =~ s/lh\=//;
 135         if ( $match =~ /([-\d\.+]+)/ ) {
 136             $score = $1;
 137         }
 138     }
 139
 140     $self->_eventHandler->start_document;
 141
 142     # Call the parse_newick method as defined in NewickParser.pm
 143     $self->parse_newick($_);
 144
 145     my $tree = $self->_eventHandler->end_document;
 146
 147     # Add the tree score afterwards if it exists.
 148     if (defined $tree) {
 149       $tree->score($score);
 150       return $tree;
 151     }
 152 }
 153
 154 # Returns the default set of parsing & writing parameters for the Newick format.
 155 sub get_default_params {
 156   my $self = shift;
 157
 158   return {
 159     newline_each_node => 0,
 160     order_by => '', # ???
 161     bootstrap_style => 'traditional', # Can be 'traditional', 'molphy', 'nobranchlength'
 162     internal_node_id => 'id', # Can be 'id' or 'bootstrap'
 163
 164     no_branch_lengths => 0,
 165     no_bootstrap_values => 0,
 166     no_internal_node_labels => 0
 167   };
 168 }
 169
 170
 171 =head2 write_tree
 172
 173 Title   : write_tree
 174 Usage   : $treeio->write_tree($tree);
 175 Function: Write a tree out to data stream in newick/phylip format
 176 Returns : none
 177 Args    : L<Bio::Tree::TreeI> object
 178
 179 =cut
 180
 181 sub write_tree {
 182     my ( $self, @trees ) = @_;
 183     if ( $self->print_tree_count ) {
 184         $self->_print( sprintf( " %d\n", scalar @trees ) );
 185     }
 186
 187     my $params = $self->get_params;
 188
 189     foreach my $tree (@trees) {
 190       if (  !defined $tree
 191             || ref($tree) =~ /ARRAY/i
 192             || !$tree->isa('Bio::Tree::TreeI') )
 193       {
 194         $self->throw(
 195                      "Calling write_tree with non Bio::Tree::TreeI object\n");
 196       }
 197       my @data = $self->_write_tree_Helper( $tree->get_root_node, $params);
 198       $self->_print( join( ',', @data ).";" );
 199     }
 200
 201     $self->flush if $self->_flush_on_write && defined $self->_fh;
 202     return;
 203 }
 204
 205 sub _write_tree_Helper {
 206   my $self = shift;
 207     my ( $node, $params ) = @_;
 208     my @data;
 209
 210     foreach my $n ( $node->each_Descendent($params->{order_by}) ) {
 211         push @data, $self->_write_tree_Helper( $n, $params );
 212     }
 213
 214     my $label = $self->_node_as_string($node,$params);
 215
 216     if ( scalar(@data) >= 1) {
 217       $data[0] = "(" . $data[0];
 218       $data[-1] .= ")";
 219       $data[-1] .= $label;
 220     } else {
 221       push @data, $label;
 222     }
 223
 224     return @data;
 225 }
 226
 227 sub _node_as_string {
 228   my $self = shift;
 229   my $node = shift;
 230   my $params = shift;
 231
 232   my $label_stringbuffer = '';
 233
 234   if ($params->{no_bootstrap_values} != 1 &&
 235       !$node->is_Leaf &&
 236       defined $node->bootstrap &&
 237       $params->{bootstrap_style} eq 'traditional' &&
 238       $params->{internal_node_id} eq 'bootstrap') {
 239     # If we're an internal node and we're using 'traditional' bootstrap style,
 240     # we output the bootstrap instead of any label.
 241     my $bootstrap = $node->bootstrap;
 242     $label_stringbuffer .= $bootstrap if (defined $bootstrap);
 243   } elsif ($params->{no_internal_node_labels} != 1) {
 244     my $id = $node->id;
 245     $label_stringbuffer .= $id  if( defined $id );
 246   }
 247
 248   if ($params->{no_branch_lengths} != 1) {
 249     my $blen  = $node->branch_length;
 250     $label_stringbuffer .= ":". $blen if (defined $blen);
 251   }
 252
 253   if ($params->{bootstrap_style} eq 'molphy') {
 254     my $bootstrap = $node->bootstrap;
 255     $label_stringbuffer .= "[$bootstrap]" if (defined $bootstrap);
 256   }
 257
 258   if ($params->{newline_each_node} == 1) {
 259     $label_stringbuffer .= "\n";
 260   }
 261
 262   return $label_stringbuffer;
 263 }
 264
 265
 266 =head2 print_tree_count
 267
 268 Title   : print_tree_count
 269 Usage   : $obj->print_tree_count($newval)
 270 Function: Get/Set flag for printing out the tree count (paml,protml way)
 271 Returns : value of print_tree_count (a scalar)
 272 Args    : on set, new value (a scalar or undef, optional)
 273
 274 =cut
 275
 276 sub print_tree_count {
 277     my $self = shift;
 278     return $self->{'_print_tree_count'} = shift if @_;
 279     return $self->{'_print_tree_count'} || 0;
 280 }
 281
 282 =head2 bootstrap_style
 283
 284 Title   : bootstrap_style
 285 Usage   : $obj->bootstrap_style($newval)
 286 Function: A description of how bootstraps and branch lengths are
 287            written, as the ID part of the internal node or else in []
 288            in the branch length (Molphy-like; I am sure there is a
 289            better name for this but am not sure where to go for some
 290            sort of format documentation)
 291
 292            If no branch lengths are requested then no bootstraps are usually
 293            written (unless someone REALLY wants this functionality...)
 294
 295            Can take on strings which contain the possible values of
 296            'nobranchlength'   --> don't draw any branch lengths - this
 297                                   is helpful if you don't want to have to
 298                                   go through and delete branch len on all nodes
 299            'molphy' --> draw bootstraps (100) like
 300                                   (A:0.11,B:0.22):0.33[100];
 301            'traditional' --> draw bootstraps (100) like
 302                                   (A:0.11,B:0.22)100:0.33;
 303 Returns : value of bootstrap_style (a scalar)
 304 Args    : on set, new value (a scalar or undef, optional)
 305
 306 =cut
 307
 308 sub bootstrap_style {
 309     my $self = shift;
 310     my $val  = shift;
 311     if ( defined $val ) {
 312
 313         if ( $val !~ /^nobranchlength|molphy|traditional/i ) {
 314             $self->warn(
 315 "requested an unknown bootstrap style $val, expect one of nobranchlength,molphy,traditional, not updating value.\n"
 316             );
 317         }
 318         else {
 319             $self->{'_bootstrap_style'} = $val;
 320         }
 321     }
 322     return $self->{'_bootstrap_style'} || 'traditional';
 323 }
 324
 325 =head2 order_by
 326
 327 Title   : order_by
 328 Usage   : $obj->order_by($newval)
 329 Function: Allow node order to be specified (typically "alpha")
 330            See L<Bio::Node::Node::each_Descendent()>
 331 Returns : value of order_by (a scalar)
 332 Args    : on set, new value (a scalar or undef, optional)
 333
 334 =cut
 335
 336 sub order_by {
 337     my $self = shift;
 338
 339     return $self->{'order_by'} = shift if @_;
 340     return $self->{'order_by'};
 341 }
 342
 343 1;