Bio::Phylo::Treedrawer - Visualizer of tree shapes

 use Bio::Phylo::IO 'parse';
 use Bio::Phylo::Treedrawer;

 my $string = '((A:1,B:2)n1:3,C:4)n2:0;';
 my $tree = parse( -format => 'newick', -string => $string )->first;

 my $treedrawer = Bio::Phylo::Treedrawer->new(
    -width  => 800,
    -height => 600,
    -shape  => 'CURVY', # curvogram
    -mode   => 'PHYLO', # cladogram
    -format => 'SVG'
 );

 $treedrawer->set_scale_options(
    -width => '100%',
    -major => '10%', # major cross hatch interval
    -minor => '2%',  # minor cross hatch interval
    -label => 'MYA',
 );

 $treedrawer->set_tree($tree);
 print $treedrawer->draw;

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

# $Id: Treedrawer.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::Treedrawer;
use strict;
use Bio::Phylo::Util::Logger;
use Bio::Phylo::Forest::DrawTree;
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw'_TREE_ /looks_like/';
my @fields = qw(
  WIDTH
  BRANCH_WIDTH
  HEIGHT
  MODE
  SHAPE
  PADDING
  NODE_RADIUS
  TIP_RADIUS
  TEXT_HORIZ_OFFSET
  TEXT_VERT_OFFSET
  TEXT_WIDTH
  TREE
  _SCALEX
  _SCALEY
  SCALE
  FORMAT
  COLLAPSED_CLADE_WIDTH
);
my $tips   = 0.000_000_000_000_01;
my $logger = Bio::Phylo::Util::Logger->new;

sub new {
    my $class = shift;
    my $self  = {
        'WIDTH'                 => 500,
        'HEIGHT'                => 500,
        'MODE'                  => 'PHYLO',
        'SHAPE'                 => 'CURVY',
        'PADDING'               => 50,
        'NODE_RADIUS'           => 0,
        'TIP_RADIUS'            => 0,
        'TEXT_HORIZ_OFFSET'     => 6,
        'TEXT_VERT_OFFSET'      => 4,
        'TEXT_WIDTH'            => 150,
        'TREE'                  => undef,
        '_SCALEX'               => 1,
        '_SCALEY'               => 1,
        'FORMAT'                => 'Svg',
        'SCALE'                 => undef,
        'BRANCH_WIDTH'          => 1,
        'COLLAPSED_CLADE_WIDTH' => 6,
    };
    bless $self, $class;
    if (@_) {
        my %opts = looks_like_hash @_;
        for my $key ( keys %opts ) {
            my $mutator = lc $key;
            $mutator =~ s/^-/set_/;
            $self->$mutator( $opts{$key} );
        }
    }
    return $self;
}

sub _cascading_setter {
    my ( $self, $value ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ( my $tree = $self->get_tree ) {
        if ( $tree->can($subroutine) ) {
            $tree->$subroutine($value);
        }
    }
    $subroutine =~ s/^set_//;
    $self->{ uc $subroutine } = $value;
    return $self;
}

sub _cascading_getter {
    my ( $self, $invocant ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ($invocant) {
        if ( $invocant->can($subroutine) ) {
            my $value = $invocant->$subroutine();
            if ( defined $value ) {
                return $value;
            }
        }
    }
    $subroutine =~ s/^get_//;
    return $self->{ uc $subroutine };
}

sub set_format {
    my ( $self, $format ) = @_;
    $format = ucfirst( lc($format) );
    if ( looks_like_class __PACKAGE__ . '::' . $format ) {
        $self->{'FORMAT'} = $format;
        return $self;
    }
    else {
        throw 'BadFormat' => "'$format' is not a valid image format";
    }
}

sub set_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->{'WIDTH'} = $width;
    }
    else {
        throw 'BadNumber' => "'$width' is not a valid image width";
    }
    return $self;
}

sub set_height {
    my ( $self, $height ) = @_;
    if ( looks_like_number $height && $height > 0 ) {
        $self->{'HEIGHT'} = $height;
    }
    else {
        throw 'BadNumber' => "'$height' is not a valid image height";
    }
    return $self;
}

sub set_mode {
    my ( $self, $mode ) = @_;
    if ( $mode =~ m/^(?:clado|phylo)$/i ) {
        $self->{'MODE'} = uc $mode;
    }
    else {
        throw 'BadFormat' => "'$mode' is not a valid drawing mode";
    }
    return $self;
}

