Bio/TreeIO/TreeEventBuilder.pm

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