Bio/TreeIO/nhx.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::TreeIO::nhx
   4 #
   5 # Cared for by Aaron Mackey <amackey@virginia.edu>
   6 #
   7 # Copyright Aaron Mackey
   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::nhx - TreeIO implementation for parsing
  16     Newick/New Hampshire eXtendend (NHX) format.
  17
  18 =head1 SYNOPSIS
  19
  20   # do not use this module directly
  21   use Bio::TreeIO;
  22   my $treeio = Bio::TreeIO->new(-format => 'nhx', -file => 'tree.dnd');
  23   my $tree = $treeio->next_tree;
  24
  25 =head1 DESCRIPTION
  26
  27 This module handles parsing and writing of Newick/New Hampshire eXtended (NHX) format.
  28
  29 =head1 FEEDBACK
  30
  31 =head2 Mailing Lists
  32
  33 User feedback is an integral part of the evolution of this and other
  34 Bioperl modules. Send your comments and suggestions preferably to the
  35 Bioperl mailing list.  Your participation is much appreciated.
  36
  37   bioperl-l@bioperl.org                  - General discussion
  38   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  39
  40 =head2 Reporting Bugs
  41
  42 Report bugs to the Bioperl bug tracking system to help us keep track
  43 of the bugs and their resolution. Bug reports can be submitted viax the
  44 web:
  45
  46   http://bugzilla.open-bio.org/
  47
  48 =head1 AUTHOR - Aaron Mackey
  49
  50 Email amackey-at-virginia.edu
  51
  52 =head1 CONTRIBUTORS
  53
  54 Email jason-at-bioperl-dot-org
  55
  56 =head1 APPENDIX
  57
  58 The rest of the documentation details each of the object methods.
  59 Internal methods are usually preceded with a _
  60
  61 =cut
  62
  63
  64 # Let the code begin...
  65
  66
  67 package Bio::TreeIO::nhx;
  68 use strict;
  69
  70 # Object preamble - inherits from Bio::Root::Root
  71
  72 use Bio::Tree::NodeNHX;
  73 use Bio::Event::EventGeneratorI;
  74 #use XML::Handler::Subs;
  75
  76
  77 use base qw(Bio::TreeIO);
  78
  79 sub _initialize {
  80   my($self, %args) = @_;
  81   $args{-nodetype} ||= 'Bio::Tree::NodeNHX';
  82   $self->SUPER::_initialize(%args);
  83 }
  84
  85 =head2 next_tree
  86
  87  Title   : next_tree
  88  Usage   : my $tree = $treeio->next_tree
  89  Function: Gets the next tree in the stream
  90  Returns : Bio::Tree::TreeI
  91  Args    : none
  92
  93
  94 =cut
  95
  96 sub next_tree{
  97     my ($self) = @_;
  98     local $/ = ";\n";
  99     return unless $_ = $self->_readline;
 100     s/\s+//g;
 101     $self->debug("entry is $_\n");
 102     my $chars = '';
 103     $self->_eventHandler->start_document;
 104     my ($prev_event,$lastevent,$last_leaf_event) = ('','','');
 105     my @ch = split(//, $_);
 106     foreach my $ch  (@ch) {
 107         if( $ch eq ';' ) {
 108             $self->_eventHandler->in_element('node') &&
 109                 $self->_eventHandler->end_element( {'Name' => 'node'});
 110             return $self->_eventHandler->end_document;
 111         } elsif ($ch eq '[') {
 112             if ( length $chars ) {
 113                 if ( $lastevent eq ':' ) {
 114                     $self->_eventHandler->start_element( { Name => 'branch_length' } );
 115                     $self->_eventHandler->characters($chars);
 116                     $self->_eventHandler->end_element( { Name => 'branch_length' });
 117                     $lastevent = $prev_event;
 118                 } else {
 119                     $self->debug("id with no branchlength is $chars\n");
 120                     $self->_eventHandler->start_element( { 'Name' => 'node' } );
 121                     $self->_eventHandler->start_element( { 'Name' => 'id' } );
 122                     $self->_eventHandler->characters($chars);
 123                     $self->_eventHandler->end_element( { 'Name' => 'id' } );
 124                 }
 125             } else {
 126                 $self->_eventHandler->start_element( { Name => 'node' } );
 127             }
 128             my $leafstatus = ( $last_leaf_event ne ')' ) ? 1 : 0;
 129             $self->_eventHandler->start_element({'Name' => 'leaf'});
 130             $self->_eventHandler->characters($leafstatus);
 131             $self->_eventHandler->end_element({'Name' => 'leaf'});
 132             $chars = '';
 133
 134             $self->_eventHandler->start_element( { Name => 'nhx_tag' });
 135         } elsif( $ch eq '(' ) {
 136             $chars = '';
 137             $self->_eventHandler->start_element( {'Name' => 'tree'} );
 138         } elsif($ch eq ')' ) {
 139             if( length $chars ) {
 140                 if( $lastevent eq ':') {
 141                     unless ($self->_eventHandler->within_element('nhx_tag')) {
 142                         $self->_eventHandler->start_element( { 'Name' => 'branch_length'});
 143                         $self->_eventHandler->characters($chars);
 144                         $self->_eventHandler->end_element( {'Name' => 'branch_length'});
 145                     } else {
 146                         $self->throw("malformed input; end of node ) before ] found");
 147                     }
 148                 } else {
 149                     $self->debug("id with no branchlength is '$chars'\n");
 150                     $self->_eventHandler->start_element( { 'Name' => 'node' } );
 151                     $self->_eventHandler->start_element( { 'Name' => 'id' } );
 152                     $self->_eventHandler->characters($chars);
 153                     $self->_eventHandler->end_element( { 'Name' => 'id' } );
 154                 }
 155             } elsif ( $lastevent ne ']' ) {
 156                 $self->_eventHandler->start_element( {'Name' => 'node'} );
 157             }
 158             # problem here is that we need to detect if we coming up on
 159             # the end of a leaf node or a labeled internal node
 160             # each can have [] and each can have :, but only leaves are
 161             # NOT proceeded by a ')'
 162             # the [] events throw us off
 163             my $leafstatus = ( $last_leaf_event ne ')' ) ? 1 : 0;
 164             $self->_eventHandler->start_element({'Name' => 'leaf'});
 165             $self->_eventHandler->characters($leafstatus);
 166             $self->_eventHandler->end_element({'Name' => 'leaf'});
 167
 168             $self->_eventHandler->end_element( {'Name' => 'node'} );
 169             $self->_eventHandler->end_element( {'Name' => 'tree'} );
 170             $chars = '';
 171             $last_leaf_event = $ch;
 172
 173         } elsif ( $ch eq ',' ) {
 174             if( length $chars ) {
 175                 if( $lastevent eq ':' ) {
 176                     $self->_eventHandler->start_element( { 'Name' => 'branch_length'});
 177                     $self->_eventHandler->characters($chars);
 178                     $self->_eventHandler->end_element( {'Name' => 'branch_length'});
 179                     $lastevent = $prev_event;
 180                 } else {
 181                     $self->debug("id with no branchlength is $chars, last event was $lastevent\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                 }
 187             } elsif ( $lastevent ne ']' ) {
 188                 $self->_eventHandler->start_element( { 'Name' => 'node' } );
 189             }
 190             $self->_eventHandler->end_element( {'Name' => 'node'} );
 191             $chars = '';
 192             $last_leaf_event = $ch;
 193         } elsif( $ch eq ':' ) {
 194             if ($self->_eventHandler->within_element('nhx_tag')) {
 195                 if ($lastevent eq '=') {
 196                     $self->_eventHandler->start_element( { Name => 'tag_value' } );
 197                     $self->_eventHandler->characters($chars);
 198                     $self->_eventHandler->end_element( { Name => 'tag_value' } );
 199                     $chars = '';
 200                 } else {
 201                     if ($chars eq '&&NHX') {
 202                         $chars = ''; # get rid of &&NHX:
 203                     } else {
 204                         $self->throw("Unrecognized, non \&\&NHX string: >>$chars<<; lastevent is $lastevent");
 205                     }
 206                 }
 207             } elsif ($lastevent ne ']') {
 208                 $self->debug("id with a branchlength coming is $chars\n");
 209                 $self->_eventHandler->start_element( { 'Name' => 'node' } );
 210                 $self->_eventHandler->start_element( { 'Name' => 'id' } );
 211                 $self->_eventHandler->characters($chars);
 212                 $self->_eventHandler->end_element( { 'Name' => 'id' } );
 213                 $chars = '';
 214             }
 215         } elsif ( $ch eq '=' ) {
 216             if ($self->_eventHandler->within_element('nhx_tag')) {
 217                 $self->_eventHandler->start_element( { Name => 'tag_name' } );
 218                 $self->_eventHandler->characters($chars);
 219                 $self->_eventHandler->end_element( { Name => 'tag_name' } );
 220                 $chars = '';
 221             } else {
 222                 $chars .= $ch;
 223             }
 224         } elsif ( $ch eq ']' ) {
 225             if ($self->_eventHandler->within_element('nhx_tag') ) {
 226                 if( $lastevent eq '=' ) {
 227                     $self->_eventHandler->start_element( { Name => 'tag_value' } );
 228                     $self->_eventHandler->characters($chars);
 229                     $self->_eventHandler->end_element( { Name => 'tag_value' } );
 230                     $chars = '';
 231                     $self->_eventHandler->end_element( { Name => 'nhx_tag' } );
 232                 } else {
 233                     if ($chars ne '&&NHX') {
 234                         $self->throw("Unrecognized, non \&\&NHX string: >>$chars<<; lastevent is $lastevent");
 235                     }
 236                     $chars = '';
 237                     $self->_eventHandler->end_element( { Name => 'nhx_tag' } );
 238                 }
 239             } else {
 240                 $chars .= $ch;
 241                 next;
 242             }
 243         } else {
 244             $chars .= $ch;
 245             next;
 246         }
 247         $prev_event = $lastevent;
 248         $lastevent = $ch;
 249     }
 250     return;
 251 }
 252
 253 =head2 write_tree
 254
 255  Title   : write_tree
 256  Usage   : $treeio->write_tree($tree);
 257  Function: Write a tree out to data stream in nhx format
 258  Returns : none
 259  Args    : Bio::Tree::TreeI object
 260
 261 =cut
 262
 263 sub write_tree{
 264     my ($self,@trees) = @_;
 265     my $nl = $self->newline_each_node;
 266    foreach my $tree ( @trees ) {
 267        my @data = _write_tree_Helper($tree->get_root_node,$nl);
 268        # per bug # 1471 do not include enclosing brackets.
 269        # this is sort of cheating but it should work
 270        # remove first and last paren if the set ends in a paren
 271        if($data[-1] =~ s/\)$// ) {
 272            $data[0] =~ s/^\(//;
 273        }
 274        if( $nl ) {
 275            chomp($data[-1]);# remove last newline
 276            $self->_print(join(",\n", @data), ";\n");
 277        } else {
 278            $self->_print(join(',', @data), ";\n");
 279        }
 280    }
 281    $self->flush if $self->_flush_on_write && defined $self->_fh;
 282    return;
 283 }
 284
 285 sub _write_tree_Helper {
 286     my ($node,$nl) = @_;
 287     return () unless defined $node;
 288     # rebless
 289     $node = bless $node,'Bio::Tree::NodeNHX';
 290     my @data;
 291
 292     foreach my $n ( $node->each_Descendent() ) {
 293         push @data, _write_tree_Helper($n,$nl);
 294     }
 295
 296     if( @data > 1 ) {
 297         if( $nl ) {
 298             $data[0] = "(\n" . $data[0];
 299             $data[-1] .= ")\n";
 300         } else {
 301             $data[0] = "(" . $data[0];
 302             $data[-1] .= ")";
 303         }
 304
 305         my $id = $node->id;
 306         $data[-1] .= $id  if( defined $id );
 307         my $blen  = $node->branch_length;
 308         $data[-1] .= ":". $blen if $blen;
 309         # this is to not print out an empty NHX for the root node which is
 310         # a convience for how we get a handle to the whole tree
 311         my @tags = $node->get_all_tags;
 312         if( $node->ancestor || @tags ) {
 313             $data[-1] .= '[' .
 314                 join(":", "&&NHX",
 315                      map { "$_=" .join(',',$node->get_tag_values($_)) }
 316                      @tags ) . ']';
 317
 318         } else {
 319             if( $nl ) {
 320                 $data[0] = "(\n" . $data[0];
 321                 $data[-1] .= ")\n";
 322             } else {
 323                 $data[0] = "(" . $data[0];
 324                 $data[-1] .= ")";
 325             }
 326         }
 327     } else {
 328         push @data, $node->to_string; # a leaf
 329     }
 330     return @data;
 331 }
 332
 333
 334 1;