1 # POD documentation - main docs before the code
5 Module which implements a newick string parser as a finite state
6 machine which enables it to parse the full Newick specification.
8 Taken largely from the Ensembl Compara file with the same name
9 (Bio::EnsEMBL::Compara::Graph::NewickParser), this module adapts the
10 parser to work with BioPerl's event handler-based parsing scheme.
12 This module is used by nhx.pm and newick.pm, and is NOT called
13 directly. Instead, both of those parsing modules extend this module in
14 order to gain access to the main parsing method.
19 use base qw(Bio::TreeIO Bio::TreeIO::NewickParser);
21 # in the next_tree method...
22 $self->parse_newick($_);
26 This module correctly parses the Newick and NHX formats, sending calls
27 to the BioPerl TreeEventHandler when appropriate in order to build and
28 populate the node objects.
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.
38 bioperl-l@bioperl.org - General discussion
39 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
43 Please direct usage questions or support issues to the mailing list:
45 I<bioperl-l@bioperl.org>
47 rather than to the module maintainer directly. Many experienced and
48 reponsive experts will be able look at the problem and quickly
49 address it. Please include a thorough description of the problem
50 with code and data examples if at all possible.
54 Report bugs to the Bioperl bug tracking system to help us keep track
55 of the bugs and their resolution. Bug reports can be submitted via the
58 https://github.com/bioperl/bioperl-live/issues
60 =head1 AUTHOR - Jessica Severin (EnsEMBL implementation), Greg Jordan (BioPerl adaptation)
64 package Bio
::TreeIO
::NewickParser
;
67 use base
qw(Bio::Root::Root);
73 $newick = $newick . ";" unless ($newick =~ m/;/);
76 my $debug = $self->verbose;
77 my $token = next_token
(\
$newick, "(;");
79 my $bracket_level = 0;
81 $self->_start('tree');
85 while(defined($token)) {
86 # backwards-compat. with 5.8.1, no Switch (but we hate if-elsif-ad-infinitum
87 if ($state == 1) { #new node
89 $self->_start('node');
91 $self->debug(" -> [$token]\n");
92 if($token eq '(') { #create new set
93 $self->debug(" create set\n") if($debug);
94 $token = next_token
(\
$newick, "[(:,)");
101 } elsif ($state == 2) { #naming a node
102 if(!($token =~ /[\[\:\,\)\;]/)) {
104 if (!$leaf_flag && $self->param('internal_node_id') eq 'bootstrap') {
105 $self->_start('bootstrap');
106 $self->_chars($token);
107 $self->_end('bootstrap');
112 $self->_chars($token);
115 $self->debug(" naming leaf\n") if ($debug);
116 $token = next_token
(\
$newick, "[:,);");
119 } elsif ($state == 3) { # optional : and distance
121 $token = next_token
(\
$newick, "[,);");
123 $self->_start('branch_length');
124 $self->_chars($token);
125 $self->_end('branch_length');
127 $token = next_token
(\
$newick, ",);"); #move to , or )
128 } elsif ($token eq '[') { # NHX tag without previous blength
129 $token .= next_token
(\
$newick, ",);");
132 } elsif ($state == 4) { # optional NHX tags
133 if($token =~ /\[\&\&NHX/) {
134 # careful: this regexp gets rid of all NHX wrapping in one step
136 $self->_start('nhx_tag');
137 $token =~ /\[\&\&NHX\:(\S+)\]/;
139 # NHX may be empty, presumably at end of file, just before ";"
140 my @attributes = split ':', $1;
141 foreach my $attribute (@attributes) {
142 $attribute =~ s/\s+//;
143 my($key,$value) = split '=', $attribute;
145 $self->_start('tag_name');
147 $self->_end('tag_name');
149 $self->_start('tag_value');
150 $self->_chars($value);
151 $self->_end('tag_value');
154 $self->_end('nhx_tag');
156 $token = next_token
(\
$newick, ",);"); #move to , or )
157 } elsif ($token =~ /\[/) {
158 # This is a hack to make AMPHORA2 work
159 if ($token =~ /\[(\S+)\]/) {
160 $self->_start('bootstrap');
162 $self->_end('bootstrap');
164 $token = next_token
(\
$newick, ",);"); }
166 } elsif ($state == 5) { # end node
171 $token = next_token
(\
$newick, "[:,);");
172 if (defined $token && $token eq '[') {
173 # It is possible to have anonymous internal nodes w/ no name
174 # and no blength but with NHX tags
176 # We use leaf_flag=0 to let the parser know that it's labeling an internal
177 # node. This affects how potential bootstrap values are handled in state 2.
185 } elsif($token eq ',') {
189 $token = next_token
(\
$newick, "[(:,)"); #can be un_blengthed nhx nodes
191 } elsif($token eq ';') {
193 $self->throw("parse error: unbalanced ()\n") if($bracket_level ne 0);
198 $token = next_token
(\
$newick, "(");
201 $self->debug("[$token]]\n");
202 $self->throw("parse error: expected ; or ) or ,\n");
204 } elsif ($state == 13) {
205 $self->throw("parse error: nothing expected after ;");
209 if ($self->_eventHandler->within_element('tree')) {
219 $self->_eventHandler->characters($chars);
226 $self->_eventHandler->start_element({Name
=>$name});
233 $self->_eventHandler->end_element({Name
=>$name});
240 $$string =~ s/^(\s)+//;
242 return undef unless(length($$string));
244 #print("input =>$$string\n");
245 #print("delim =>$delim\n");
248 my @delims = split(/ */, $delim);
249 foreach my $dl (@delims) {
250 my $pos = index($$string, $dl);
252 $index = $pos unless(defined($index));
253 $index = $pos if($pos<$index);
256 unless(defined($index)) {
257 # have to call as class here (this is not an instance method)
258 Bio
::Root
::Root
->throw("couldn't find delimiter $delim\n $$string");
264 $token = substr($$string,0,1);
265 $$string = substr($$string, 1);
267 $token = substr($$string, 0, $index);
268 $$string = substr($$string, $index);
271 #print(" token =>$token\n");
272 #print(" outstring =>$$string\n\n");