← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/TreeIO/newick.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/TreeIO/newick.pm
1
 
# $Id: newick.pm,v 1.24 2003/12/16 16:53:43 jason Exp $
 
1
# $Id: newick.pm,v 1.36.4.2 2006/10/02 23:10:37 sendu Exp $
2
2
#
3
3
# BioPerl module for Bio::TreeIO::newick
4
4
#
35
35
Bioperl modules. Send your comments and suggestions preferably to the
36
36
Bioperl mailing list.  Your participation is much appreciated.
37
37
 
38
 
  bioperl-l@bioperl.org              - General discussion
39
 
  http://bioperl.org/MailList.shtml  - About the mailing lists
 
38
  bioperl-l@bioperl.org                  - General discussion
 
39
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
40
40
 
41
41
=head2 Reporting Bugs
42
42
 
43
43
Report bugs to the Bioperl bug tracking system to help us keep track
44
 
of the bugs and their resolution. Bug reports can be submitted via
45
 
email or the web:
 
44
of the bugs and their resolution. Bug reports can be submitted via the
 
45
web:
46
46
 
47
 
  bioperl-bugs@bioperl.org
48
 
  http://bugzilla.bioperl.org/
 
47
  http://bugzilla.open-bio.org/
49
48
 
50
49
=head1 AUTHOR - Jason Stajich
51
50
 
52
 
Email jason@bioperl.org
53
 
 
54
 
Describe contact details here
55
 
 
56
 
=head1 CONTRIBUTORS
57
 
 
58
 
Additional contributors names and emails here
 
51
Email jason-at-bioperl-dot-org
59
52
 
60
53
=head1 APPENDIX
61
54
 
69
62
 
70
63
 
71
64
package Bio::TreeIO::newick;
72
 
use vars qw(@ISA);
 
65
use vars qw($DefaultBootstrapStyle);
73
66
use strict;
74
67
 
75
 
# Object preamble - inherits from Bio::Root::Root
76
 
 
77
 
use Bio::TreeIO;
78
68
use Bio::Event::EventGeneratorI;
79
 
#use XML::Handler::Subs;
80
 
 
81
 
 
82
 
@ISA = qw(Bio::TreeIO );
 
69
 
 
70
#initialize some package variables, could use 'our' but fails in perl < 5.6
 
71
 
 
72
$DefaultBootstrapStyle = 'traditional';
 
73
use base qw(Bio::TreeIO);
 
74
 
 
75
 
 
76
=head2 new
 
77
 
 
78
 Title   : new
 
79
 Args    : -print_count     => boolean  default is false
 
80
           -bootstrap_style => set the bootstrap style (one of nobranchlength,
 
81
                                                        molphy, traditional)
 
82
           -order_by        => set the order by sort method 
 
83
                               (see L<Bio::Node::Node::each_Descendent()> )
 
84
 
 
85
=cut
 
86
 
 
87
sub _initialize { 
 
88
    my $self = shift;
 
89
    $self->SUPER::_initialize(@_);
 
90
    my ($print_count,$style,$order_by) = $self->_rearrange([qw(PRINT_COUNT 
 
91
                                                               BOOTSTRAP_STYLE
 
92
                                                               ORDER_BY)],
 
93
                                          @_);
 
94
    $self->print_tree_count($print_count || 0);
 
95
    $self->bootstrap_style($style || $DefaultBootstrapStyle);
 
96
    $self->order_by($order_by) if defined $order_by;
 
97
    return;
 
98
}
 
99
 
83
100
 
84
101
=head2 next_tree
85
102
 
86
103
 Title   : next_tree
87
104
 Usage   : my $tree = $treeio->next_tree
88
105
 Function: Gets the next tree in the stream
89
 
 Returns : Bio::Tree::TreeI
 
106
 Returns : L<Bio::Tree::TreeI>
90
107
 Args    : none
91
108
 
92
109
 
97
114
   local $/ = ";\n";
98
115
   return unless $_ = $self->_readline;
99
116
   s/[\r\n]//gs;
 
117
   my $score;
