File Coverage

blib/lib/Bio/NEXUS/TreesBlock.pm

Criterion	Covered	Total	%
statement	180	261	68.9
branch	33	68	48.5
condition	8	21	38.1
subroutine	28	34	82.3
pod	20	20	100.0
total	269	404	66.5

######################################################
# TreesBlock.pm
######################################################
# Author: Chengzhi Liang, Eugene Melamud, Weigang Qiu, Peter Yang, Thomas Hladish
# $Id: TreesBlock.pm,v 1.63 2007/09/24 04:52:14 rvos Exp $

#################### START POD DOCUMENTATION ##################

=head1 NAME

Bio::NEXUS::TreesBlock - Represents TREES block of a NEXUS file

=head1 SYNOPSIS

 if ( $type =~ /trees/i ) {
     $block_object = new Bio::NEXUS::TreesBlock( $block_type, $block, $verbose );
 }

=head1 DESCRIPTION

If a NEXUS block is a Trees Block, this module parses the block and stores the tree data.

=head1 FEEDBACK

All feedback (bugs, feature enhancements, etc.) are all greatly appreciated.

=head1 AUTHORS

 Chengzhi Liang ([e-mail])
 Eugene Melamud ([e-mail])
 Weigang Qiu ([e-mail])
 Peter Yang ([e-mail])
 Thomas Hladish (tjhladish at yahoo)

=head1 VERSION

$Revision: 1.63 $

=head1 METHODS

=cut

package Bio::NEXUS::TreesBlock;

use strict;
#use Carp; # XXX this is not used, might as well not import it!
#use Data::Dumper; # XXX this is not used, might as well not import it!
use Bio::NEXUS::Functions;
#use Bio::NEXUS::Node; # XXX loaded dynamically
#use Bio::NEXUS::Tree; # XXX loaded dynamically
use Bio::NEXUS::Block;
use Bio::NEXUS::Util::Exceptions 'throw';
use Bio::NEXUS::Util::Logger;
use vars qw(@ISA $VERSION $AUTOLOAD);
use Bio::NEXUS; $VERSION = $Bio::NEXUS::VERSION;

@ISA = qw(Bio::NEXUS::Block);
my $logger = Bio::NEXUS::Util::Logger->new;

my %factories = (
	'treetype' => __PACKAGE__->_load_module('Bio::NEXUS::Tree'),
	'nodetype' => __PACKAGE__->_load_module('Bio::NEXUS::Node'),
);

sub import {
	my $class = shift;
	my %args;
	if ( @_ ) {
		%args = @_;
	}
	for ( qw(treetype nodetype) ) {
		$factories{$_} = $class->_load_module( $args{$_} ) if $args{$_};
	}
}

=head2 new

 Title   : new
 Usage   : block_object = new Bio::NEXUS::TreesBlock($block_type, $commands, $verbose );
 Function: Creates a new Bio::NEXUS::TreesBlock object and automatically reads the file
 Returns : Bio::NEXUS::TreesBlock object
 Args    : type (string), the commands/comments to parse (array ref), and a verbose flag (0 or 1; optional)

=cut

sub new {
    my ( $class, $type, $commands, $verbose ) = @_;
    $logger->info("constructor called for $class");
    ( $type ||= lc $class ) =~ s/Bio::NEXUS::(.+)Block/$1/i;
    my $self = {
    	'type'     => $type,
    	'treetype' => $factories{'treetype'},
    	'nodetype' => $factories{'nodetype'},
    };
    bless $self, $class;
    if ( defined $commands and @{ $commands } ) {
    	$self->_parse_block( $commands, $verbose );
    }
    return $self;
}

=begin comment

 Title   : _parse_translate
 Usage   : $self->_parse_translate($buffer);
 Function: Process the 'translate' section of the Trees Block
 Returns : the translation hash ref
 Args    : the buffer to parse (string)

=end comment

=cut

sub _parse_translate {
    my ( $self, $buffer ) = @_;
    $buffer =~ s/,//g;
    my $translate = { @{ _parse_nexus_words($buffer) } };
    $self->{'translation'} = $translate;
    return $translate;
}

