Bio::Phylo::Forest::Node - Node in a phylogenetic tree

 # some way to get nodes:
 use Bio::Phylo::IO;
 my $string = '((A,B),C);';
 my $forest = Bio::Phylo::IO->parse(
    -format => 'newick',
    -string => $string
 );

 # prints 'Bio::Phylo::Forest'
 print ref $forest;

 foreach my $tree ( @{ $forest->get_entities } ) {

    # prints 'Bio::Phylo::Forest::Tree'
    print ref $tree;

    foreach my $node ( @{ $tree->get_entities } ) {

       # prints 'Bio::Phylo::Forest::Node'
       print ref $node;

       # node has a parent, i.e. is not root
       if ( $node->get_parent ) {
          $node->set_branch_length(1);
       }

       # node is root
       else {
          $node->set_branch_length(0);
       }
    }
 }

 $Id: Node.pm 1660 2011-04-02 18:29:40Z rvos $

# $Id: Node.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::Forest::Node;
use strict;
use base qw'Bio::Phylo::Taxa::TaxonLinker Bio::Phylo::Listable';
use Bio::Phylo::Util::OptionalInterface 'Bio::Tree::NodeI';
use Bio::Phylo::Util::CONSTANT qw':objecttypes /looks_like/';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::NeXML::Writable;
use Bio::Phylo::Factory;
use Scalar::Util 'weaken';
no warnings 'recursion';
my $LOADED_WRAPPERS = 0;
{
    my $fac = Bio::Phylo::Factory->new;

    # logger singleton
    my $logger = __PACKAGE__->get_logger;

    # store type constant
    my ( $TYPE_CONSTANT, $CONTAINER_CONSTANT ) = ( _NODE_, _TREE_ );

    # @fields array necessary for object destruction
    my @fields = \( my ( %branch_length, %parent, %tree ) );

    sub new {

        # could be child class
        my $class = shift;

        # notify user
        $logger->info("constructor called for '$class'");

        # process bioperl args
        my %args = looks_like_hash @_;
        if ( exists $args{'-leaf'} ) {
            delete $args{'-leaf'};
        }
        if ( exists $args{'-id'} ) {
            my $name = $args{'-id'};
            delete $args{'-id'};
            $args{'-name'} = $name;
        }
        if ( exists $args{'-nhx'} ) {
            my $hash = $args{'-nhx'};
            delete $args{'-nhx'};
            $args{'-generic'} = $hash;
        }

        # 		if ( not exists $args{'-tag'} ) {
        # 			$args{'-tag'} = __PACKAGE__->_tag;
        # 		}
        # go up inheritance tree, eventually get an ID
        my $self = $class->SUPER::new(%args);
        if ( not $LOADED_WRAPPERS ) {
            eval do { local $/; <DATA> };
            $LOADED_WRAPPERS++;
        }
        return $self;
    }
    my $set_raw_parent = sub {
        my ( $self, $parent ) = @_;
        my $id = $self->get_id;
        $parent{$id} = $parent;    # XXX here we modify parent
        weaken $parent{$id} if $parent;
    };
    my $get_parent = sub {
        my $self = shift;
        return $parent{ $self->get_id };
    };
    my $get_children = sub { shift->get_entities };
    my $get_branch_length = sub {
        my $self = shift;
        return $branch_length{ $self->get_id };
    };
    my $set_raw_child = sub {
        my ( $self, $child, $i ) = @_;
        $i = $self->last_index + 1 if not defined $i or $i == -1;
        $self->insert_at_index( $child, $i );    # XXX here we modify children
    };

    sub new_from_bioperl {
        my ( $class, $bpnode ) = @_;
        my $node = $class->new;

        # copy name
        my $name = $bpnode->id;
        $node->set_name($name) if defined $name;

        # copy branch length
        my $branch_length = $bpnode->branch_length;
        $node->set_branch_length($branch_length) if defined $branch_length;

        # copy description
        my $desc = $bpnode->description;
        $node->set_desc($desc) if defined $desc;

        # copy bootstrap
        my $bootstrap = $bpnode->bootstrap;
        $node->set_score($bootstrap)
          if defined $bootstrap and looks_like_number $bootstrap;

        # copy other tags
        for my $tag ( $bpnode->get_all_tags ) {
            my @values = $bpnode->get_tag_values($tag);
            $node->set_generic( $tag => \@values );
        }
        return $node;
    }

    sub prune_child {
        my ( $self, $child ) = @_;
        $self->delete($child);
        return $self;
    }

    sub collapse {
        my $self = shift;

        # can't collapse root
        if ( my $parent = $self->get_parent ) {

            # can't collapse terminal nodes
            if ( my @children = @{ $self->get_children } ) {

                # add node's branch length to that of children
                my $length = $self->get_branch_length;
                for my $child (@children) {
                    if ( defined $length ) {
                        my $child_length = $child->get_branch_length || 0;
                        $child->set_branch_length( $length + $child_length );
                    }

                    # attach children to node's parent
                    $child->set_parent($parent);
                }

                # prune node from parent
                $parent->prune_child($self);

                # delete node from tree
                if ( my $tree = $self->_get_container ) {
                    $tree->delete($self);
                }
            }
            else {
                return $self;
            }
        }
        else {
            return $self;
        }
    }

    sub set_parent {
        my ( $self, $parent ) = @_;
        if ( $parent and looks_like_object $parent, $TYPE_CONSTANT ) {
            $parent->set_child($self);
        }
        elsif ( not $parent ) {
            $set_raw_parent->($self);
        }
        return $self;
    }

    sub set_first_daughter {
        my ( $self, $fd ) = @_;
        $self->set_child( $fd, 0 );
        return $self;
    }

    sub set_last_daughter {
        my ( $self, $ld ) = @_;
        $self->set_child( $ld, scalar @{ $self->get_children } );
        return $self;
    }

    sub set_previous_sister {
        my ( $self, $ps ) = @_;
        if ( $ps and looks_like_object $ps, $TYPE_CONSTANT ) {
            if ( my $parent = $self->get_parent ) {
                my $children = $parent->get_children;
                my $j        = 0;
              FINDSELF: for ( my $i = $#{$children} ; $i >= 0 ; $i-- ) {
                    if ( $children->[$i] == $self ) {
                        $j = $i - 1;
                        last FINDSELF;
                    }
                }
                $j = 0 if $j == -1;
                $parent->set_child( $ps, $j );
            }
        }
        return $self;
    }

    sub set_next_sister {
        my ( $self, $ns ) = @_;
        if ( $ns and looks_like_object $ns, $TYPE_CONSTANT ) {
            if ( my $parent = $self->get_parent ) {
                my $children = $parent->get_children;
                my $last     = scalar @{$children};
                my $j        = $last;
              FINDSELF: for my $i ( 0 .. $#{$children} ) {
                    if ( $children->[$i] == $self ) {
                        $j = $i + 1;
                        last FINDSELF;
                    }
                }
                $parent->set_child( $ns, $j );
            }
        }
        return $self;
    }

    sub set_child {
        my ( $self, $child, $i ) = @_;

        # bad args?
        if ( not $child or not looks_like_object $child, $TYPE_CONSTANT ) {
            return;
        }

        # maybe nothing to do?
        if (   not $child
            or $child->get_id == $self->get_id
            or $child->is_child_of($self) )
        {
            return $self;
        }

        # $child_parent is NEVER $self, see above
        my $child_parent = $child->get_parent;

        # child is ancestor: this is obviously problematic, because
        # now we're trying to set a node nearer to the root on the
        # same lineage as the CHILD of a descendant. Because they're
        # on the same lineage it's hard to see how this can be done
        # sensibly. The decision here is to do:
        # 	1. we prune what is to become the parent (now the descendant)
        #	   from its current parent
        #	2. we set this pruned node (and its descendants) as a sibling
        #	   of what is to become the child
        #	3. we prune what is to become the child from its parent
        #	4. we set that pruned child as the child of $self
        if ( $child->is_ancestor_of($self) ) {

            # step 1.
            my $parent_parent = $self->get_parent;
            $parent_parent->prune_child($self);

            # step 2.
            $set_raw_parent->( $self, $child_parent );    # XXX could be undef
            if ($child_parent) {
                $set_raw_child->( $child_parent, $self );
            }
        }

        # step 3.
        if ($child_parent) {
            $child_parent->prune_child($child);
        }
        $set_raw_parent->( $child, $self );

        # now do the insert, first make room by shifting later siblings right
        my $children = $self->get_children;
        if ( defined $i ) {
            for ( my $j = $#{$children} ; $j >= 0 ; $j-- ) {
                my $sibling = $children->[$j];
                $set_raw_child->( $self, $sibling, $j + 1 );
            }
        }

        # no index was supplied, child becomes last daughter
        else {
            $i = scalar @{$children};
        }

        # step 4.
        $set_raw_child->( $self, $child, $i );
        return $self;
    }

    sub set_branch_length {
        my ( $self, $bl ) = @_;
        my $id = $self->get_id;
        if ( defined $bl && looks_like_number $bl && !ref $bl ) {
            $branch_length{$id} = $bl;
        }
        elsif ( defined $bl && ( !looks_like_number $bl || ref $bl ) ) {
            throw 'BadNumber' => "Branch length \"$bl\" is a bad number";
        }
        elsif ( !defined $bl ) {
            $branch_length{$id} = undef;
        }
        return $self;
    }

    sub set_node_below {
        my $self = shift;

        # can't set node below root
        if ( $self->is_root ) {
            return;
        }

        # instantiate new node from $self's class
        my $new_node = ( ref $self )->new(@_);

        # attach new node to $child's parent
        my $parent = $self->get_parent;
        $parent->set_child($new_node);

        # insert new node in tree
        # 		if ( my $tree = $self->_get_container ) {
        # 			$tree->insert( $new_node );
        # 		}
        # attach $self to new node
        $new_node->set_child($self);

        # done
        return $new_node;
    }

    # Example tree to illustrate rerooting algorithm:
    #
    #  A     B     C     D     E     F
    #   \   /     /     /     /     /
    #    \_/     /     /     /     /
    #     1     /     /     /     /
    # new->\   /     /     /     /
    #       \_/     /     /     /
    #        2     /     /     /
    #         \   /     /     /
    #          \_/     /     /
    #           3     /     /
    #            \   /     /
    #             \_/     /
    #              4     /
    #               \   /
    #                \_/
    #                 5
    #                 |
    sub set_root_below {
        my $self             = shift;
        my %constructor_args = @_;
        $constructor_args{'-name'} = 'root' if not $constructor_args{'-name'};

        # $self is node 5, nothing to do,
        # can't place root below root
        if ( $self->is_root ) {
            return;
        }
        my @ancestors = @{ $self->get_ancestors };

        # if @ancestors = ( 5 ); i.e. $self is node 4
        # root is already below $self
        if ( scalar @ancestors == 1 ) {
            return;
        }

        # let's say $self is node 1, ancestors is:
        # ( 2, 3, 4, 5 ) -> ( 2, 3, 4 )
        my $root = pop @ancestors;

        # ( 2, 3, 4 ) -> ( 2, 3 )
        my $node_above_root = pop @ancestors;

        # collapse node 4
        $node_above_root->collapse;

        # ( 2, 3 ) -> ( 2, 3, 5 ); 4 doesn't exist anymore (collapsed)
        push @ancestors, $root;

        # ( 2, 3, 5 ) -> ( new, 2, 3, 5 )
        unshift @ancestors, $self->set_node_below(%constructor_args);

        # i.e. $self wasn't 3
        if ( scalar @ancestors > 2 ) {
            for ( my $i = $#ancestors ; $i >= 0 ; $i-- ) {

                # flip parent & child
                $ancestors[$i]->set_child( $ancestors[ $i + 1 ] );
            }
        }
        else {

            # XXX
            $logger->info("Incomplete implementation reached");
            $ancestors[0]->set_child( $ancestors[1] );
        }
        if ( my $tree = $self->get_tree ) {
            $tree->insert( $ancestors[0] );
        }
        return $ancestors[0];
    }

    # 	sub set_root_below {
    # 		my $node = shift;
    # 		if ( $node->get_ancestors ) {
    # 			my @ancestors = @{ $node->get_ancestors };
    #
    # 			# first collapse root
    # 			my $root = $ancestors[-1];
    # 			my $lineage_containing_node;
    # 			my @children = @{ $root->get_children };
    # 		  FIND_LINEAGE: for my $child (@children) {
    # 				if ( $child->get_id == $node->get_id ) {
    # 					$lineage_containing_node = $child;
    # 					last FIND_LINEAGE;
    # 				}
    # 				for my $descendant ( @{ $child->get_descendants } ) {
    # 					if ( $descendant->get_id == $node->get_id ) {
    # 						$lineage_containing_node = $child;
    # 						last FIND_LINEAGE;
    # 					}
    # 				}
    # 			}
    # 			for my $child (@children) {
    # 				next if $child->get_id == $lineage_containing_node->get_id;
    # 				$child->set_parent($lineage_containing_node);
    # 			}
    #
    # 			# now create new root as parent of $node
    # 			my $newroot = __PACKAGE__->new( '-name' => 'root' );
    # 			$node->set_parent($newroot);
    #
    # 			# update list of ancestors, want to get rid of old root
    # 			# at $ancestors[-1] and have new root as $ancestors[0]
    # 			unshift @ancestors, $newroot;
    # 			pop @ancestors;
    #
    # 			# update connections
    # 			for ( my $i = $#ancestors ; $i >= 1 ; $i-- ) {
    # 				$ancestors[$i]->set_parent( $ancestors[ $i - 1 ] );
    # 			}
    #
    # 			# delete root if part of tree, insert new
    # 			if ( my $tree = $node->_get_container ) {
    # 				$tree->delete($root);
    # 				$tree->insert($newroot);
    # 			}
    # 		}
    # 	}

    sub set_tree {
        my ( $self, $tree ) = @_;
        my $id = $self->get_id;
        if ($tree) {
            if ( looks_like_object $tree, $CONTAINER_CONSTANT ) {
                $tree{$id} = $tree;
                weaken $tree{$id};
            }
            else {
                throw 'ObjectMismatch' => "$tree is not a tree";
            }
        }
        else {
            $tree{$id} = undef;
        }
        return $self;
    }

    sub get_parent { return $get_parent->(shift) }

    sub get_first_daughter {
        return $_[0]->get_child(0);
    }

    sub get_last_daughter {
        return $_[0]->get_child(-1);
    }

    sub get_previous_sister {
        my ($self) = @_;
        my $ps;
        if ( my $parent = $self->get_parent ) {
            my $children = $parent->get_children;
          FINDSELF: for ( my $i = $#{$children} ; $i >= 1 ; $i-- ) {
                if ( $children->[$i] == $self ) {
                    $ps = $children->[ $i - 1 ];
                    last FINDSELF;
                }
            }
        }
        return $ps;
    }

    sub get_next_sister {
        my ($self) = @_;
        my $ns;
        if ( my $parent = $self->get_parent ) {
            my $children = $parent->get_children;
          FINDSELF: for my $i ( 0 .. $#{$children} ) {
                if ( $children->[$i] == $self ) {
                    $ns = $children->[ $i + 1 ];
                    last FINDSELF;
                }
            }
        }
        return $ns;
    }

    sub get_branch_length { return $get_branch_length->(shift) }

    sub get_ancestors {
        my $self = shift;
        my @ancestors;
        my $node = $self;
        if ( $node = $node->get_parent ) {
            while ($node) {
                push @ancestors, $node;
                $node = $node->get_parent;
            }
            return \@ancestors;
        }
        else {
            return;
        }
    }

    sub get_root {
        my $self = shift;
        if ( my $anc = $self->get_ancestors ) {
            return $anc->[-1];
        }
        else {
            return $self;
        }
    }

    sub get_farthest_node {
        my ( $self, $patristic ) = @_;
        my $criterion = $patristic ? 'patristic' : 'nodal';
        my $method = sprintf 'calc_%s_distance', $criterion;
        my $root = $self->get_root;
        if ( my $terminals = $root->get_terminals ) {
            my ( $furthest_distance, $furthest_node ) = (0);
            for my $tip ( @{$terminals} ) {
                my $distance = $self->$method($tip);
                if ( $distance > $furthest_distance ) {
                    $furthest_distance = $distance;
                    $furthest_node     = $tip;
                }
            }
            return $furthest_node;
        }
    }

    sub get_sisters {
        my $self    = shift;
        my $sisters = $self->get_parent->get_children;
        return $sisters;
    }

    sub get_children { return $get_children->(shift) }

    sub get_child {
        my ( $self, $i ) = @_;
        $i = 0 if not defined $i;
        my $children = $self->get_children;
        return $children->[$i];
    }

    sub get_descendants {
        my $self    = shift;
        my @current = ($self);
        my @desc;
        while ( $self->_desc(@current) ) {
            @current = $self->_desc(@current);
            push @desc, @current;
        }
        return \@desc;
    }

    sub _desc {
        my $self    = shift;
        my @current = @_;
        my @return;
        foreach (@current) {
            my $children = $_->get_children;
            if ($children) {
                push @return, @{$children};
            }
        }
        return @return;
    }

    sub get_terminals {
        my $self = shift;
        if ( $self->is_terminal ) {
            return [$self];
        }
        else {
            my @terminals;
            my $desc = $self->get_descendants;
            if ( @{$desc} ) {
                foreach ( @{$desc} ) {
                    if ( $_->is_terminal ) {
                        push @terminals, $_;
                    }
                }
            }
            return \@terminals;
        }
    }

    sub get_internals {
        my $self = shift;
        my @internals;
        my $desc = $self->get_descendants;
        if ( @{$desc} ) {
            foreach ( @{$desc} ) {
                if ( $_->is_internal ) {
                    push @internals, $_;
                }
            }
        }
        return \@internals;
    }

    sub get_mrca {
        my ( $self, $other_node ) = @_;
        my $self_anc  = $self->get_ancestors       || [$self];
        my $other_anc = $other_node->get_ancestors || [$other_node];
        for my $i ( 0 .. $#{$self_anc} ) {
            my $self_anc_id = $self_anc->[$i]->get_id;
            for my $j ( 0 .. $#{$other_anc} ) {
                if ( $self_anc_id == $other_anc->[$j]->get_id ) {
                    return $self_anc->[$i];
                }
            }
        }
        $logger->warn( "using " . $self_anc->[-1]->get_internal_name );
        return $self_anc->[-1];
    }

    sub get_leftmost_terminal {
        my $self     = shift;
        my $daughter = $self;
      FIRST_DAUGHTER: while ($daughter) {
            if ( my $grand_daughter = $daughter->get_first_daughter ) {
                $daughter = $grand_daughter;
                next FIRST_DAUGHTER;
            }
            else {
                last FIRST_DAUGHTER;
            }
        }
        return $daughter;
    }

    sub get_rightmost_terminal {
        my $self     = shift;
        my $daughter = $self;
      LAST_DAUGHTER: while ($daughter) {
            if ( my $grand_daughter = $daughter->get_last_daughter ) {
                $daughter = $grand_daughter;
                next LAST_DAUGHTER;
            }
            else {
                last LAST_DAUGHTER;
            }
        }
        return $daughter;
    }

    sub get_tree {
        my $self = shift;
        my $id   = $self->get_id;
        return $tree{$id};
    }

    sub get_subtree {
        my $self = shift;
        my $tree = $fac->create_tree;
        $self->visit_depth_first(
            '-pre' => sub {
                my $node  = shift;
                my $clone = $node->clone;
                $node->set_generic( 'clone' => $clone );
                $tree->insert($clone);
                if ( my $parent = $node->get_parent ) {
                    if ( my $pclone = $node->get_generic('clone') ) {
                        $clone->set_parent($pclone);
                    }
                    else {
                        $clone->set_parent;
                    }
                }
            },
            '-post' => sub {
                my $node = shift;
                my $gen  = $node->get_generic;
                delete $gen->{'clone'};
            }
        );
        return $tree->_analyze;
    }

    sub is_terminal {
        return !shift->get_first_daughter;
    }

    sub is_internal {
        return !!shift->get_first_daughter;
    }

    sub is_preterminal {
        my $self     = shift;
        my $children = $self->get_children;
        for my $child ( @{$children} ) {
            return 0 if $child->is_internal;
        }
        return !!scalar @{$children};
    }

    sub is_first {
        return !shift->get_previous_sister;
    }

    sub is_last {
        return !shift->get_next_sister;
    }

    sub is_root {
        return !shift->get_parent;
    }

    sub is_descendant_of {
        my ( $self, $ancestor ) = @_;
        my $ancestor_id = $ancestor->get_id;
        while ($self) {
            if ( my $parent = $self->get_parent ) {
                $self = $parent;
            }
            else {
                return;
            }
            if ( $self->get_id == $ancestor_id ) {
                return 1;
            }
        }
    }

    sub is_ancestor_of {
        my ( $self, $child ) = @_;
        if ( $child->is_descendant_of($self) ) {
            return 1;
        }
        else {
            return;
        }
    }

    sub is_sister_of {
        my ( $self, $sister ) = @_;
        my ( $self_parent, $sister_parent ) =
          ( $self->get_parent, $sister->get_parent );
        if (   $self_parent
            && $sister_parent
            && $self_parent->get_id == $sister_parent->get_id )
        {
            return 1;
        }
        else {
            return;
        }
    }

    sub is_child_of {
        my ( $self, $node ) = @_;
        if ( my $parent = $self->get_parent ) {
            return $parent->get_id == $node->get_id;
        }
        return 0;
    }

    sub is_outgroup_of {
        my ( $outgroup, $nodes ) = @_;
        for my $i ( 0 .. $#{$nodes} ) {
            for my $j ( ( $i + 1 ) .. $#{$nodes} ) {
                my $mrca = $nodes->[$i]->get_mrca( $nodes->[$j] );
                return if $mrca->is_ancestor_of($outgroup);
            }
        }
        return 1;
    }

    sub can_contain {
        my $self = shift;
        my $type = $self->_type;
        for (@_) {
            return 0 if $type != $_->_type;
        }
        return 1;
    }

    sub calc_path_to_root {
        my $self = shift;
        my $node = $self;
        my $path = 0;
        while ($node) {
            my $branch_length = $node->get_branch_length;
            if ( defined $branch_length ) {
                $path += $branch_length;
            }
            if ( my $parent = $node->get_parent ) {
                $node = $parent;
            }
            else {
                last;
            }
        }
        return $path;
    }

    sub calc_nodes_to_root {
        my $self = shift;
        my ( $nodes, $parent ) = ( 0, $self );
        while ($parent) {
            $nodes++;
            $parent = $parent->get_parent;
            if ($parent) {
                if ( my $cntr = $parent->calc_nodes_to_root ) {
                    $nodes += $cntr;
                    last;
                }
            }
        }
        return $nodes;
    }

    sub calc_max_nodes_to_tips {
        my $self    = shift;
        my $self_id = $self->get_id;
        my ( $nodes, $maxnodes ) = ( 0, 0 );
        foreach my $child ( @{ $self->get_terminals } ) {
            $nodes = 0;
            while ( $child && $child->get_id != $self_id ) {
                $nodes++;
                $child = $child->get_parent;
            }
            if ( $nodes > $maxnodes ) {
                $maxnodes = $nodes;
            }
        }
        return $maxnodes;
    }

    sub calc_min_nodes_to_tips {
        my $self    = shift;
        my $self_id = $self->get_id;
        my ( $nodes, $minnodes );
        foreach my $child ( @{ $self->get_terminals } ) {
            $nodes = 0;
            while ( $child && $child->get_id != $self_id ) {
                $nodes++;
                $child = $child->get_parent;
            }
            if ( !$minnodes || $nodes < $minnodes ) {
                $minnodes = $nodes;
            }
        }
        return $minnodes;
    }

    sub calc_max_path_to_tips {
        my $self = shift;
        my $id   = $self->get_id;
        my ( $length, $maxlength ) = ( 0, 0 );
        foreach my $child ( @{ $self->get_terminals } ) {
            $length = 0;
            while ( $child && $child->get_id != $id ) {
                my $branch_length = $child->get_branch_length;
                if ( defined $branch_length ) {
                    $length += $branch_length;
                }
                $child = $child->get_parent;
            }
            if ( $length > $maxlength ) {
                $maxlength = $length;
            }
        }
        return $maxlength;
    }

    sub calc_min_path_to_tips {
        my $self = shift;
        my $id   = $self->get_id;
        my ( $length, $minlength );
        foreach my $child ( @{ $self->get_terminals } ) {
            $length = 0;
            while ( $child && $child->get_id != $id ) {
                my $branch_length = $child->get_branch_length;
                if ( defined $branch_length ) {
                    $length += $branch_length;
                }
                $child = $child->get_parent;
            }
            if ( !$minlength ) {
                $minlength = $length;
            }
            if ( $length < $minlength ) {
                $minlength = $length;
            }
        }
        return $minlength;
    }

    sub calc_patristic_distance {
        my ( $self, $other_node ) = @_;
        my $patristic_distance;
        my $mrca    = $self->get_mrca($other_node);
        my $mrca_id = $mrca->get_id;
        while ( $self->get_id != $mrca_id ) {
            my $branch_length = $self->get_branch_length;
            if ( defined $branch_length ) {
                $patristic_distance += $branch_length;
            }
            $self = $self->get_parent;
        }
        while ( $other_node and $other_node->get_id != $mrca_id ) {
            my $branch_length = $other_node->get_branch_length;
            if ( defined $branch_length ) {
                $patristic_distance += $branch_length;
            }
            $other_node = $other_node->get_parent;
        }
        return $patristic_distance;
    }

    sub calc_nodal_distance {
        my ( $self, $other_node ) = @_;
        my $nodal_distance;
        my $mrca    = $self->get_mrca($other_node);
        my $mrca_id = $mrca->get_id;
        while ( $self and $self->get_id != $mrca_id ) {
            $nodal_distance++;
            $self = $self->get_parent;
        }
        while ( $other_node and $other_node->get_id != $mrca_id ) {
            $nodal_distance++;
            $other_node = $other_node->get_parent;
        }
        return $nodal_distance;
    }

 #$tree->visit_depth_first(
 #	'-pre'            => sub { print "pre: ",            shift->get_name, "\n" },
 #	'-pre_daughter'   => sub { print "pre_daughter: ",   shift->get_name, "\n" },
 #	'-post_daughter'  => sub { print "post_daughter: ",  shift->get_name, "\n" },
 #	'-in'             => sub { print "in: ",             shift->get_name, "\n" },
 #	'-pre_sister'     => sub { print "pre_sister: ",     shift->get_name, "\n" },
 #	'-post_sister'    => sub { print "post_sister: ",    shift->get_name, "\n" },
 #	'-post'           => sub { print "post: ",           shift->get_name, "\n" },
 #	'-order'          => 'ltr',
 #);
    sub visit_depth_first {
        my $self = shift;
        my %args = looks_like_hash @_;

# 		my @keys = qw(pre pre_daughter post_daughter in pre_sister post_sister post order with_relatives);
# 		my %permitted_keys = map { "-${_}" => 1 } @keys;
# 		for my $key ( keys %args ) {
# 			if ( not exists $permitted_keys{$key} ) {
# 				throw 'BadArgs' => "Can't use argument $key";
# 			}
# 			if ( $key ne "-with_relatives" or $key ne "-order" ) {
# 				if ( not looks_like_instance $args{$key}, 'CODE' ) {
# 					throw 'BadArgs' => "Argument $key must be a code reference";
# 				}
# 			}
# 		}
        if ( $args{'-order'} and $args{'-order'} =~ /^rtl$/i ) {
            $args{'-sister_method'}   = 'get_previous_sister';
            $args{'-daughter_method'} = 'get_last_daughter';
        }
        else {
            $args{'-sister_method'}   = 'get_next_sister';
            $args{'-daughter_method'} = 'get_first_daughter';
        }
        $self->_visit_depth_first(%args);
        return $self;
    }

    sub _visit_depth_first {
        my ( $node, %args ) = @_;
        my ( $daughter_method, $sister_method ) =
          @args{qw(-daughter_method -sister_method)};
        $args{'-pre'}->($node) if $args{'-pre'};
        if ( my $daughter = $node->$daughter_method ) {
            my @args = ($node);
            push @args, $daughter if $args{'-with_relatives'};
            $args{'-pre_daughter'}->(@args) if $args{'-pre_daughter'};
            $daughter->_visit_depth_first(%args);
            $args{'-post_daughter'}->(@args) if $args{'-post_daughter'};
        }
        else {
            $args{'-no_daughter'}->($node) if $args{'-no_daughter'};
        }
        $args{'-in'}->($node) if $args{'-in'};
        if ( my $sister = $node->$sister_method ) {
            my @args = ($node);
            push @args, $sister if $args{'-with_relatives'};
            $args{'-pre_sister'}->(@args) if $args{'-pre_sister'};
            $sister->_visit_depth_first(%args);
            $args{'-post_sister'}->(@args) if $args{'-post_sister'};
        }
        else {
            $args{'-no_sister'}->($node) if $args{'-no_sister'};
        }
        $args{'-post'}->($node) if $args{'-post'};
    }

    sub visit_breadth_first {
        my $self = shift;
        my %args = looks_like_hash @_;
        if ( $args{'-order'} and $args{'-order'} =~ /rtl/i ) {
            $args{'-sister_method'}   = 'get_previous_sister';
            $args{'-daughter_method'} = 'get_last_daughter';
        }
        else {
            $args{'-sister_method'}   = 'get_next_sister';
            $args{'-daughter_method'} = 'get_first_daughter';
        }
        $self->_visit_breadth_first(%args);
        return $self;
    }

    sub _visit_breadth_first {
        my ( $node, %args ) = @_;
        my ( $daughter_method, $sister_method ) =
          @args{qw(-daughter_method -sister_method)};
        $args{'-pre'}->($node) if $args{'-pre'};
        if ( my $sister = $node->$sister_method ) {
            $args{'-pre_sister'}->($node) if $args{'-pre_sister'};
            $sister->_visit_breadth_first(%args);
            $args{'-post_sister'}->($node) if $args{'-post_sister'};
        }
        else {
            $args{'-no_sister'}->($node) if $args{'-no_sister'};
        }
        $args{'-in'}->($node) if $args{'-in'};
        if ( my $daughter = $node->$daughter_method ) {
            $args{'-pre_daughter'}->($node) if $args{'-pre_daughter'};
            $daughter->_visit_breadth_first(%args);
            $args{'-post_daughter'}->($node) if $args{'-post_daughter'};
        }
        else {
            $args{'-no_daughter'}->($node) if $args{'-no_daughter'};
        }
        $args{'-post'}->($node) if $args{'-post'};
    }

    sub visit_level_order {
        my ( $self, $sub ) = @_;
        if ( looks_like_instance $sub, 'CODE' ) {
            my @queue = ($self);
            while (@queue) {
                my $node = shift @queue;
                $sub->($node);
                if ( my $children = $node->get_children ) {
                    push @queue, @{$children};
                }
            }
        }
        else {
            throw 'BadArgs' => "'$sub' not a CODE reference";
        }
        return $self;
    }

    sub clone {
        my $self = shift;
        $logger->info("cloning $self");
        my %subs = @_;

        # we'll clone relatives in the tree, so no raw copying
        $subs{'set_parent'}          = sub { };
        $subs{'set_first_daughter'}  = sub { };
        $subs{'set_last_daughter'}   = sub { };
        $subs{'set_next_sister'}     = sub { };
        $subs{'set_previous_sister'} = sub { };
        $subs{'set_child'}           = sub { };
        $subs{'insert'}              = sub { };
        return $self->SUPER::clone(%subs);
    }

    sub to_xml {
        my $self  = shift;
        my @nodes = ( $self, @{ $self->get_descendants } );
        my $xml   = '';

        # first write out the node elements
        for my $node (@nodes) {
            if ( my $taxon = $node->get_taxon ) {
                $node->set_attributes( 'otu' => $taxon->get_xml_id );
            }
            if ( $node->is_root ) {
                $node->set_attributes( 'root' => 'true' );
            }
            $xml .= "\n" . $node->get_xml_tag(1);
        }

        # then the rootedge?
        if ( my $length = shift(@nodes)->get_branch_length ) {
            my $edge = $fac->create_xmlwritable(
                '-tag'        => 'rootedge',
                '-attributes' => {
                    'target' => $self->get_xml_id,
                    'id'     => "edge" . $self->get_id,
                    'length' => $length
                }
            );
            $xml .= "\n" . $edge->get_xml_tag(1);
        }

        # then the subtended edges
        for my $node (@nodes) {
            my $length = $node->get_branch_length;
            my $edge   = $fac->create_xmlwritable(
                '-tag'        => 'edge',
                '-attributes' => {
                    'source' => $node->get_parent->get_xml_id,
                    'target' => $node->get_xml_id,
                    'id'     => "edge" . $node->get_id
                }
            );
            $edge->set_attributes( 'length' => $length ) if defined $length;
            $xml .= "\n" . $edge->get_xml_tag(1);
        }
        return $xml;
    }

    {
        my ( $root_id, $string );

        #no warnings 'uninitialized';
        sub to_newick {
            my $node = shift;
            my %args = @_;
            $root_id = $node->get_id if not $root_id;
            my $blformat = '%f';

            # first create the name
            my $name;
            if ( $node->is_terminal or $args{'-nodelabels'} ) {
                if ( not $args{'-tipnames'} ) {
                    $name = $node->get_nexus_name;
                }
                elsif ( $args{'-tipnames'} =~ /^internal$/i ) {
                    $name = $node->get_nexus_name;
                }
                elsif ( $args{'-tipnames'} =~ /^taxon/i and $node->get_taxon ) {
                    if ( $args{'-tipnames'} =~ /^taxon_internal$/i ) {
                        $name = $node->get_taxon->get_nexus_name;
                    }
                    elsif ( $args{'-tipnames'} =~ /^taxon$/i ) {
                        $name = $node->get_taxon->get_nexus_name;
                    }
                }
                else {
                    $name = $node->get_generic( $args{'-tipnames'} );
                }
                if ( $args{'-translate'}
                    and exists $args{'-translate'}->{$name} )
                {
                    $name = $args{'-translate'}->{$name};
                }
            }

            # now format branch length
            my $branch_length;
            if ( defined( $branch_length = $node->get_branch_length ) ) {
                if ( $args{'-blformat'} ) {
                    $blformat = $args{'-blformat'};
                }
                $branch_length = sprintf $blformat, $branch_length;
            }

            # now format nhx
            my $nhx;
            if ( $args{'-nhxkeys'} ) {
                my $sep;
                if ( $args{'-nhxstyle'} =~ /^mesquite$/i ) {
                    $sep = ',';
                    $nhx = '[%';
                }
                else {
                    $sep = ':';
                    $nhx = '[&&NHX:';
                }
                my @nhx;
                for my $i ( 0 .. $#{ $args{'-nhxkeys'} } ) {
                    my $key   = $args{'-nhxkeys'}->[$i];
                    my $value = $node->get_generic($key);
                    push @nhx, " $key = $value " if $value;
                }
                if (@nhx) {
                    $nhx .= join $sep, @nhx;
                    $nhx .= ']';
                }
                else {
                    $nhx = '';
                }
            }

            # recurse further
            if ( my $first_daughter = $node->get_first_daughter ) {
                $string .= '(';
                $first_daughter->to_newick(%args);
            }

            # append to growing newick string
            $string .= ')'                  if $node->get_first_daughter;
            $string .= $name                if defined $name;
            $string .= ':' . $branch_length if defined $branch_length;
            $string .= $nhx                 if $nhx;
            if ( $root_id == $node->get_id ) {
                undef $root_id;
                my $result = $string . ';';
                undef $string;
                return $result;
            }

            # recurse further
            elsif ( my $next_sister = $node->get_next_sister ) {
                $string .= ',';
                $next_sister->to_newick(%args);
            }
        }
    }

    sub to_dom {
        my ( $self, $dom ) = shift;
        $dom ||= $Bio::Phylo::NeXML::DOM::DOM;
        unless ( looks_like_object $dom, _DOMCREATOR_ ) {
            throw 'BadArgs' => 'DOM factory object not provided';
        }
        my @nodes = ( $self, @{ $self->get_descendants } );
        my @elts;

        # first write out the node elements
        for my $node (@nodes) {
            if ( my $taxon = $node->get_taxon ) {
                $node->set_attributes( 'otu' => $taxon->get_xml_id );
            }
            if ( $node->is_root ) {
                $node->set_attributes( 'root' => 'true' );
            }
            push @elts, $node->get_dom_elt($dom);
        }

        # then the rootedge?
        if ( my $length = shift(@nodes)->get_branch_length ) {
            my $target = $self->get_xml_id;
            my $id     = "edge" . $self->get_id;
            my $elt    = $dom->create_element(
                '-tag'        => 'rootedge',
                '-attributes' => {
                    'target' => $target,
                    'id'     => $id,
                    'length' => $length,
                }
            );
            push @elts, $elt;
        }

        # then the subtended edges
        for my $node (@nodes) {
            my $source = $node->get_parent->get_xml_id;
            my $target = $node->get_xml_id;
            my $id     = "edge" . $node->get_id;
            my $length = $node->get_branch_length;
            my $elt    = $dom->create_element(
                '-tag'        => 'edge',
                '-attributes' => {
                    'source' => $source,
                    'target' => $target,
                    'id'     => $id,
                }
            );
            $elt->set_attributes( 'length' => $length ) if ( defined $length );
            push @elts, $elt;
        }
        return @elts;
    }

    sub _cleanup {
        my $self = shift;
        my $id   = $self->get_id;
        for my $field (@fields) {
            delete $field->{$id};
        }
    }

    sub _type { $TYPE_CONSTANT }
    sub _tag  { 'node' }

    sub _container { $CONTAINER_CONSTANT }

    # podinherit_insert_token

}
1;
__DATA__

