|
0
|
1 # $Id: newick.pm,v 1.13.2.4 2003/09/14 19:00:35 jason Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::TreeIO::newick
|
|
|
4 #
|
|
|
5 # Cared for by Jason Stajich <jason@bioperl.org>
|
|
|
6 #
|
|
|
7 # Copyright Jason Stajich
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10
|
|
|
11 # POD documentation - main docs before the code
|
|
|
12
|
|
|
13 =head1 NAME
|
|
|
14
|
|
|
15 Bio::TreeIO::newick - TreeIO implementation for parsing
|
|
|
16 Newick/New Hampshire/PHYLIP format.
|
|
|
17
|
|
|
18 =head1 SYNOPSIS
|
|
|
19
|
|
|
20 # do not use this module directly
|
|
|
21 use Bio::TreeIO;
|
|
|
22 my $treeio = new Bio::TreeIO(-format => 'newick',
|
|
|
23 -file => 't/data/LOAD_Ccd1.dnd');
|
|
|
24 my $tree = $treeio->next_tree;
|
|
|
25
|
|
|
26 =head1 DESCRIPTION
|
|
|
27
|
|
|
28 This module handles parsing and writing of Newick/PHYLIP/New Hampshire format.
|
|
|
29
|
|
|
30 =head1 FEEDBACK
|
|
|
31
|
|
|
32 =head2 Mailing Lists
|
|
|
33
|
|
|
34 User feedback is an integral part of the evolution of this and other
|
|
|
35 Bioperl modules. Send your comments and suggestions preferably to the
|
|
|
36 Bioperl mailing list. Your participation is much appreciated.
|
|
|
37
|
|
|
38 bioperl-l@bioperl.org - General discussion
|
|
|
39 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
40
|
|
|
41 =head2 Reporting Bugs
|
|
|
42
|
|
|
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:
|
|
|
46
|
|
|
47 bioperl-bugs@bioperl.org
|
|
|
48 http://bugzilla.bioperl.org/
|
|
|
49
|
|
|
50 =head1 AUTHOR - Jason Stajich
|
|
|
51
|
|
|
52 Email jason@bioperl.org
|
|
|
53
|
|
|
54 Describe contact details here
|
|
|
55
|
|
|
56 =head1 CONTRIBUTORS
|
|
|
57
|
|
|
58 Additional contributors names and emails here
|
|
|
59
|
|
|
60 =head1 APPENDIX
|
|
|
61
|
|
|
62 The rest of the documentation details each of the object methods.
|
|
|
63 Internal methods are usually preceded with a _
|
|
|
64
|
|
|
65 =cut
|
|
|
66
|
|
|
67
|
|
|
68 # Let the code begin...
|
|
|
69
|
|
|
70
|
|
|
71 package Bio::TreeIO::newick;
|
|
|
72 use vars qw(@ISA);
|
|
|
73 use strict;
|
|
|
74
|
|
|
75 # Object preamble - inherits from Bio::Root::Root
|
|
|
76
|
|
|
77 use Bio::TreeIO;
|
|
|
78 use Bio::Event::EventGeneratorI;
|
|
|
79 #use XML::Handler::Subs;
|
|
|
80
|
|
|
81
|
|
|
82 @ISA = qw(Bio::TreeIO );
|
|
|
83
|
|
|
84 =head2 next_tree
|
|
|
85
|
|
|
86 Title : next_tree
|
|
|
87 Usage : my $tree = $treeio->next_tree
|
|
|
88 Function: Gets the next tree in the stream
|
|
|
89 Returns : Bio::Tree::TreeI
|
|
|
90 Args : none
|
|
|
91
|
|
|
92
|
|
|
93 =cut
|
|
|
94
|
|
|
95 sub next_tree{
|
|
|
96 my ($self) = @_;
|
|
|
97 local $/ = ";\n";
|
|
|
98 return unless $_ = $self->_readline;
|
|
|
99 # s/\s+//g;
|
|
|
100 my $despace = sub {my $dirty = shift; $dirty =~ s/\s+//gs; return $dirty};
|
|
|
101 my $dequote = sub {my $dirty = shift; $dirty =~ s/^"?\s*(.+?)\s*"?$/$1/; return $dirty};
|
|
|
102 s/([^"]*)(".+?")([^"]*)/$despace->($1) . $dequote->($2) . $despace->($3)/egsx;
|
|
|
103 $self->debug("entry is $_\n");
|
|
|
104 # my $empty = chr(20);
|
|
|
105
|
|
|
106 # replace empty labels with a tag
|
|
|
107 # s/\(,/\($empty,/ig;
|
|
|
108 # s/,,/,$empty,/ig;
|
|
|
109 # s/,,/,/ig;
|
|
|
110 # s/,\)/,$empty\)/ig;
|
|
|
111 # s/\"/\'/ig;
|
|
|
112
|
|
|
113 my $chars = '';
|
|
|
114 $self->_eventHandler->start_document;
|
|
|
115 my ($prev_event,$lastevent,$id) = ('','','');
|
|
|
116 foreach my $ch ( split(//,$_) ) {
|
|
|
117 if( $ch eq ';' ) {
|
|
|
118 return $self->_eventHandler->end_document;
|
|
|
119 } elsif( $ch eq '(' ) {
|
|
|
120 $chars = '';
|
|
|
121 $self->_eventHandler->start_element( {'Name' => 'tree'} );
|
|
|
122 } elsif($ch eq ')' ) {
|
|
|
123 if( length $chars ) {
|
|
|
124 if( $lastevent eq ':' ) {
|
|
|
125 $self->_eventHandler->start_element( { 'Name' => 'branch_length'});
|
|
|
126 $self->_eventHandler->characters($chars);
|
|
|
127 $self->_eventHandler->end_element( {'Name' => 'branch_length'});
|
|
|
128 $lastevent = $prev_event;
|
|
|
129 } else {
|
|
|
130 $self->debug("id with no branchlength is $chars\n");
|
|
|
131 $self->_eventHandler->start_element( { 'Name' => 'node' } );
|
|
|
132 $self->_eventHandler->start_element( { 'Name' => 'id' } );
|
|
|
133 $self->_eventHandler->characters($chars);
|
|
|
134 $self->_eventHandler->end_element( { 'Name' => 'id' } );
|
|
|
135 $id = $chars;
|
|
|
136 }
|
|
|
137 my $leafstatus = 0;
|
|
|
138 if( $lastevent ne ')' ) {
|
|
|
139 $leafstatus = 1;
|
|
|
140 }
|
|
|
141
|
|
|
142 $self->_eventHandler->start_element({'Name' => 'leaf'});
|
|
|
143 $self->_eventHandler->characters($leafstatus);
|
|
|
144 $self->_eventHandler->end_element({'Name' => 'leaf'});
|
|
|
145 $id = '';
|
|
|
146 } else {
|
|
|
147 $self->_eventHandler->start_element( {'Name' => 'node'} );
|
|
|
148 }
|
|
|
149
|
|
|
150 $self->_eventHandler->end_element( {'Name' => 'node'} );
|
|
|
151 $self->_eventHandler->end_element( {'Name' => 'tree'} );
|
|
|
152 $chars = '';
|
|
|
153 } elsif ( $ch eq ',' ) {
|
|
|
154 if( $chars ) {
|
|
|
155 if( $lastevent eq ':' ) {
|
|
|
156 $self->_eventHandler->start_element( { 'Name' => 'branch_length'});
|
|
|
157 $self->_eventHandler->characters($chars);
|
|
|
158 $self->_eventHandler->end_element( {'Name' => 'branch_length'});
|
|
|
159 $lastevent = $prev_event;
|
|
|
160 $chars = '';
|
|
|
161 } else {
|
|
|
162 $self->debug("id with no branchlength is $chars\n");
|
|
|
163 $self->_eventHandler->start_element( { 'Name' => 'node' } );
|
|
|
164 $self->_eventHandler->start_element( { 'Name' => 'id' } );
|
|
|
165 $self->_eventHandler->characters($chars);
|
|
|
166 $self->_eventHandler->end_element( { 'Name' => 'id' } );
|
|
|
167 $id = $chars;
|
|
|
168 }
|
|
|
169 } else {
|
|
|
170 $self->_eventHandler->start_element( { 'Name' => 'node' } );
|
|
|
171 }
|
|
|
172 my $leafstatus = ( $lastevent ne ')' ) ? 1 : 0;
|
|
|
173
|
|
|
174 $self->_eventHandler->start_element({'Name' => 'leaf'});
|
|
|
175 $self->_eventHandler->characters($leafstatus);
|
|
|
176 $self->_eventHandler->end_element({'Name' => 'leaf'});
|
|
|
177 $self->_eventHandler->end_element( {'Name' => 'node'} );
|
|
|
178 $chars = '';
|
|
|
179 $id = '';
|
|
|
180 } elsif( $ch eq ':' ) {
|
|
|
181 $self->debug("id with a branchlength coming is $chars\n");
|
|
|
182 $self->_eventHandler->start_element( { 'Name' => 'node' } );
|
|
|
183 $self->_eventHandler->start_element( { 'Name' => 'id' } );
|
|
|
184 $self->_eventHandler->characters($chars);
|
|
|
185 $self->_eventHandler->end_element( { 'Name' => 'id' } );
|
|
|
186 $id = $chars;
|
|
|
187 $chars = '';
|
|
|
188 } else {
|
|
|
189 $chars .= $ch;
|
|
|
190 next;
|
|
|
191 }
|
|
|
192 $prev_event = $lastevent;
|
|
|
193 $lastevent = $ch;
|
|
|
194 }
|
|
|
195 return undef;
|
|
|
196 }
|
|
|
197
|
|
|
198 =head2 write_tree
|
|
|
199
|
|
|
200 Title : write_tree
|
|
|
201 Usage : $treeio->write_tree($tree);
|
|
|
202 Function: Write a tree out to data stream in newick/phylip format
|
|
|
203 Returns : none
|
|
|
204 Args : Bio::Tree::TreeI object
|
|
|
205
|
|
|
206 =cut
|
|
|
207
|
|
|
208 sub write_tree{
|
|
|
209 my ($self,@trees) = @_;
|
|
|
210 foreach my $tree( @trees ) {
|
|
|
211 my @data = _write_tree_Helper($tree->get_root_node);
|
|
|
212 if($data[-1] !~ /\)$/ ) {
|
|
|
213 $data[0] = "(".$data[0];
|
|
|
214 $data[-1] .= ")";
|
|
|
215 }
|
|
|
216 $self->_print(join(',', @data), ";\n");
|
|
|
217 }
|
|
|
218 $self->flush if $self->_flush_on_write && defined $self->_fh;
|
|
|
219 return;
|
|
|
220 }
|
|
|
221
|
|
|
222 sub _write_tree_Helper {
|
|
|
223 my ($node) = @_;
|
|
|
224 return () if (!defined $node);
|
|
|
225
|
|
|
226 my @data;
|
|
|
227
|
|
|
228 foreach my $n ( $node->each_Descendent() ) {
|
|
|
229 push @data, _write_tree_Helper($n);
|
|
|
230 }
|
|
|
231
|
|
|
232 if( @data > 1 ) {
|
|
|
233 $data[0] = "(" . $data[0];
|
|
|
234 $data[-1] .= ")";
|
|
|
235 # let's explicitly write out the bootstrap if we've got it
|
|
|
236 my $b;
|
|
|
237 if( defined ($b = $node->bootstrap) ) {
|
|
|
238 $data[-1] .= $b;
|
|
|
239 } elsif( defined ($b = $node->id) ) {
|
|
|
240 $data[-1] .= $b;
|
|
|
241 }
|
|
|
242 $data[-1] .= ":". $node->branch_length if( $node->branch_length);
|
|
|
243
|
|
|
244 } else {
|
|
|
245 if( defined $node->id || defined $node->branch_length ) {
|
|
|
246 push @data, sprintf("%s%s",
|
|
|
247 defined $node->id ? $node->id : '',
|
|
|
248 defined $node->branch_length ? ":" .
|
|
|
249 $node->branch_length : '');
|
|
|
250 }
|
|
|
251 }
|
|
|
252 return @data;
|
|
|
253 }
|
|
|
254
|
|
|
255
|
|
|
256 1;
|