=begin comment

 Title   : _parse_tree
 Usage   : $self->_parse_tree($buffer);
 Function: Process the 'tree' section of the Trees Block
 Returns : none
 Args    : buffer (string)
 Method  : Separates the buffer by the equal sign (example:
           tree tree_name = tree_string)
           Creates a new Bio::NEXUS::Tree object, sets the name as the name
           and the tree as the tree. (duh)
           Retrieves list of nodes from the Bio::NEXUS::Tree object. For each node,
           checks to see if a translation is defined. If it is, then it
           performs the appropriate translation. If not, then it just leaves
           the name as it is. Then it adds itself to the list blockTrees.

=end comment

=cut

sub _parse_tree {
    my ( $self, $buffer, $verbose ) = @_;

    $logger->info("Entering tree");;
    my $tree       = $self->treetype->new();
    my @tree_words = @{ _parse_nexus_words($buffer) };

    # If there's an asterisk, set the 'default' attribute, then get rid of the asterisk
    if ( $tree_words[0] eq '*' ) {
        shift @tree_words;
        $tree->set_as_default();
    }

    # separate out the name of the tree and the '=' symbol
    my ( $name, $equals_symb ) = splice @tree_words, 0, 2;
    $tree->set_name($name);

    # mark the tree as unrooted if it's prepended with [&U]
    if ( lc $tree_words[0] eq lc '[&U]' ) {
        $logger->info("setting tree as unrooted");
        $tree->set_as_unrooted();
        shift @tree_words;
    }

    # if it's prepended with the rooted flag, nothing needs to change
    elsif ( lc $tree_words[0] eq lc '[&R]' ) {
        $logger->info("tree is rooted");
        shift @tree_words;
    }

	$logger->info("going to parse newick string");
    $tree->_parse_newick( \@tree_words );
    $logger->info($tree->as_string);

    my $nodes = $tree->get_nodes();
    for my $node (@$nodes) {
        if ( $node->is_otu() ) {    #check for translation
            $name = $node->get_name();
            $logger->info("node is terminal, setting translation '$name'");
            $node->set_name( $self->translate($name) );
        }
    }

    $self->add_tree($tree);
    return $tree;
}

=head2 treetype

 Title   : treetype
 Usage   : $block->treetype('Bio::NEXUS::Tree');
 Function: sets a tree type class to instantiate on parse
 Returns : none
 Args    : a tree class

=cut

sub treetype {
	my $self = shift;
	if ( @_ ) {
		$self->{'treetype'} = $self->_load_module(shift);
	}
	return $self->{'treetype'} || $self->_load_module('Bio::NEXUS::Tree');
}

=head2 nodetype

 Title   : nodetype
 Usage   : $block->nodetype('Bio::NEXUS::Node');
 Function: sets a node type class to instantiate on parse
 Returns : none
 Args    : a node class

=cut

sub nodetype {
	my $self = shift;
	if ( @_ ) {
		$self->{'nodetype'} = $self->_load_module(shift);
	}
	return $self->{'nodetype'} || $self->_load_module('Bio::NEXUS::Node');
}

=head2 clone

 Title   : clone
 Usage   : my $newblock = $block->clone();
 Function: clone a block object (shallow)
 Returns : Block object
 Args    : none

=cut

sub clone {
    my ($self) = @_;
    my $class = ref($self);
    my $TreesBlock = bless( { %{$self} }, $class );

    # clone trees
    my @trees = ();
    for my $tree ( @{ $self->get_trees() } ) {
        push @trees, $tree;
    }
    $TreesBlock->set_trees( \@trees );
    return $TreesBlock;
}

=head2 set_trees

 Title   : set_trees
 Usage   : $block->set_trees($trees);
 Function: Sets the list of trees (Bio::NEXUS::Tree objects)
 Returns : none
 Args    : ref to array of Bio::NEXUS::Tree objects

=cut

sub set_trees {
    my ( $self, $trees ) = @_;
    $self->{'blockTrees'} = $trees;
}

=head2 add_tree

 Title   : add_tree
 Usage   : $block->add_tree($tree);
 Function: Add trees (Bio::NEXUS::Tree object)
 Returns : none
 Args    : a Bio::NEXUS::Tree object

=cut

sub add_tree {
    my ( $self, $tree ) = @_;
    push @{ $self->{'blockTrees'} }, $tree;
}

