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