← Back to branch summary

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

« back to all changes in this revision

Viewing changes to Bio/TreeIO/nexus.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/nexus.pm
1
 
# $Id: nexus.pm,v 1.2 2003/12/06 18:10:26 jason Exp $
 
1
# $Id: nexus.pm,v 1.13.4.1 2006/10/02 23:10:37 sendu Exp $
2
2
#
3
3
# BioPerl module for Bio::TreeIO::nexus
4
4
#
34
34
Bioperl modules. Send your comments and suggestions preferably to
35
35
the Bioperl mailing list.  Your participation is much appreciated.
36
36
 
37
 
  bioperl-l@bioperl.org              - General discussion
38
 
  http://bioperl.org/MailList.shtml  - About the mailing lists
 
37
  bioperl-l@bioperl.org                  - General discussion
 
38
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
39
39
 
40
40
=head2 Reporting Bugs
41
41
 
43
43
of the bugs and their resolution. Bug reports can be submitted via
44
44
the web:
45
45
 
46
 
  http://bugzilla.bioperl.org/
 
46
  http://bugzilla.open-bio.org/
47
47
 
48
48
=head1 AUTHOR - Jason Stajich
49
49
 
50
50
Email jason-at-open-bio-dot-org
51
51
 
52
 
Describe contact details here
53
 
 
54
 
=head1 CONTRIBUTORS
55
 
 
56
 
Additional contributors names and emails here
57
 
 
58
52
=head1 APPENDIX
59
53
 
60
54
The rest of the documentation details each of the object methods.
67
61
 
68
62
 
69
63
package Bio::TreeIO::nexus;
70
 
use vars qw(@ISA);
71
64
use strict;
72
65
 
73
 
use Bio::TreeIO;
74
66
use Bio::Event::EventGeneratorI;
75
67
use IO::String;
76
68
 
77
 
@ISA = qw(Bio::TreeIO );
 
69
use base qw(Bio::TreeIO);
 
70
 
 
71
=head2 new
 
72
 
 
73
 Title   : new
 
74
 Args    : -header    => boolean  default is true 
 
75
                         print/do not print #NEXUS header
 
76
           -translate => boolean default is true
 
77
                         print/do not print Node Id translation to a number
 
78
 
 
79
=cut
 
80
 
 
81
sub _initialize { 
 
82
    my $self = shift;
 
83
    $self->SUPER::_initialize(@_);
 
84
    my ($hdr,$trans) = $self->_rearrange([qw(HEADER
 
85
                                             TRANSLATE)],
 
86
                                         @_);
 
87
    $self->header(defined $hdr ? $hdr : 1 );
 
88
    $self->translate_node(defined $trans ? $trans : 1);
 
89
}
78
90
 
79
91
 
80
92
=head2 next_tree
116
128
       $self->warn("File does not start with #NEXUS"); #'
117
129
           return;
118
130
   }
119
 
   my $state = 0;
 
131
 
 
132
   my $line;
120
133
   my %translate;
121
134
   while( defined ( $_ = $self->_readline ) ) {
122
 
       if( $state > 0 ) {          
123
 
           if( /^\[/ ) {
124
 
               $state++;
125
 
           } elsif( /^\]/ ) {
126
 
               $state--;
127
 
           } elsif( /^\s*Translate/ ) { 
128
 
               $state = 3;
129
 
           } elsif( $state == 3) {
130
 
               if( /^\s+(\S+)\s+(\S+)\,\s*$/ ) {
131
 
                   $translate{$1} = $2;
132
 
               } elsif( /^\s+;/) {
133
 
                   $state = 1;
134
 
               }
135
 
           } elsif( /^tree\s+(\S+)\s+\=\s+(?:\[\S+\])?\s+(.+\;)\s*$/ ) {
136
 
               my $buf = new IO::String($2);
137
 
               my $treeio = new Bio::TreeIO(-format => 'newick',
138
 
                                            -fh     => $buf);
139
 
               my $tree = $treeio->next_tree;
140
 
               foreach my $node ( grep { $_->is_Leaf } $tree->get_nodes ) {
141
 
                   my $id = $node->id;
142
 
                   my $lookup = $translate{$id};
143
 
                   $node->id($lookup || $id);
144
 
               }
145
 
               push @{$self->{'_trees'}},$tree;
146
 
           }
147
 
       } elsif( /^\s*Begin\s+trees;/i ) {
148
 
           $state = 1;
149
 
       } elsif( /^\s*End(\s+trees);/i ) {
150
 
           $state = 0;
151
 
           return;
152
 
       }
 
135
     $line .= $_;     
 
136
   }
 
