Bio::Phylo::Forest::DrawTree - Tree with extra methods for tree drawing

 # see Bio::Phylo::Forest::Tree

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

package Bio::Phylo::Forest::DrawTree;
use strict;
use base 'Bio::Phylo::Forest::Tree';
use Bio::Phylo::Forest::DrawNode;
use Bio::Phylo::Util::CONSTANT 'looks_like_hash';
{

    # @fields array necessary for object destruction
    my @fields = \(
        my (
            %width,             %height,         %node_radius,
            %tip_radius,        %node_colour,    %node_shape,
            %node_image,        %branch_color,   %branch_shape,
            %branch_width,      %branch_style,   %collapsed_width,
            %font_face,         %font_size,      %font_style,
            %margin,            %margin_top,     %margin_bottom,
            %margin_left,       %margin_right,   %padding,
            %padding_top,       %padding_bottom, %padding_left,
            %padding_right,     %mode,           %shape,
            %text_horiz_offset, %text_vert_offset,
        )
    );

    sub new {
        my $class = shift;
        my %args  = looks_like_hash @_;
        if ( not $args{'-tree'} ) {
            return $class->SUPER::new(@_);
        }
        else {
            my $tree = $args{'-tree'};
            my $self = $tree->clone;
            bless $self, $class;
            $self->visit( sub { bless shift, 'Bio::Phylo::Forest::DrawNode' } );
            delete $args{'-tree'};
            for my $key ( keys %args ) {
                my $method = $key;
                $method =~ s/^-/set_/;
                $self->$method( $args{$key} );
            }
            return $self;
        }
    }

    sub set_width {
        my ( $self, $width ) = @_;
        my $id = $self->get_id;
        $width{$id} = $width;
        $self->_redraw;
        return $self;
    }

    sub set_height {
        my ( $self, $height ) = @_;
        my $id = $self->get_id;
        $height{$id} = $height;
        $self->_redraw;
        return $self;
    }

    sub set_node_radius {
        my ( $self, $node_radius ) = @_;
        my $id = $self->get_id;
        $node_radius{$id} = $node_radius;
        $self->_apply_to_nodes( 'set_radius', $node_radius );
        return $self;
    }

    sub set_tip_radius {
        my ( $self, $r ) = @_;
        my $id = $self->get_id;
        $tip_radius{$id} = $r;
        $self->_apply_to_nodes( 'set_tip_radius', $r );
        return $self;
    }

    sub set_node_colour {
        my ( $self, $node_colour ) = @_;
        my $id = $self->get_id;
        $node_colour{$id} = $node_colour;
        $self->_apply_to_nodes( 'set_node_colour', $node_colour );
        return $self;
    }
    *set_node_color = \&set_node_colour;

    sub set_node_shape {
        my ( $self, $node_shape ) = @_;
        my $id = $self->get_id;
        $node_shape{$id} = $node_shape;
        $self->_apply_to_nodes( 'set_node_shape', $node_shape );
        return $self;
    }

    sub set_node_image {
        my ( $self, $node_image ) = @_;
        my $id = $self->get_id;
        $node_image{$id} = $node_image;
        $self->_apply_to_nodes( 'set_node_image', $node_image );
        return $self;
    }

    sub set_collapsed_clade_width {
        my ( $self, $width ) = @_;
        my $id = $self->get_id;
        $collapsed_width{$id} = $width;
        $self->_apply_to_nodes( 'set_collapsed_clade_width', $width );
        return $self;
    }

    sub set_branch_color {
        my ( $self, $branch_color ) = @_;
        my $id = $self->get_id;
        $branch_color{$id} = $branch_color;
        $self->_apply_to_nodes( 'set_branch_color', $branch_color );
        return $self;
    }
    *set_branch_colour = \&set_branch_colour;

    sub set_branch_shape {
        my ( $self, $branch_shape ) = @_;
        my $id = $self->get_id;
        $branch_shape{$id} = $branch_shape;
        $self->_apply_to_nodes( 'set_branch_shape', $branch_shape );
        return $self;
    }

    sub set_branch_width {
        my ( $self, $branch_width ) = @_;
        my $id = $self->get_id;
        $branch_width{$id} = $branch_width;
        $self->_apply_to_nodes( 'set_branch_width', $branch_width );
        return $self;
    }

    sub set_branch_style {
        my ( $self, $branch_style ) = @_;
        my $id = $self->get_id;
        $branch_style{$id} = $branch_style;
        $self->_apply_to_nodes( 'set_branch_style', $branch_style );
        return $self;
    }

    sub set_font_face {
        my ( $self, $font_face ) = @_;
        my $id = $self->get_id;
        $font_face{$id} = $font_face;
        $self->_apply_to_nodes( 'set_font_face', $font_face );
        return $self;
    }

    sub set_font_size {
        my ( $self, $font_size ) = @_;
        my $id = $self->get_id;
        $font_size{$id} = $font_size;
        $self->_apply_to_nodes( 'set_font_size', $font_size );
        return $self;
    }

    sub set_font_style {
        my ( $self, $font_style ) = @_;
        my $id = $self->get_id;
        $font_style{$id} = $font_style;
        $self->_apply_to_nodes( 'set_font_style', $font_style );
        return $self;
    }

    sub set_margin {
        my ( $self, $margin ) = @_;
        my $id = $self->get_id;
        $margin{$id} = $margin;
        for my $setter (qw(top bottom left right)) {
            my $method = 'set_margin_' . $setter;
            $self->$method($margin);
        }
        $self->_redraw;
        return $self;
    }

    sub set_margin_top {
        my ( $self, $margin_top ) = @_;
        my $id = $self->get_id;
        $margin_top{$id} = $margin_top;
        $self->_redraw;
        return $self;
    }

    sub set_margin_bottom {
        my ( $self, $margin_bottom ) = @_;
        my $id = $self->get_id;
        $margin_bottom{$id} = $margin_bottom;
        $self->_redraw;
        return $self;
    }

    sub set_margin_left {
        my ( $self, $margin_left ) = @_;
        my $id = $self->get_id;
        $margin_left{$id} = $margin_left;
        $self->_redraw;
        return $self;
    }

    sub set_margin_right {
        my ( $self, $margin_right ) = @_;
        my $id = $self->get_id;
        $margin_right{$id} = $margin_right;
        $self->_redraw;
        return $self;
    }

    sub set_padding {
        my ( $self, $padding ) = @_;
        my $id = $self->get_id;
        $padding{$id} = $padding;
        for my $setter (qw(top bottom left right)) {
            my $method = 'set_padding_' . $setter;
            $self->$method($padding);
        }
        $self->_redraw;
        return $self;
    }

    sub set_padding_top {
        my ( $self, $padding_top ) = @_;
        my $id = $self->get_id;
        $padding_top{$id} = $padding_top;
        $self->_redraw;
        return $self;
    }

    sub set_padding_bottom {
        my ( $self, $padding_bottom ) = @_;
        my $id = $self->get_id;
        $padding_bottom{$id} = $padding_bottom;
        $self->_redraw;
        return $self;
    }

    sub set_padding_left {
        my ( $self, $padding_left ) = @_;
        my $id = $self->get_id;
        $padding_left{$id} = $padding_left;
        $self->_redraw;
        return $self;
    }

    sub set_padding_right {
        my ( $self, $padding_right ) = @_;
        my $id = $self->get_id;
        $padding_right{$id} = $padding_right;
        $self->_redraw;
        return $self;
    }

    sub set_mode {
        my ( $self, $mode ) = @_;
        my $id = $self->get_id;
        $mode{$id} = $mode;
        $self->_redraw;
        return $self;
    }

    sub set_shape {
        my ( $self, $shape ) = @_;
        my $id = $self->get_id;
        $shape{$id} = $shape;
        return $self;
    }

    sub set_text_horiz_offset {
        my ( $self, $text_horiz_offset ) = @_;
        my $id = $self->get_id;
        $text_horiz_offset{$id} = $text_horiz_offset;
        $self->_apply_to_nodes( 'set_text_horiz_offset', $text_horiz_offset );
        return $self;
    }

    sub set_text_vert_offset {
        my ( $self, $text_vert_offset ) = @_;
        my $id = $self->get_id;
        $text_vert_offset{$id} = $text_vert_offset;
        $self->_apply_to_nodes( 'set_text_vert_offset', $text_vert_offset );
        return $self;
    }

    sub get_width {
        my $self = shift;
        my $id   = $self->get_id;
        return $width{$id};
    }

    sub get_height {
        my $self = shift;
        my $id   = $self->get_id;
        return $height{$id};
    }

    sub get_node_radius {
        my $self = shift;
        my $id   = $self->get_id;
        return $node_radius{$id};
    }

    sub get_node_colour {
        my $self = shift;
        my $id   = $self->get_id;
        return $node_colour{$id};
    }
    *get_node_color = \&get_node_colour;

    sub get_node_shape {
        my $self = shift;
        my $id   = $self->get_id;
        return $node_shape{$id};
    }

    sub get_node_image {
        my $self = shift;
        my $id   = $self->get_id;
        return $node_image{$id};
    }

    sub get_collapsed_clade_width {
        my $self = shift;
        my $id   = $self->get_id;
        return $collapsed_width{$id};
    }

    sub get_branch_color {
        my $self = shift;
        my $id   = $self->get_id;
        return $branch_color{$id};
    }
    *get_branch_colour = \&get_branch_color;

    sub get_branch_shape {
        my $self = shift;
        my $id   = $self->get_id;
        return $branch_shape{$id};
    }

    sub get_branch_width {
        my $self = shift;
        my $id   = $self->get_id;
        return $branch_width{$id};
    }

    sub get_branch_style {
        my $self = shift;
        my $id   = $self->get_id;
        return $branch_style{$id};
    }

    sub get_font_face {
        my $self = shift;
        my $id   = $self->get_id;
        return $font_face{$id};
    }

    sub get_font_size {
        my $self = shift;
        my $id   = $self->get_id;
        return $font_size{$id};
    }

    sub get_font_style {
        my $self = shift;
        my $id   = $self->get_id;
        return $font_style{$id};
    }

    sub get_margin {
        my $self = shift;
        my $id   = $self->get_id;
        return $margin{$id};
    }

    sub get_margin_top {
        my $self = shift;
        my $id   = $self->get_id;
        return $margin_top{$id};
    }

    sub get_margin_bottom {
        my $self = shift;
        my $id   = $self->get_id;
        return $margin_bottom{$id};
    }

    sub get_margin_left {
        my $self = shift;
        my $id   = $self->get_id;
        return $margin_left{$id};
    }

    sub get_margin_right {
        my $self = shift;
        my $id   = $self->get_id;
        return $margin_right{$id};
    }

    sub get_padding {
        my $self = shift;
        my $id   = $self->get_id;
        return $padding{$id};
    }

    sub get_padding_top {
        my $self = shift;
        my $id   = $self->get_id;
        return $padding_top{$id};
    }

    sub get_padding_bottom {
        my $self = shift;
        my $id   = $self->get_id;
        return $padding_bottom{$id};
    }

    sub get_padding_left {
        my $self = shift;
        my $id   = $self->get_id;
        return $padding_left{$id};
    }

    sub get_padding_right {
        my $self = shift;
        my $id   = $self->get_id;
        return $padding_right{$id};
    }

    sub get_mode {
        my $self = shift;
        my $id   = $self->get_id;
        if ( $self->is_cladogram ) {
            $mode{$id} = 'CLADO';
        }
        return $mode{$id};
    }

    sub get_shape {
        my $self = shift;
        my $id   = $self->get_id;
        return $shape{$id};
    }

    sub get_text_horiz_offset {
        my $self = shift;
        my $id   = $self->get_id;
        return $text_horiz_offset{$id};
    }

    sub get_text_vert_offset {
        my $self = shift;
        my $id   = $self->get_id;
        return $text_vert_offset{$id};
    }

    sub _redraw {
        my $self = shift;
        my ( $width, $height ) = ( $self->get_width, $self->get_height );
        my $tips_seen  = 0;
        my $total_tips = $self->calc_number_of_terminals();
        my $tallest    = $self->get_root->calc_max_path_to_tips;
        my $maxnodes   = $self->get_root->calc_max_nodes_to_tips;
        my $is_clado   = $self->get_mode =~ m/^c/i;
        $self->visit_depth_first(
            '-post' => sub {
                my $node = shift;
                my ( $x, $y );
                if ( $node->is_terminal ) {
                    $tips_seen++;
                    $y = ( $height / $total_tips ) * $tips_seen;
                    $x =
                        $is_clado
                      ? $width
                      : ( $width / $tallest ) * $node->calc_path_to_root;
                }
                else {
                    my @children = @{ $node->get_children };
                    $y += $_->get_y for @children;
                    $y /= scalar @children;
                    $x =
                        $is_clado
                      ? $width -
                      ( ( $width / $maxnodes ) * $node->calc_max_nodes_to_tips )
                      : ( $width / $tallest ) * $node->calc_path_to_root;
                }
                $node->set_y($y);
                $node->set_x($x);
            }
        );
    }

    sub _apply_to_nodes {
        my ( $self, $method, $value ) = @_;
        $self->visit( sub { shift->$method($value) } );
    }

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

    # podinherit_insert_token

}
1;