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

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

 Chengzhi Liang (liangc@umbi.umd.edu)
 Eugene Melamud (melamud@carb.nist.gov)
 Weigang Qiu (weigang@genectr.hunter.cuny.edu)
 Peter Yang (pyang@rice.edu)
 Thomas Hladish (tjhladish at yahoo)

 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)

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

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

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

 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

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

 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)

 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

 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

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

 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.

 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

 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 

 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

 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

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

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

 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

 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

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

######################################################
# 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 ##################

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{$_};
	}
}

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;
}

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

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;
}

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

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

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;
}

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

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

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

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

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;
}

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

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

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;
}

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;
}

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);
}

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

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
}

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;
}

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;
}

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;
}

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;
}

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

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

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;