sub set_shape {
    my ( $self, $shape ) = @_;
    if ( $shape =~ m/^(?:rect|diag|curvy)/i ) {
        $self->{'SHAPE'} = uc $shape;
    }
    else {
        throw 'BadFormat' => "'$shape' is not a valid drawing shape";
    }
    return $self;
}

sub set_padding {
    my ( $self, $padding ) = @_;
    if ( looks_like_number $padding && $padding > 0 ) {
        $self->{'PADDING'} = $padding;
    }
    else {
        throw 'BadNumber' => "'$padding' is not a valid padding value";
    }
    return $self;
}

sub set_text_horiz_offset {
    my ( $self, $offset ) = @_;
    if ( looks_like_number $offset ) {
        $self->{'TEXT_HORIZ_OFFSET'} = $offset;
    }
    else {
        throw 'BadNumber' =>
          "'$offset' is not a valid text horizontal offset value";
    }
    return $self;
}

sub set_text_vert_offset {
    my ( $self, $offset ) = @_;
    if ( looks_like_number $offset ) {
        $self->{'TEXT_VERT_OFFSET'} = $offset;
    }
    else {
        throw 'BadNumber' =>
          "'$offset' is not a valid text vertical offset value";
    }
    return $self;
}

sub set_text_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->{'TEXT_WIDTH'} = $width;
    }
    else {
        throw 'BadNumber' => "'$width' is not a valid text width value";
    }
    return $self;
}

sub set_tree {
    my ( $self, $tree ) = @_;
    if ( looks_like_object $tree, _TREE_ ) {
        if ( not $tree->isa('Bio::Phylo::Forest::DrawTree') ) {
            $tree = Bio::Phylo::Forest::DrawTree->new( '-tree' => $tree );
        }
        $self->{'TREE'} = $tree->negative_to_zero;
    }
    return $self;
}

sub set_scale_options {
    my $self = shift;
    if ( ( @_ && !scalar @_ % 2 ) || ( scalar @_ == 1 && ref $_[0] eq 'HASH' ) )
    {
        my %o;    # %options
        if ( scalar @_ == 1 && ref $_[0] eq 'HASH' ) {
            %o = %{ $_[0] };
        }
        else {
            %o = looks_like_hash @_;
        }
        if ( looks_like_number $o{'-width'} or $o{'-width'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-width'} = $o{'-width'};
        }
        else {
            throw 'BadArgs' => "\"$o{'-width'}\" is invalid for '-width'";
        }
        if ( looks_like_number $o{'-major'} or $o{'-major'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-major'} = $o{'-major'};
        }
        else {
            throw 'BadArgs' => "\"$o{'-major'}\" is invalid for '-major'";
        }
        if ( looks_like_number $o{'-minor'} or $o{'-minor'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-minor'} = $o{'-minor'};
        }
        else {
            throw 'BadArgs' => "\"$o{'-minor'}\" is invalid for '-minor'";
        }
        $self->{'SCALE'}->{'-label'} = $o{'-label'};
    }
    else {
        throw 'OddHash' => 'Odd number of elements in hash assignment';
    }
    return $self;
}

sub set_branch_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->_cascading_setter($width);
    }
    else {
        throw 'BadNumber' => "'$width' is not a valid branch width";
    }
    return $self;
}

sub set_node_radius {
    my ( $self, $radius ) = @_;
    if ( looks_like_number $radius && $radius >= 0 ) {
        $self->_cascading_setter($radius);
    }
    else {
        throw 'BadNumber' => "'$radius' is not a valid node radius value";
    }
    return $self;
}

sub set_collapsed_clade_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->_cascading_setter($width);
    }
    else {
        throw 'BadNumber' => "'$width' is not a valid image width";
    }
    return $self;
}

sub set_tip_radius {
    my ( $self, $radius ) = @_;
    if ( looks_like_number $radius && $radius >= 0 ) {
        $self->_cascading_setter($radius);
    }
    else {
        throw 'BadNumber' => "'$radius' is not a valid tip radius value";
    }
    return $self;
}

sub get_format { shift->{'FORMAT'} }

sub get_width { shift->{'WIDTH'} }

sub get_height { shift->{'HEIGHT'} }

sub get_mode { shift->{'MODE'} }

sub get_shape { shift->{'SHAPE'} }

sub get_padding { shift->{'PADDING'} }

sub get_text_horiz_offset { shift->{'TEXT_HORIZ_OFFSET'} }