=head2 add_tree_from_newick

 Title   : add_tree_from_newick
 Usage   : $block->add_tree_from_newick($newick_tree, $tree_name);
 Function: Add a tree (Bio::NEXUS::Tree object)
 Returns : none
 Args    : a tree string in newick format and a name for the tree (scalars)

=cut

sub add_tree_from_newick {
    my ( $self, $tree, $tree_name ) = @_;
    $tree = "$tree_name = $tree";
    $self->_parse_tree($tree);
    return;
}

=head2 get_trees

 Title   : get_trees
 Usage   : $block->get_trees();
 Function: Gets the list of trees (Bio::NEXUS::Tree objects) and returns it
 Returns : ref to array of Bio::NEXUS::Tree objects
 Args    : none

=cut

sub get_trees {
    my $self = shift;
    return $self->{'blockTrees'} || [];
}

=head2 get_tree

 Title   : get_tree
 Usage   : $block->get_tree($treename);
 Function: Gets the first tree (Bio::NEXUS::Tree object) that matches the name given or the first tree if $treename is not specified. If no tree matches, returns undef.
 Returns : a Bio::NEXUS::Tree object
 Args    : tree name or none

=cut

sub get_tree {
    my ( $self, $treename ) = @_;
    return $self->get_trees()->[0] unless $treename;
    for my $t ( @{ $self->get_trees() } ) {
        return $t if ( $t->get_name() =~ /^$treename/ );
    }
    return undef;
}

=head2 set_translate

 Title   : set_translate
 Usage   : $block->set_translate($translate);
 Function: Sets the hash of translates for nodes names
 Returns : none
 Args    : hash of translates

=cut

sub set_translate {
    my ( $self, $translate ) = @_;
    $self->{'translation'} = $translate;
}

=head2 translate

 Title   : translate
 Usage   : $self->translate($num);
 Function: Translates a number with its associated name.
 Returns : integer or string
 Args    : integer
 Method  : Returns the name associated with that number's translated name.
           If it can't find an association, returns the number.

=cut

sub translate {
    my ( $self, $num ) = @_;
    if ( defined $self->{'translation'}{$num} ) {
        return $self->{'translation'}{$num};
    }
    else {
        return $num;
    }
}

=head2 reroot_tree

 Title   : reroot_tree
 Usage   : $block->reroot_tree($outgroup,$root_position, $treename);
 Function: Reroot a tree using an OTU as new outgroup.
 Returns : none
 Args    : outgroup name, the distance before the root position and tree name

=cut

sub reroot_tree {
    my ( $self, $outgroup, $root_position, $treename ) = @_;
    if ( not defined $treename and not defined $outgroup ) {
    	throw 'BadArgs' => 'Need to specify a tree name and outgroup name for rerooting';
    }
    my $tree = $self->get_tree($treename);
    my @rerooted_trees;
    foreach my $tree ( @{ $self->get_trees() } ) {
        if ( $tree->get_name ne $treename ) {
            push @rerooted_trees, $tree;
        }
        else {
            push @rerooted_trees, $tree->reroot( $outgroup, $root_position );
        }
    }
    $self->set_trees( \@rerooted_trees );
    return $self;
}

=head2 reroot_all_trees

 Title   : reroot_all_trees
 Usage   : $block->reroot_all_trees($outgroup, $root_position);
 Function: Reroot all the trees in the treesblock tree. use an OTU as new outgroup
 Returns : none
 Args    : outgroup name and root position

=cut

sub reroot_all_trees {
    my ( $self, $outgroup, $root_position ) = @_;
    return if not defined $self->get_tree;
    my @rerooted_trees;
    foreach my $tree ( @{ $self->get_trees() } ) {
        push @rerooted_trees, $tree->reroot( $outgroup, $root_position );
    }
    $self->set_trees( \@rerooted_trees );
    return $self;
}

=head2 rename_otus

 Title   : rename_otus
 Usage   : $block->rename_otus(\%translation);
 Function: Renames nodes based on a translation hash
 Returns : none
 Args    : hash containing translation (e.g., { old_name => new_name} )
 Comments: nodes not included in translation hash are unaffected

=cut