137
   $line =~ s/\n/ /g;   
 
138
   my @sections = split(/#NEXUS/i, $line);
 
139
   for my $s ( @sections ) {
 
140
     if( $self->verbose > 0 ) {
 
141
       while( $s =~ s/(\[[^\]]+\])// ) {
 
142
         $self->debug("removing comment $1\n");
 
143
       }
 
144
     } else {
 
145
       $s =~ s/(\[[^\]]+\])//g;
 
146
     }
 
147
     if( $s =~ /begin trees;(.+)(end;)?/i ) {
 
148
       my $trees = $1;
 
149
       if( $trees =~ s/\s+translate\s+([^;]+);//i )  {
 
150
         my $trans = $1;
 
151
         for my $n ( split(/\s*,\s*/,$trans) ) {
 
152
           my ($id,$tag) = split(/\s+/,$n);
 
153
           $translate{$id} = $tag;
 
154
         }
 
155
       } else {
 
156
         $self->debug("no translate in: $trees\n");
 
157
       }
 
158
       while( $trees =~ /\s+tree\s+(\S+)\s*\=
 
159
                         \s*(?:\[\S+\])?\s*([^\;]+;)\s*/igx) {
 
160
         my ($tree_name,$tree_str) = ($1,$2);
 
161
         
 
162
         # MrBayes does not print colons for node label
 
163
         # $tree_str =~ s/\)(\d*\.\d+)\)/:$1/g;
 
164
         my $buf = new IO::String($tree_str);      
 
165
         my $treeio = new Bio::TreeIO(-format => 'newick',
 
166
                                      -fh     => $buf);
 
167
         my $tree = $treeio->next_tree;
 
168
         foreach my $node ( grep { $_->is_Leaf } $tree->get_nodes ) {
 
169
           my $id = $node->id;
 
170
           my $lookup = $translate{$id};
 
171
           $node->id($lookup || $id);
 
172
         }
 
173
         $tree->id($tree_name) if defined $tree_name;
 
174
         push @{$self->{'_trees'}},$tree;
 
175
       }       
 
176
     } else {
 
177
       $self->debug("begin_trees failed: $s\n");
 
178
     }
 
179
   }
 
180
   if( ! @sections ) {     
 
181
     $self->debug("warn no sections: $line\n");
153
182
   }
154
183
}
155
184
 
166
195
=cut
167
196
 
168
197
sub write_tree{
169
 
   my ($self,$tree) = @_;
170
 
   $self->throw("Cannot call method write_tree on Bio::TreeIO object must use a subclass");
171
 
}
172
 
 
 
198
   my ($self,@trees) = @_;
 
199
   if ( $self->header ) {
 
200
       $self->_print("#NEXUS\n\n");
 
201
   }
 
202
   my $translate = $self->translate_node;
 
203
   my $time = localtime();
 
204
   $self->_print(sprintf("Begin trees; [Treefile created %s]\n",$time));
 
205
 
 
206
   my ($first,$nodecter,%node2num) = (0,1);
 
