Bio/TreeIO/lintree.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::TreeIO::lintree
   4 #
   5 # Cared for by Jason Stajich <jason-at-bioperl-dot-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::lintree - Parser for lintree output trees
  16
  17 =head1 SYNOPSIS
  18
  19   # do not use directly, use through Bio::TreeIO
  20   use Bio::TreeIO;
  21   my $treeio = Bio::TreeIO->new(-format => 'lintree',
  22                                -file   => 't/data/crab.nj');
  23   my $tree = $treeio->next_tree;
  24
  25 =head1 DESCRIPTION
  26
  27 Parser for the lintree output which looks like this
  28
  29   13 sequences     1000 bootstraping
  30 1 A-salina
  31 2 C-vittat
  32 3 C-sp.
  33 4 L-aequit
  34 5 P-camtsc
  35 6 E-tenuim
  36 7 L-splend
  37 8 P-bernha
  38 9 P-acadia
  39 10 P-p(NE)
  40 11 P-p(GU)
  41 12 P-l(NE)
  42 13 P-l(GU)
  43  14 and   2        0.098857      1000
  44  14 and   3        0.127932      1000
  45  15 and   1        0.197471      1000
  46  15 and  14        0.029273       874
  47  16 and  10        0.011732      1000
  48  16 and  11        0.004529      1000
  49  17 and  12        0.002258      1000
  50  17 and  13        0.000428      1000
  51  18 and  16        0.017512      1000
  52  18 and  17        0.010824       998
  53  19 and   4        0.006534      1000
  54  19 and   5        0.006992      1000
  55  20 and  15        0.070461      1000
  56  20 and  18        0.030579       998
  57  21 and   8        0.003339      1000
  58  21 and   9        0.002042      1000
  59  22 and   6        0.011142      1000
  60  22 and  21        0.010693       983
  61  23 and  20        0.020714       996
  62  23 and  19        0.020350      1000
  63  24 and  23        0.008665       826
  64  24 and  22        0.013457       972
  65  24 and   7        0.025598      1000
  66
  67 See http://www.bio.psu.edu/People/Faculty/Nei/Lab/software.htm for access
  68 to the program and N Takezaki, A Rzhetsky, and M Nei, "Phylogenetic test
  69 of the molecular clock and linearized trees." Mol Biol Evol 12(5):823-33.
  70
  71 =head1 FEEDBACK
  72
  73 =head2 Mailing Lists
  74
  75 User feedback is an integral part of the evolution of this and other
  76 Bioperl modules. Send your comments and suggestions preferably to
  77 the Bioperl mailing list.  Your participation is much appreciated.
  78
  79   bioperl-l@bioperl.org                  - General discussion
  80   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  81
  82 =head2 Reporting Bugs
  83
  84 Report bugs to the Bioperl bug tracking system to help us keep track
  85 of the bugs and their resolution. Bug reports can be submitted via the
  86 web:
  87
  88   http://bugzilla.open-bio.org/
  89
  90 =head1 AUTHOR - Jason Stajich
  91
  92 Email jason-at-bioperl-dot-org
  93
  94 =head1 CONTRIBUTORS
  95
  96 Ideas and discussion from:
  97  Alan Christoffels
  98  Avril Coghlan
  99
 100 =head1 APPENDIX
 101
 102 The rest of the documentation details each of the object methods.
 103 Internal methods are usually preceded with a _
 104
 105 =cut
 106
 107
 108 # Let the code begin...
 109
 110
 111 package Bio::TreeIO::lintree;
 112 use vars qw(%Defaults);
 113 use strict;
 114
 115
 116 use base qw(Bio::TreeIO);
 117 $Defaults{'NodeType'} = "Bio::Tree::Node";
 118
 119 =head2 new
 120
 121  Title   : new
 122  Usage   : my $obj = Bio::TreeIO::lintree->new();
 123  Function: Builds a new Bio::TreeIO::lintree object
 124  Returns : an instance of Bio::TreeIO::lintree
 125  Args    : -nodetype => Node type to create [default Bio::Tree::Node]
 126
 127
 128 =cut
 129
 130 sub _initialize {
 131     my ($self,@args) = @_;
 132     $self->SUPER::_initialize(@args);
 133     my ($nodetype) = $self->_rearrange([qw(NODETYPE)],@args);
 134     $nodetype ||= $Defaults{'NodeType'};
 135     $self->nodetype($nodetype);
 136 }
 137
 138 =head2 next_tree
 139
 140  Title   : next_tree
 141  Usage   : my $tree = $treeio->next_tree
 142  Function: Gets the next tree in the stream
 143  Returns : Bio::Tree::TreeI
 144  Args    : none
 145
 146
 147 =cut
 148
 149 sub next_tree {
 150     my ($self) = @_;
 151     my $seentop = 0;
 152     my ($tipcount,%data,@nodes) = (0);
 153     my $nodetype = $self->nodetype;
 154
 155     while( defined( $_ = $self->_readline) ) {
 156         if( /^\s*(\d+)\s+sequences/ox ) {
 157             if( $seentop ) {
 158                 $self->_pushback($_);
 159                 last;
 160             }
 161             $tipcount = $1;
 162             $seentop = 1;
 163         } elsif( /^(\d+)\s+(\S+)\s*$/ox ) {
 164             # deal with setting an outgroup
 165             unless( defined $data{'outgroup'} ) {
 166                 $data{'outgroup'} = [$1,$2];
 167             }
 168             $nodes[$1 - 1] = { '-id' => $2 };
 169         } elsif( m/^\s*(\d+)\s+and\s+(\d+)\s+(\-?\d+\.\d+)(?:\s+(\d+))?/ox ) {
 170             my ($node,$descend,$blength,$bootstrap) = ( $1, $2, $3, $4 );
 171             # need to -- descend and node because
 172             # array is 0 based
 173             $node--;$descend--;
 174             $nodes[$descend]->{'-branch_length'} = $blength;
 175             $nodes[$descend]->{'-bootstrap'}     = $bootstrap; #? here
 176             $nodes[$node]->{'-id'} = $node+1;
 177             push @{$nodes[$node]->{'-d'}}, $descend;
 178
 179         } elsif( /\s+(\S+)\-distance was used\./ox ) {
 180             $data{'method'} = $1;
 181         } elsif( /\s*seed=(\d+)/ox ) {
 182             $data{'seed'} = $1;
 183         } elsif( m/^outgroup:\s+(\d+)\s+(\S+)/ox ) {
 184             $data{'outgroup'} = [$1,$2];
 185         }
 186     }
 187     if( @nodes ) {
 188         my @treenodes;
 189         foreach my $n ( @nodes ) {
 190             push @treenodes, $nodetype->new(%{$n});
 191         }
 192
 193         foreach my $tn ( @treenodes ) {
 194             my $n = shift @nodes;
 195             for my $ptr ( @{ $n->{'-d'} || [] } ) {
 196                 $tn->add_Descendent($treenodes[$ptr]);
 197             }
 198         }
 199         my $T = Bio::Tree::Tree->new(-root => (pop @treenodes) );
 200         if( $data{'outgroup'} ) {
 201             my ($outgroup) = $treenodes[$data{'outgroup'}->[0]];
 202             if( ! defined $outgroup) {
 203                 $self->warn("cannot find '". $data{'outgroup'}->[1]. "'\n");
 204             } else {
 205                 $T->reroot($outgroup->ancestor);
 206             }
 207         }
 208         return $T;
 209     }
 210     return; # if there are no more trees, return undef
 211
 212 }
 213
 214 =head2 nodetype
 215
 216  Title   : nodetype
 217  Usage   : $obj->nodetype($newval)
 218  Function:
 219  Example :
 220  Returns : value of nodetype (a scalar)
 221  Args    : on set, new value (a scalar or undef, optional)
 222
 223
 224 =cut
 225
 226 sub nodetype{
 227    my ($self,$value) = @_;
 228    if( defined $value) {
 229        eval "require $value";
 230        if( $@ ) { $self->throw("$@: Unrecognized Node type for ".ref($self).
 231                                "'$value'");}
 232
 233        my $a = bless {},$value;
 234        unless( $a->isa('Bio::Tree::NodeI')  ) {
 235            $self->throw("Must provide a valid Bio::Tree::NodeI or child class to SeqFactory Not $value");
 236        }
 237       $self->{'nodetype'} = $value;
 238     }
 239    return $self->{'nodetype'};
 240 }
 241
 242 1;