sub add_Descendent{
   my ( $self,$child ) = @_;
   $self->set_child( $child );
   return scalar @{ $self->get_children };
}

sub each_Descendent{
	my $self = shift;
	if ( my $children = $self->get_children ) {
		return @{ $children };
   	}
   	return;
}

sub get_all_Descendents{
	my $self = shift;
	if ( my $desc = $self->get_descendants ) {
		return @{ $desc };
	}
	return;
}

*get_Descendents = \&get_all_Descendents;

*is_Leaf = \&is_terminal;
*is_otu = \&is_terminal;

sub descendent_count{
	my $self = shift;
	my $count = 0;
	if ( my $desc = get_descendants ) {
		$count = scalar @{ $desc };
	}
	return $count;
}

sub height{ shift->calc_max_path_to_tips }

sub depth{ shift->calc_path_to_root }

sub branch_length{
	my $self = shift;
	if ( @_ ) {
		$self->set_branch_length(shift);
	}
	return $self->get_branch_length;
}

sub id {
    my $self = shift;
    if ( @_ ) {
    	$self->set_name(shift);
    }
    return $self->get_name;
}

sub internal_id { shift->get_id }

sub description {
	my $self = shift;
	if ( @_ ) {
		$self->set_desc(shift);
	}
	return $self->get_desc;
}