100
118
   my $despace = sub {my $dirty = shift; $dirty =~ s/\s+//gs; return $dirty};
101
119
   my $dequote = sub {my $dirty = shift; $dirty =~ s/^"?\s*(.+?)\s*"?$/$1/; return $dirty};
102
120
   s/([^"]*)(".+?")([^"]*)/$despace->($1) . $dequote->($2) . $despace->($3)/egsx;
 
121
   if( s/^\s*\[([^\]]+)\]// ) {
 
122
       my $match = $1;
 
123
       $match =~ s/\s//g;
 
124
       $match =~ s/lh\=//;
 
125
       if( $match =~ /([-\d\.+]+)/ ) {
 
126
           $score = $1;
 
127
       }
 
128
   }
103
129
 
104
130
   $self->debug("entry is $_\n");
105
131
#   my $empty = chr(20);
115
141
   $self->_eventHandler->start_document;
116
142
   my ($prev_event,$lastevent,$id) = ('','','');
117
143
   foreach my $ch ( split(//,$_) ) {
118
 
       if( $ch eq ';' ) {          
119
 
           return $self->_eventHandler->end_document;
 
144
       if( $ch eq ';' ) {
 
145
           my $tree = $self->_eventHandler->end_document($chars);
 
146
           $tree->score($score) if defined $score;
 
147
           return $tree;
120
148
       } elsif( $ch eq '(' ) {
121
149
           $chars = '';
122
150
           $self->_eventHandler->start_element( {'Name' => 'tree'} );
128
156
                   $self->_eventHandler->end_element( {'Name' => 'branch_length'});
129
157
                   $lastevent = $prev_event;
130
158
               } else { 
131
 
                   $self->debug("id with no branchlength is $chars\n");
 
159
                   $self->debug("internal node, id with no branchlength is $chars\n");
132
160
                   $self->_eventHandler->start_element( { 'Name' => 'node' } );
133
161
                   $self->_eventHandler->start_element( { 'Name' => 'id' } );
134
162
                   $self->_eventHandler->characters($chars);
148
176
               $self->_eventHandler->start_element( {'Name' => 'node'} );
149
177
           }
150
178
 
151
 
           $self->_eventHandler->end_element( {'Name' => 'node'} );
 
179
           $self->_eventHandler->end_element( {'Name' => 'node'} );
152
180
           $self->_eventHandler->end_element( {'Name' => 'tree'} );
153
181
           $chars = '';
154
182
       } elsif ( $ch eq ',' ) {
160
188
                   $lastevent = $prev_event;
161
189
                   $chars = '';            
162
190
               } else { 
163
 
                   $self->debug("id with no branchlength is $chars\n");
 
191
                   $self->debug("leaf id with no branchlength is $chars\n");
164
192
                   $self->_eventHandler->start_element( { 'Name' => 'node' } );
165
193
                   $self->_eventHandler->start_element( { 'Name' => 'id' } );
166
194
                   $self->_eventHandler->characters($chars);
195
223
       $prev_event = $lastevent;
196
224
       $lastevent = $ch;
197
225
   }
198
 
   return undef;
 
226
   return;
199
227
}
200
228
 
201
229
=head2 write_tree
204
232
 Usage   : $treeio->write_tree($tree);
205
233
 Function: Write a tree out to data stream in newick/phylip format
206
234
 Returns : none
207
 
 Args    : Bio::Tree::TreeI object
 
235
 Args    : L<Bio::Tree::TreeI> object
208
236
 
209
237
=cut
210
238
 
211
239
sub write_tree{
212
 
   my ($self,@trees) = @_;      
 
240
   my ($self,@trees) = @_;  
 
241
   my $orderby = $self->order_by;
 
242
   my $bootstrap_style = $self->bootstrap_style;
 
243
   if( $self->print_tree_count ){ 
 
244
       $self->_print(sprintf(" %d\n",scalar @trees));
 
245
   }
 
246
   my $nl = $self->newline_each_node;
213
247
   foreach my $tree( @trees ) {
214
 
       my @data = _write_tree_Helper($tree->get_root_node);
215
 
       if($data[-1] !~ /\)$/ ) {
216
 
           $data[0] = "(".$data[0];
217
 
           $data[-1] .= ")";
 
248
       my @data = _write_tree_Helper($tree->get_root_node,
 
249
                                     $bootstrap_style,
 
250
                                     $orderby,
 
251
                                     $nl);
 
252
       if( $nl ) {
 
253
           chomp($data[-1]);# remove last newline
 
254
           $self->_print(join(",\n", @data), ";\n");
 
255
       } else {
 
256
           $self->_print(join(',', @data), ";\n");
218
257
       }
219
 
       $self->_print(join(',', @data), ";\n");   
220
258
   }
221
259
   $self->flush if $self->_flush_on_write && defined $self->_fh;
222
260
   return;
223
261
}
224
262
 
225
263
sub _write_tree_Helper {
226
 
    my ($node) = @_;
 
264
    my ($node,$style,$orderby,$nl) = @_;
 
265
    $style = '' unless defined $style;
227
266
    return () if (!defined $node);
228
267
 
229
268
    my @data;
 
269
    foreach my $n ( $node->each_Descendent($orderby) ) {
 
270
        push @data, _write_tree_Helper($n,$style,$orderby,$nl);
 
271
    }
230
272
    
231
 
    foreach my $n ( $node->each_Descendent() ) {
232
 
        push @data, _write_tree_Helper($n);
233
 
    }
234
 
 
235
 
    if( @data > 1 ) {
236
 
        $data[0] = "(" . $data[0];
237
 
        $data[-1] .= ")";
238
 
        # let's explicitly write out the bootstrap if we've got it
239
 
        my $b;
240
 
        if( defined ($b = $node->bootstrap) ) {
241
 
            $data[-1] .= $b;
242
 
        } elsif( defined ($b = $node->id) ) {
243
 
            $data[-1] .= $b;
244
 
        }
245
 
        $data[-1] .= ":". $node->branch_length if( defined $node->branch_length);
246
 
        
247
 
    } else {
248
 
        if( defined $node->id || defined $node->branch_length ) { 
249
 
            push @data, sprintf("%s%s",
250
 
                                defined $node->id ? $node->id : '', 
251
 
                                defined $node->branch_length ? ":" .
252
 
                                $node->branch_length : '');
253
 
        }
 
273
    # let's explicitly write out the bootstrap if we've got it
 
274
    my $id = $node->id_output;
 
275
    my $bs = $node->bootstrap; # bs better not have any spaces?
 
276
    $bs =~ s/\s+//g if defined $bs;
 
277
    my $bl = $node->branch_length;
 
278
    if( @data ) {
 
279
        if( $nl ) {
 
280
            $data[0] = "(\n" . $data[0];
 
281
            $data[-1] .= ")\n";
 
282
        } else {
 
283
            $data[0] = "(" . $data[0];
 
284
            $data[-1] .= ")";
 
285
        }
 
286
 
 
287
        if( $node->is_Leaf ) { 
 
288
            $node->debug("node is a leaf!  This is unexpected...");
 
289
 
 
290
            $id ||= '';
 
291
            if( ! defined $bl || ! length($bl) ||
 
292
                ($style && $style =~ /nobranchlength/i) ) {
 
293
                $data[-1] .= $id;
 
294
            } elsif( defined $bl && length($bl) ) { 
 
295
                $data[-1] .= "$id:$bl";
 
296
            } else { 
 
297
                $data[-1] .= $id;
 
298
            }
 
299
        } else { 
 
300
            if( ! defined $bl || ! length($bl) ||
 
301
                ($style && $style =~ /nobranchlength/i) ) {
 
302
                
 
303
                if( defined $id || defined $bs ) {
 
304
                    $data[-1] .= defined $bs ? $bs : $id;
 
305
                }
 
306
            } elsif( $style =~ /molphy/i ) {
 
307
                if( defined $id ) {
 
308
                    $data[-1] .= $id;
 
309
                }
 
310
                if( $bl =~ /\#/) {
 
311
                    $data[-1] .= $bl;
 
312
                } else { 
 
313
                    $data[-1] .= ":$bl";
 
314
                }
 
315
                if( defined $bs ) { 
 
316
                    $data[-1] .= "[$bs]";
 
317
                }
 
318
            } else {
 
319
                # traditional style of 
 
320
                # ((A:1,B:2)81:3);   where 3 is internal node branch length
 
321
                #                    and 81 is bootstrap/node label
 
322
                if( defined $bs || defined $id ) {
 
323
                    $data[-1] .= defined $bs ? "$bs:$bl" : "$id:$bl";
 
324
                } elsif( $bl =~ /\#/ ) {
 
325
                    $data[-1] .= $bl;
 
326
                } else { 
 
327
                    $data[-1] .= ":$bl"; 
 
328
                }
 
329
            }
 
330
        }
 
331
    } elsif( defined $id || defined $bl ) {
 
332
        my $str;
 
333
        $id ||= '';
 
334
        if( ! defined $bl || ! length($bl) ||
 
335
            ($style && $style =~ /nobranchlength/i) ) {
 
336
            $str = $id;
 
337
        } elsif( defined $bl && length($bl) ) { 
 
338
            $str = "$id:$bl";
 
339
        } else { 
 
340
            $str = $id;
 
341
        }
 
342
        push @data, $str;
254
343
    }
255
344
    return @data;
256
345
}
257
346
 
 
347
=head2 print_tree_count
 
348
 
 
349
 Title   : print_tree_count
 
350
 Usage   : $obj->print_tree_count($newval)
 
351
 Function: Get/Set flag for printing out the tree count (paml,protml way)
 
352
 Returns : value of print_tree_count (a scalar)
 
353
 Args    : on set, new value (a scalar or undef, optional)
 
354
 
 
355
 
 
356
=cut
 
357
 
 
358
sub print_tree_count{
 
359
    my $self = shift;
 
360
    return $self->{'_print_tree_count'} = shift if @_;
 
361
    return $self->{'_print_tree_count'} || 0;
 
362
}
 
363
 
 
364
=head2 bootstrap_style
 
365
 
 
366
 Title   : bootstrap_style
 
367
 Usage   : $obj->bootstrap_style($newval)
 
368
 Function: A description of how bootstraps and branch lengths are
 
369
           written, as the ID part of the internal node or else in []
 
370
           in the branch length (Molphy-like; I am sure there is a
 
371
           better name for this but am not sure where to go for some
 
372
           sort of format documentation)
 
373
 
 
374
           If no branch lengths are requested then no bootstraps are usually
 
375
           written (unless someone REALLY wants this functionality...)
 
376
 
 
377
           Can take on strings which contain the possible values of
 
378
           'nobranchlength'   --> don't draw any branch lengths - this
 
379
                                  is helpful if you don't want to have to 
 
380
                                  go through and delete branch len on all nodes
 
381
           'molphy' --> draw bootstraps (100) like
 
382
                                  (A:0.11,B:0.22):0.33[100];
 
383
           'traditional' --> draw bootstraps (100) like
 
384
                                  (A:0.11,B:0.22)100:0.33;
 
385
 Returns : value of bootstrap_style (a scalar)
 
386
 Args    : on set, new value (a scalar or undef, optional)
 
387
 
 
388
 
 
389
=cut
 
390
 
 
391
sub bootstrap_style{
 
392
    my $self = shift;
 
393
    my $val = shift;
 
394
    if( defined $val ) {
 
395
 
 
396
        if( $val !~ /^nobranchlength|molphy|traditional/i ) {
 
397
            $self->warn("requested an unknown bootstrap style $val, expect one of nobranchlength,molphy,traditional, not updating value.  Default is $DefaultBootstrapStyle\n");
 
398
        } else { 
 
399
            $self->{'_bootstrap_style'} = $val;
 
400
        }
 
401
    }
 
402
    return $self->{'_bootstrap_style'} || $DefaultBootstrapStyle;
 
403
}
 
404
 
 
405
=head2 order_by
 
406
 
 
407
 Title   : order_by
 
408
 Usage   : $obj->order_by($newval)
 
409
 Function: Allow node order to be specified (typically "alpha")
 
410
           See L<Bio::Node::Node::each_Descendent()>
 
411
 Returns : value of order_by (a scalar)
 
412
 Args    : on set, new value (a scalar or undef, optional)
 
413
 
 
414
 
 
415
=cut
 
416
 
 
417
sub order_by {
 
418
    my $self = shift;
 
419
 
 
420
    return $self->{'order_by'} = shift if @_;
 
421
    return $self->{'order_by'};
 
422
}
258
423
 
259
424
1;