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 16Bio::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 29This module handles parsing and writing of Newick/PHYLIP/New Hampshire format. 30 31=head1 FEEDBACK 32 33=head2 Mailing Lists 34 35User feedback is an integral part of the evolution of this and other 36Bioperl modules. Send your comments and suggestions preferably to the 37Bioperl 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 44Please direct usage questions or support issues to the mailing list: 45 46I<bioperl-l@bioperl.org> 47 48rather than to the module maintainer directly. Many experienced and 49reponsive experts will be able look at the problem and quickly 50address it. Please include a thorough description of the problem 51with code and data examples if at all possible. 52 53=head2 Reporting Bugs 54 55Report bugs to the Bioperl bug tracking system to help us keep track 56of the bugs and their resolution. Bug reports can be submitted via the 57web: 58 59 https://github.com/bioperl/bioperl-live/issues 60 61=head1 AUTHOR - Jason Stajich 62 63Email jason-at-bioperl-dot-org 64 65=head1 APPENDIX 66 67The rest of the documentation details each of the object methods. 68Internal methods are usually preceded with a _ 69 70=cut 71 72# Let the code begin... 73 74package Bio::TreeIO::newick; 75$Bio::TreeIO::newick::VERSION = '1.7.7'; 76use strict; 77 78use Bio::Event::EventGeneratorI; 79 80use base qw(Bio::TreeIO Bio::TreeIO::NewickParser); 81 82=head2 new 83 84Title : new 85Args : -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 90See L<Bio::Node::Node::each_Descendent()> 91 92=cut 93 94sub _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 109Title : next_tree 110Usage : my $tree = $treeio->next_tree 111Function: Gets the next tree in the stream 112Returns : L<Bio::Tree::TreeI> 113Args : none 114 115=cut 116 117sub 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 }; 130s/([^"]*)(".+?")([^"]*)/$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. 156sub 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 174Title : write_tree 175Usage : $treeio->write_tree($tree); 176Function: Write a tree out to data stream in newick/phylip format 177Returns : none 178Args : L<Bio::Tree::TreeI> object 179 180=cut 181 182sub 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 206sub _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 228sub _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 269Title : print_tree_count 270Usage : $obj->print_tree_count($newval) 271Function: Get/Set flag for printing out the tree count (paml,protml way) 272Returns : value of print_tree_count (a scalar) 273Args : on set, new value (a scalar or undef, optional) 274 275=cut 276 277sub 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 285Title : bootstrap_style 286Usage : $obj->bootstrap_style($newval) 287Function: 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; 304Returns : value of bootstrap_style (a scalar) 305Args : on set, new value (a scalar or undef, optional) 306 307=cut 308 309sub 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 328Title : order_by 329Usage : $obj->order_by($newval) 330Function: Allow node order to be specified (typically "alpha") 331 See L<Bio::Node::Node::each_Descendent()> 332Returns : value of order_by (a scalar) 333Args : on set, new value (a scalar or undef, optional) 334 335=cut 336 337sub order_by { 338 my $self = shift; 339 340 return $self->{'order_by'} = shift if @_; 341 return $self->{'order_by'}; 342} 343 3441; 345