Bio/TreeIO/TreeEventBuilder.pm

   1 #
   2 # BioPerl module for Bio::TreeIO::TreeEventBuilder
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Jason Stajich <jason@bioperl.org>
   7 #
   8 # Copyright Jason Stajich
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::TreeIO::TreeEventBuilder - Build Bio::Tree::Tree's and
  17   Bio::Tree::Node's from Events
  18
  19 =head1 SYNOPSIS
  20
  21 # internal use only
  22
  23 =head1 DESCRIPTION
  24
  25 This object will take events and build a Bio::Tree::TreeI compliant
  26 object makde up of Bio::Tree::NodeI objects.
  27
  28 =head1 FEEDBACK
  29
  30 =head2 Mailing Lists
  31
  32 User feedback is an integral part of the evolution of this and other
  33 Bioperl modules. Send your comments and suggestions preferably to
  34 the Bioperl mailing list.  Your participation is much appreciated.
  35
  36   bioperl-l@bioperl.org                  - General discussion
  37   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  38
  39 =head2 Support
  40
  41 Please direct usage questions or support issues to the mailing list:
  42
  43 I<bioperl-l@bioperl.org>
  44
  45 rather than to the module maintainer directly. Many experienced and
  46 reponsive experts will be able look at the problem and quickly
  47 address it. Please include a thorough description of the problem
  48 with code and data examples if at all possible.
  49
  50 =head2 Reporting Bugs
  51
  52 Report bugs to the Bioperl bug tracking system to help us keep track
  53 of the bugs and their resolution. Bug reports can be submitted via the
  54 web:
  55
  56   https://github.com/bioperl/bioperl-live/issues
  57
  58 =head1 AUTHOR - Jason Stajich
  59
  60 Email jason-at-bioperl.org
  61
  62 =head1 APPENDIX
  63
  64 The rest of the documentation details each of the object methods.
  65 Internal methods are usually preceded with a _
  66
  67 =cut
  68
  69
  70 # Let the code begin...
  71
  72
  73 package Bio::TreeIO::TreeEventBuilder;
  74 use strict;
  75
  76 use Bio::Tree::Tree;
  77 use Bio::Tree::Node;
  78
  79 use base qw(Bio::Root::Root Bio::Event::EventHandlerI);
  80
  81 =head2 new
  82
  83  Title   : new
  84  Usage   : my $obj = Bio::TreeIO::TreeEventBuilder->new();
  85  Function: Builds a new Bio::TreeIO::TreeEventBuilder object
  86  Returns : Bio::TreeIO::TreeEventBuilder
  87  Args    :
  88
  89
  90 =cut
  91
  92 sub new {
  93   my($class,@args) = @_;
  94
  95   my $self = $class->SUPER::new(@args);
  96   my ($treetype, $nodetype) = $self->_rearrange([qw(TREETYPE
  97                                                     NODETYPE)], @args);
  98   $treetype ||= 'Bio::Tree::Tree';
  99   $nodetype ||= 'Bio::Tree::Node';
 100
 101   eval {
 102       $self->_load_module($treetype);
 103       $self->_load_module($nodetype);
 104   };
 105
 106   if( $@ ) {
 107       $self->throw("Could not load module $treetype or $nodetype. \n$@\n")
 108   }
 109   $self->treetype($treetype);
 110   $self->nodetype($nodetype);
 111   $self->{'_treelevel'} = 0;
 112   return $self;
 113 }
 114
 115 =head2 treetype
 116
 117  Title   : treetype
 118  Usage   : $obj->treetype($newval)
 119  Function:
 120  Returns : value of treetype
 121  Args    : newvalue (optional)
 122
 123
 124 =cut
 125
 126 sub treetype{
 127    my ($self,$value) = @_;
 128    if( defined $value) {
 129       $self->{'treetype'} = $value;
 130     }
 131     return $self->{'treetype'};
 132 }
 133
 134 =head2 nodetype
 135
 136  Title   : nodetype
 137  Usage   : $obj->nodetype($newval)
 138  Function:
 139  Returns : value of nodetype
 140  Args    : newvalue (optional)
 141
 142
 143 =cut
 144
 145 sub nodetype{
 146    my ($self,$value) = @_;
 147    if( defined $value) {
 148       $self->{'nodetype'} = $value;
 149     }
 150     return $self->{'nodetype'};
 151 }
 152
 153
 154 =head2 SAX methods
 155
 156 =cut
 157
 158 =head2 start_document
 159
 160  Title   : start_document
 161  Usage   : $handler->start_document
 162  Function: Begins a Tree event cycle
 163  Returns : none
 164  Args    : none
 165
 166 =cut
 167
 168 sub start_document {
 169    my ($self) = @_;
 170    $self->{'_lastitem'} = {};
 171    $self->{'_currentitems'} = [];
 172    $self->{'_currentnodes'} = [];
 173    return;
 174 }
 175
 176 =head2 end_document
 177
 178  Title   : end_document
 179  Usage   : my @trees = $parser->end_document
 180  Function: Finishes a Phylogeny cycle
 181  Returns : An array  Bio::Tree::TreeI
 182  Args    : none
 183
 184 =cut
 185
 186 sub end_document {
 187     my ($self,$label) = @_;
 188
 189     my ($root) = @{$self->{'_currentnodes'}};
 190
 191     $self->debug("Root node is " . $root->to_string()."\n");
 192     if( $self->verbose > 0 ) {
 193         foreach my $node ( $root->get_Descendents  ) {
 194             $self->debug("node is ". $node->to_string(). "\n");
 195         }
 196     }
 197     my $tree = $self->treetype->new(-verbose => $self->verbose,
 198                                     -root => $root);
 199     return $tree;
 200 }
 201
 202 =head2 start_element
 203
 204  Title   : start_element
 205  Usage   :
 206  Function:
 207  Example :
 208  Returns :
 209  Args    : $data => hashref with key 'Name'
 210
 211 =cut
 212
 213 sub start_element{
 214    my ($self,$data) =@_;
 215    $self->{'_lastitem'}->{$data->{'Name'}}++;
 216
 217    $self->debug("starting element: $data->{Name}\n");
 218    push @{$self->{'_lastitem'}->{'current'}},$data->{'Name'};
 219
 220    my %data;
 221
 222    if( $data->{'Name'} eq 'node' ) {
 223        push @{$self->{'_currentitems'}}, \%data;
 224        $self->{'_treelevel'}++;
 225    } elsif ( $data->{Name} eq 'tree' ) {
 226    }
 227 }
 228
 229 =head2 end_element
 230
 231  Title   : end_element
 232  Usage   :
 233  Function:
 234  Returns : none
 235  Args    : $data => hashref with key 'Name'
 236
 237 =cut
 238
 239 sub end_element{
 240    my ($self,$data) = @_;
 241
 242    $self->debug("end of element: $data->{Name}\n");
 243    # this is the stack where we push/pop items from it
 244    my $curcount = scalar @{$self->{'_currentnodes'}};
 245    my $level   = $self->{'_treelevel'};
 246    my $levelct = $self->{'_nodect'}->[$self->{'_treelevel'}+1] || 0;
 247
 248    if( $data->{'Name'} eq 'node' ) {
 249        my $tnode;
 250        my $node = pop @{$self->{'_currentitems'}};
 251
 252        $tnode = $self->nodetype->new( -verbose => $self->verbose,
 253                                       %{$node});
 254        $self->debug( "new node will be ".$tnode->to_string."\n");
 255        if ( !$node->{'-leaf'} && $levelct > 0) {
 256            $self->debug(join(',', map { $_->to_string }
 257                              @{$self->{'_currentnodes'}}). "\n");
 258            $self->throw("something wrong with event construction treelevel ".
 259                         "$level is recorded as having $levelct nodes  ".
 260                         "but current nodes at this level is $curcount\n")
 261                if( $levelct > $curcount);
 262            for ( splice( @{$self->{'_currentnodes'}}, - $levelct)) {
 263                $self->debug("adding desc: " . $_->to_string . "\n");
 264                $tnode->add_Descendent($_);
 265            }
 266            $self->{'_nodect'}->[$self->{'_treelevel'}+1] = 0;
 267        }
 268        push @{$self->{'_currentnodes'}}, $tnode;
 269        $self->{'_nodect'}->[$self->{'_treelevel'}]++;
 270
 271        $curcount = scalar @{$self->{'_currentnodes'}};
 272        $self->debug ("added node: count is now $curcount, treelevel: $level, nodect: $levelct\n");
 273
 274        $self->{'_treelevel'}--;
 275    } elsif(  $data->{'Name'} eq 'tree' ) {
 276        $self->debug("end of tree: nodes in stack is $curcount\n");
 277    }
 278
 279    $self->{'_lastitem'}->{ $data->{'Name'} }--;
 280    pop @{$self->{'_lastitem'}->{'current'}};
 281 }
 282
 283
 284 =head2 in_element
 285
 286  Title   : in_element
 287  Usage   :
 288  Function:
 289  Example :
 290  Returns :
 291  Args    :
 292
 293
 294 =cut
 295
 296 sub in_element{
 297    my ($self,$e) = @_;
 298
 299    return 0 if ! defined $self->{'_lastitem'} ||
 300        ! defined $self->{'_lastitem'}->{'current'}->[-1];
 301    return ($e eq $self->{'_lastitem'}->{'current'}->[-1]);
 302
 303 }
 304
 305 =head2 within_element
 306
 307  Title   : within_element
 308  Usage   :
 309  Function:
 310  Example :
 311  Returns :
 312  Args    :
 313
 314
 315 =cut
 316
 317 sub within_element{
 318    my ($self,$e) = @_;
 319    return $self->{'_lastitem'}->{$e};
 320 }
 321
 322 =head2 characters
 323
 324  Title   : characters
 325  Usage   : $handler->characters($text);
 326  Function: Processes characters
 327  Returns : none
 328  Args    : text string
 329
 330
 331 =cut
 332
 333 sub characters{
 334    my ($self,$ch) = @_;
 335    if( $self->within_element('node') ) {
 336        my $hash = pop @{$self->{'_currentitems'}};
 337        if( $self->in_element('bootstrap') ) {
 338            # leading/trailing Whitespace-B-Gone
 339            $ch =~ s/^\s+//; $ch =~ s/\s+$//;
 340            $hash->{'-bootstrap'} = $ch;
 341        } elsif( $self->in_element('branch_length') ) {
 342            # leading/trailing Whitespace-B-Gone
 343            $ch =~ s/^\s+//; $ch =~ s/\s+$//;
 344            $hash->{'-branch_length'} = $ch;
 345        } elsif( $self->in_element('id')  ) {
 346            $hash->{'-id'} = $ch;
 347        } elsif( $self->in_element('description') ) {
 348            $hash->{'-desc'} = $ch;
 349        } elsif ( $self->in_element('tag_name') ) {
 350            $hash->{'-NHXtagname'} = $ch;
 351        } elsif ( $self->in_element('tag_value') ) {
 352            $hash->{'-nhx'}->{$hash->{'-NHXtagname'}} = $ch;
 353            delete $hash->{'-NHXtagname'};
 354        } elsif( $self->in_element('leaf') ) {
 355            $hash->{'-leaf'} = $ch;
 356        }
 357        push @{$self->{'_currentitems'}}, $hash;
 358    }
 359    $self->debug("chars: $ch\n");
 360 }
 361
 362
 363 1;