sub bootstrap {
	my ( $self, $bs ) = @_;
	if ( defined $bs && looks_like_number $bs ) {
		$self->set_score($bs);
	}
	return $self->get_score;
}

sub ancestor {
	my $self = shift;
	if ( @_ ) {
		$self->set_parent(shift);
	}
	return $self->get_parent;
}

sub invalidate_height { }

sub add_tag_value{
	my $self = shift;
	if ( @_ ) {
		my ( $key, $value ) = @_;
		$self->set_generic( $key, $value );
	}
	return 1;
}

sub remove_tag {
	my ( $self, $tag ) = @_;
	my %hash = %{ $self->get_generic };
	my $exists = exists $hash{$tag};
	delete $hash{$tag};
	$self->set_generic();
	$self->set_generic(%hash);
	return !!$exists;
}

sub remove_all_tags{ shift->set_generic() }

sub get_all_tags {
	my $self = shift;
	my %hash = %{ $self->get_generic };
	return keys %hash;
}

sub get_tag_values{
	my ( $self, $tag ) = @_;
	my $values = $self->get_generic($tag);
	return ref $values ? @{ $values } : $values;
}

sub has_tag{
	my ( $self, $tag ) = @_;
	my %hash = %{ $self->get_generic };
	return exists $hash{$tag};
}

sub id_output { shift->get_internal_name }