sub rename_otus {
    my ( $self, $translate ) = @_;
    return if not defined $self->get_tree;
    for my $tree ( @{ $self->get_trees() } ) {
        my $nodes = $tree->get_nodes();
        for my $node (@$nodes) {
            my $name           = $node->get_name();
            my $translatedname = $translate->{$name};
            if ($translatedname) {
                $node->set_name($translatedname);
            }
        }
    }
    my $newnames = $self->get_tree()->get_node_names();
    $self->set_taxlabels($newnames);
}

=head2 select_otus

 Name    : select_otus
 Usage   : $nexus->select_otus(\@otunames);
 Function: select a subset of OTUs
 Returns : a new nexus object
 Args    : a ref to array of OTU names

=cut

sub select_otus {
    my ( $self, $otunames ) = @_;
    for my $tree ( @{ $self->get_trees() } ) {
        $tree->prune("@{$otunames}");
    }
    $self->set_taxlabels($otunames);
    return $self;
}

=head2 add_otu_clone

 Title   : add_otu_clone
 Usage   : ...
 Function: ...
 Returns : ...
 Args    : ...

=cut

sub add_otu_clone {
	my ( $self, $original_otu_name, $copy_otu_name ) = @_;
	# print "Warning: Bio::NEXUS::TreesBlock::add_otu_clone() method not fully implemented\n";

	# . iterate through all trees:
	foreach my $tree ( @{ $self->{'blockTrees'} }) {
		# . find the original node
		# if not found, something must be done !
		my $original_node = $tree->find($original_otu_name);
		print "TreesBlock::add_otu_clone(): original otu [$original_otu_name] was not found.\n" if (! defined $original_node);
		# . clone the node
		my $cloned_node = $original_node->clone();
		# . rename the new node
		$cloned_node->set_name($copy_otu_name);

		# find the parent of the original node, add to it a new
		# child that will be parent of both original and
		# clone nodes. Remove the original node from the
		# list of children of its original parent
		my $original_parent = $original_node->get_parent();

		foreach my $child ( @{ $original_parent->get_children() }) {
			# print "Child name: ", $child->get_name(), "\n";
			if ($child->get_name() eq $original_otu_name) {
				my $new_parent = $self->nodetype->new();

				$new_parent->set_length($original_node->get_length());

				$cloned_node->set_length(0);
				$original_node->set_length(0);

				$new_parent->add_child($cloned_node);
				$cloned_node->set_parent_node($new_parent);
				$new_parent->add_child($original_node);
				$original_node->set_parent_node($new_parent);

				$new_parent->set_parent_node($original_parent);
				$child = $new_parent;
				last;
			}
		}
	}

	# todo:
	# add the clone to {'translation'} if the original is also there
}

=head2 select_tree

 Name    : select_tree
 Usage   : $nexus->select_tree($treename);
 Function: select a tree
 Returns : a new nexus object
 Args    : a tree name

=cut

sub select_tree {
    my ( $self, $treename ) = @_;
    my @oldtrees = @{ $self->get_trees() };
    $self->set_trees();
    for my $tree (@oldtrees) {
        if ( $tree->get_name() eq $treename ) {
            $self->add_tree($tree);
            last;
        }
    }
    return $self;
}

=head2 select_subtree

 Name    : select_subtree
 Usage   : $nexus->select_subtree($inodename);
 Function: select a subtree
 Returns : a new nexus object
 Args    : an internal node name for subtree to be selected

=cut

sub select_subtree {
    my ( $self, $nodename, $treename ) = @_;
    if ( not $nodename ) {
    	throw 'BadArgs' => 'Need to specify an internal node name for subtree';
    }
    my $tree = $self->get_tree($treename);
    if ( not $tree ) {
    	throw 'BadArgs' => "Tree $treename not found.";
    }
    $tree = $tree->select_subtree($nodename);
    $self->set_trees();
    $self->add_tree($tree);
    $self->set_taxlabels( $tree->get_node_names() );

    return $self;
}

=head2 exclude_subtree

 Name    : exclude_subtree
 Usage   : $nexus->exclude_subtree($inodename);
 Function: remove a subtree
 Returns : a new nexus object
 Args    : an internal node for subtree to be removed

=cut

