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