207
   foreach my $tree ( @trees ) {
 
208
       
 
209
       if( $first == 0 && 
 
210
           $translate ) { 
 
211
           $self->_print("\tTranslate\n");
 
212
           $self->_print(join(",\n",
 
213
                              map { $node2num{$_->id} = $nodecter;
 
214
                                  sprintf("\t\t%d %s",$nodecter++,$_->id) }
 
215
                              grep { $_->is_Leaf } $tree->get_nodes),
 
216
                         "\n;\n");
 
217
       }
 
218
       my @data = _write_tree_Helper($tree->get_root_node,\%node2num);
 
219
       if($data[-1] !~ /\)$/ ) {
 
220
           $data[0] = "(".$data[0];
 
221
           $data[-1] .= ")";
 
222
       }
 
223
       # by default all trees in bioperl are currently rooted
 
224
       # something we'll try and fix one day....
 
225
       $self->_print(sprintf("\t tree %s = [&%s] %s;\n",
 
226
                             ($tree->id || 
 
227
                              sprintf("Bioperl_%d",$first+1)),
 
228
                             ( $tree->get_root_node ) ? 'R' : 'U',
 
229
                             join(',', @data)));
 
230
       $first++;
 
231
   }
 
232
   $self->_print("End;\n");
 
233
   $self->flush if $self->_flush_on_write && defined $self->_fh;
 
234
   return;
 
235
}
 
236
 
 
237
sub _write_tree_Helper {
 
238
    my ($node,$node2num) = @_;
 
239
    return () if (!defined $node);
 
240
    my @data;
 
241
    
 
242
    foreach my $n ( $node->each_Descendent() ) {
 
243
        push @data, _write_tree_Helper($n,$node2num);
 
244
    }
 
245
    if( @data > 1 ) {
 
246
        $data[0] = "(" . $data[0];
 
247
        $data[-1] .= ")";
 
248
        # let's explicitly write out the bootstrap if we've got it
 
249
        my $b;
 
250
        
 
251
        my $bl = $node->branch_length;
 
252
        if( ! defined $bl ) {
 
253
        } elsif($bl =~ /\#/ ) { 
 
254
         $data[-1] .= $bl;
 
255
        } else { 
 
256
         $data[-1] .= ":$bl";
 
257
        }
 
258
        if( defined ($b = $node->bootstrap) ) {     
 
259
            $data[-1] .= sprintf("[%s]",$b);
 
260
        } elsif( defined ($b = $node->id) ) {
 
261
            $b = $node2num->{$b} if( $node2num->{$b} ); # translate node2num
 
262
            $data[-1] .= sprintf("[%s]",$b);
 
263
        }
 
264
 
 
265
    } else {
 
266
        if( defined $node->id || defined $node->branch_length ) { 
 
267
            my $id= defined $node->id ? $node->id : '';
 
268
            if( length($id) && $node2num->{$id} ) {
 
269
                $id = $node2num->{$id};         
 
270
            }
 
271
            push @data, sprintf("%s%s",$id,
 
272
                                defined $node->branch_length ? ":" .
 
273
                                $node->branch_length : '');
 
274
        }
 
275
    }
 
276
    return @data;
 
277
}
 
278
 
 
279
=head2 header
 
280
 
 
281
 Title   : header
 
282
 Usage   : $obj->header($newval)
 
283
 Function: 
 
284
 Example : 
 
285
 Returns : value of header (a scalar)
 
286
 Args    : on set, new value (a scalar or undef, optional)
 
287
 
 
288
 
 
289
=cut
 
290
 
 
291
sub header{
 
292
    my $self = shift;
 
293
 
 
294
    return $self->{'header'} = shift if @_;
 
295
    return $self->{'header'};
 
296
}
 
297
 
 
298
=head2 translate_node
 
299
 
 
300
 Title   : translate_node
 
301
 Usage   : $obj->translate_node($newval)
 
302
 Function: 
 
303
 Example : 
 
304
 Returns : value of translate_node (a scalar)
 
305
 Args    : on set, new value (a scalar or undef, optional)
 
306
 
 
307
 
 
308
=cut
 
309
 
 
310
sub translate_node{
 
311
    my $self = shift;
 
312
 
 
313
    return $self->{'translate_node'} = shift if @_;
 
314
    return $self->{'translate_node'};
 
315
}
173
316
 
174
317
1;