Bio/TreeIO/TreeEventBuilder.pm

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