1#
2# BioPerl module for Bio::Tree::NodeNHX
3#
4# Please direct questions and support issues to <bioperl-l@bioperl.org>
5#
6# Cared for by Aaron Mackey <amackey@virginia.edu>
7#
8# Copyright Aaron Mackey
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
16Bio::Tree::NodeNHX - A Simple Tree Node with support for NHX tags
17
18=head1 SYNOPSIS
19
20    use Bio::Tree::NodeNHX;
21    my $nodeA = Bio::Tree::NodeNHX->new();
22    my $nodeL = Bio::Tree::NodeNHX->new();
23    my $nodeR = Bio::Tree::NodeNHX->new();
24
25    my $node = Bio::Tree::NodeNHX->new();
26    $node->add_Descendents($nodeL);
27    $node->add_Descendents($nodeR);
28
29    print "node is not a leaf \n" if( $node->is_leaf);
30
31=head1 DESCRIPTION
32
33Makes a Tree Node with NHX tags, suitable for building a Tree.  See
34L<Bio::Tree::Node> for a full list of functionality.
35
36=head1 FEEDBACK
37
38=head2 Mailing Lists
39
40User feedback is an integral part of the evolution of this and other
41Bioperl modules. Send your comments and suggestions preferably to
42the Bioperl mailing list.  Your participation is much appreciated.
43
44  bioperl-l@bioperl.org                  - General discussion
45  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
46
47=head2 Support
48
49Please direct usage questions or support issues to the mailing list:
50
51I<bioperl-l@bioperl.org>
52
53rather than to the module maintainer directly. Many experienced and
54reponsive experts will be able look at the problem and quickly
55address it. Please include a thorough description of the problem
56with code and data examples if at all possible.
57
58=head2 Reporting Bugs
59
60Report bugs to the Bioperl bug tracking system to help us keep track
61of the bugs and their resolution. Bug reports can be submitted via
62the web:
63
64  https://github.com/bioperl/bioperl-live/issues
65
66=head1 AUTHOR - Aaron Mackey
67
68Email amackey@virginia.edu
69
70=head1 CONTRIBUTORS
71
72The NHX (New Hampshire eXtended) format was created by Chris Zmasek,
73and is described at:
74
75  http://sourceforge.net/projects/forester-atv/
76
77=head1 APPENDIX
78
79The rest of the documentation details each of the object methods.
80Internal methods are usually preceded with a _
81
82=cut
83
84
85# Let the code begin...
86
87package Bio::Tree::NodeNHX;
88$Bio::Tree::NodeNHX::VERSION = '1.7.7';
89use strict;
90
91
92use base qw(Bio::Tree::Node);
93
94=head2 new
95
96 Title   : new
97 Usage   : my $obj = Bio::Tree::NodeNHX->new();
98 Function: Builds a new Bio::Tree::NodeNHX object
99 Returns : Bio::Tree::NodeNHX
100 Args    : -left          => pointer to Left descendent (optional)
101           -right         => pointer to Right descenent (optional)
102	   -branch_length => branch length [integer] (optional)
103           -bootstrap     => bootstrap value (string)
104           -description   => description of node
105           -id            => unique id for node
106           -nhx           => hashref of NHX tags and values
107
108=cut
109
110sub new {
111  my($class,@args) = @_;
112
113  my $self = $class->SUPER::new(@args);
114  my ($nhx) = $self->_rearrange([qw(NHX)], @args);
115  $self->nhx_tag($nhx);
116  return $self;
117}
118
119sub DESTROY {
120    my ($self) = @_;
121    # try to insure that everything is cleaned up
122    $self->SUPER::DESTROY();
123    if( defined $self->{'_desc'} &&
124	ref($self->{'_desc'}) =~ /ARRAY/i ) {
125	while( my ($nodeid,$node) = each %{ $self->{'_desc'} } ) {
126	    $node->{'_ancestor'} = undef; # insure no circular references
127	    $node->DESTROY();
128	    $node = undef;
129	}
130	$self->{'_desc'} = {};
131    }
132}
133
134sub to_string{
135   my ($self) = @_;
136   my @tags = $self->get_all_tags;
137   my $tagstr = '';
138   if( scalar(@tags) > 0 ) {
139       $tagstr = '[' . join(":", "&&NHX",
140			    map { "$_=" .join(',',
141					      $self->get_tag_values($_))}
142			    @tags ) . ']';
143   }
144   return sprintf("%s%s%s",
145		  defined $self->id ? $self->id : '',
146		  defined $self->branch_length ? ':' .
147		  $self->branch_length : ' ',
148		  $tagstr);
149}
150
151=head2 nhx_tag
152
153 Title   : nhx_tag
154 Usage   : my $tag = $nodenhx->nhx_tag(%tags);
155 Function: Set tag-value pairs for NHX nodes
156 Returns : none
157 Args    : hashref to update the tags/value pairs
158           OR
159           with a scalar value update the bootstrap value by default
160
161
162=cut
163
164sub nhx_tag {
165    my ($self, $tags) = @_;
166    if (defined $tags && (ref($tags) =~ /HASH/i)) {
167	while( my ($tag,$val) = each %$tags ) {
168	    if( ref($val) =~ /ARRAY/i ) {
169		for my $v ( @$val ) {
170		    $self->add_tag_value($tag,$v);
171		}
172	    } else {
173		$self->add_tag_value($tag,$val);
174	    }
175	}
176	if (exists $tags->{'B'}) {
177	    $self->bootstrap($tags->{'B'});
178	}
179    } elsif (defined $tags and ! ref ($tags)) {
180	$self->debug( "here with $tags\n");
181        # bootstrap by default
182	$self->bootstrap($tags);
183    }
184}
185
1861;
187