sub get_text_vert_offset { shift->{'TEXT_VERT_OFFSET'} }

sub get_text_width { shift->{'TEXT_WIDTH'} }

sub get_tree { shift->{'TREE'} }

sub get_scale_options { shift->{'SCALE'} }

sub get_branch_width {
    my $self = shift;
    return $self->_cascading_getter(@_);
}

sub get_collapsed_clade_width {
    my $self = shift;
    return $self->_cascading_getter(@_);
}

sub get_node_radius {
    my $self = shift;
    return $self->_cascading_getter(@_);
}

sub get_tip_radius {
    my $self = shift;
    return $self->_cascading_getter(@_);
}

sub _set_scalex {
    my $self = shift;
    if ( looks_like_number $_[0] ) {
        $self->{'_SCALEX'} = $_[0];
    }
    else {
        throw 'BadNumber' => "\"$_[0]\" is not a valid number value";
    }
    return $self;
}
sub _get_scalex { shift->{'_SCALEX'} }

sub _set_scaley {
    my $self = shift;
    if ( looks_like_number $_[0] ) {
        $self->{'_SCALEY'} = $_[0];
    }
    else {
        throw 'BadNumber' => "\"$_[0]\" is not a valid integer value";
    }
    return $self;
}
sub _get_scaley { shift->{'_SCALEY'} }

sub draw {
    my $self = shift;
    if ( !$self->get_tree ) {
        throw 'BadArgs' => "Can't draw an undefined tree";
    }
    my $root = $self->get_tree->get_root;

    #Reset the stored data in the tree
    $self->_reset_internal($root);
    $self->_compute_rooted_coordinates;
    return $self->render;
}

sub _compute_rooted_coordinates {
    my $td      = shift;
    my $tree    = $td->get_tree;
    my $phylo   = $td->get_mode =~ /^p/i ? 1 : 0;    # phylogram or cladogram
    my $padding = $td->get_padding;
    my $width  = $td->get_width - ( $td->get_text_width + ( $padding * 2 ) );
    my $height = $td->get_height - ( $padding * 2 );
    my $cladew = $td->get_collapsed_clade_width;
    my ( $tip_counter, $tallest_tip ) = ( 0, 0 );
    $tree->visit_depth_first(
        '-pre' => sub {
            my $node = shift;
            if ( my $parent = $node->get_parent ) {
                my $parent_x = $parent->get_x || 0;
                my $x = $phylo ? $node->get_branch_length || 0 : 1;
                $node->set_x( $x + $parent_x );
            }
            else {
                $node->set_x(0);    # root
            }
        },
        '-no_daughter' => sub {
            my $node = shift;
            if ( $node->get_collapsed ) {
                $tip_counter += ( ( $cladew - 2 ) / 2 );
                $node->set_y($tip_counter);
                $tip_counter += ( ( $cladew - 2 ) / 2 ) + 1;
            }
            else {
                $node->set_y( $tip_counter++ );
            }
            my $x = $node->get_x;
            $tallest_tip = $x if $x > $tallest_tip;
        },
        '-post_daughter' => sub {
            my $node = shift;
            my ( $child_count, $child_y ) = ( 0, 0 );
            for my $child ( @{ $node->get_children } ) {
                $child_count++;
                $child_y += $child->get_y;
            }
            $node->set_y( $child_y / $child_count );
        },
    );
    $tree->visit(
        sub {
            my $node = shift;
            $node->set_x( $padding + $node->get_x * ( $width / $tallest_tip ) );
            $node->set_y(
                $padding + $node->get_y * ( $height / $tip_counter ) );
            if ( !$phylo && $node->is_terminal ) {
                $node->set_x(
                    $padding + $tallest_tip * ( $width / $tallest_tip ) );
            }
        }
    );
    $td->_set_scaley( $height / $tip_counter );
    $td->_set_scalex( $width / $tallest_tip );
}

sub render {
    my $self = shift;
    my $library =
      looks_like_class __PACKAGE__ . '::' . ucfirst( lc( $self->get_format ) );
    my $drawer = $library->_new(
        '-tree'   => $self->get_tree,
        '-drawer' => $self
    );
    return $drawer->_draw;
}

sub _reset_internal {
    my ( $self, $node ) = @_;
    my $tree = $self->get_tree;
    $node->set_x(undef);
    $node->set_y(undef);
    my $children = $node->get_children;
    for my $child (@$children) {
        _reset_internal( $self, $child );
    }
}

1;