sub exclude_subtree {
    my ( $self, $nodename, $treename ) = @_;
    if ( not $nodename ) {
    	throw 'BadArgs' => 'Need to specify an internal node name for subtree';
    }

    my $tree = $self->get_tree($treename);
    if ( not $tree ) {
    	throw 'BadArgs' => "Tree $treename not found.";
    }

    $tree = $tree->exclude_subtree($nodename);
    $self->set_trees();
    $self->add_tree($tree);
    $self->set_taxlabels( $tree->get_node_names() );

    return $self;
}

=head2 equals

 Name    : equals
 Usage   : $nexus->equals($another);
 Function: compare if two NEXUS objects are equal
 Returns : boolean
 Args    : a NEXUS object

=cut

sub equals {
    my ( $self, $block ) = @_;
    if ( !Bio::NEXUS::Block::equals( $self, $block ) ) { return 0; }

    #    if ($self->get_type() ne $block->get_type()) {return 0;}
    my @trees1 = @{ $self->get_trees() };
    my @trees2 = @{ $block->get_trees() };
    if ( @trees1 != @trees2 ) { return 0; }
    @trees1 = sort { $a->get_name() cmp $b->get_name() } @trees1;
    @trees2 = sort { $a->get_name() cmp $b->get_name() } @trees2;
    for ( my $i = 0; $i < @trees1; $i++ ) {
        if ( !$trees1[$i]->equals( $trees2[$i] ) ) { return 0; }
    }
    return 1;
}

# method under testing
sub _equals_test {
    my ( $self, $block ) = @_;
    if ( !Bio::NEXUS::Block::equals( $self, $block ) ) { return 0; }

    #    if ($self->get_type() ne $block->get_type()) {return 0;}
    my @trees1 = @{ $self->get_trees() };
    my @trees2 = @{ $block->get_trees() };
    if ( @trees1 != @trees2 ) { return 0; }
    @trees1 = sort { $a->get_name() cmp $b->get_name() } @trees1;
    @trees2 = sort { $a->get_name() cmp $b->get_name() } @trees2;
    for ( my $i = 0; $i < @trees1; $i++ ) {
        if ( !$trees1[$i]->_equals_test( $trees2[$i] ) ) { return 0; }
    }
    return 1;
}

=begin comment

 Name    : _write
 Usage   : $block->_write($file_handle,verbose);
 Function: Writes Trees Block object into the filehandle or STDOUT
 Returns : none
 Args    : File handle for writing the trees and verbose option( 0 or 1).
           If file handle is empty then the output it written on STDOUT.

=end comment

=cut

sub _write {
    my ( $self, $fh, $verbose ) = @_;
    $fh ||= \*STDOUT;

    Bio::NEXUS::Block::_write( $self, $fh );
    $self->_write_trees( $fh, $verbose );
    print $fh "END;\n";
}

=begin comment

 Name    : _write_trees
 Usage   : $block->_write_trees($file_handle,verbose);
 Function: Writes trees in the object into the file handle or STDOUT as string.(used in $self->_write)
 Returns : none
 Args    : File handle for writing the trees and verbose option( 0 or 1).
           If file handle is empty then the output it written on STDOUT.

=end comment

=cut

sub _write_trees {
    my ( $self, $fh, $verbose ) = @_;
    $fh ||= \*STDOUT;

    for my $tree ( @{ $self->get_trees() } ) {
        print $fh "\tTREE ";
        if ( $tree->is_default() ) {
            print $fh "* ";
        }
        # tree name has to be protected if it contains quotations
        print $fh _nexus_formatted($tree->get_name()), " = ";
        if ( !$tree->is_rooted() ) {
            print $fh "[&U] ";
        }
        print $fh $tree->as_string(), "\n";
    }

}

sub AUTOLOAD {
    return if $AUTOLOAD =~ /DESTROY$/;
    my $package_name = __PACKAGE__ . '::';

    # The following methods are deprecated and are temporarily supported
    # via a warning and a redirection
    my %synonym_for = (

#        "${package_name}parse"      => "${package_name}_parse_tree",  # example
    );

    if ( defined $synonym_for{$AUTOLOAD} ) {
        $logger->warn("$AUTOLOAD() is deprecated; use $synonym_for{$AUTOLOAD}() instead");
        goto &{ $synonym_for{$AUTOLOAD} };
    }
    else {
        throw 'UnknownMethod' => "ERROR: Unknown method $AUTOLOAD called";
    }
    return;
}

1;