# $Id: Treedrawer.pm 4213 2007-07-15 03:11:27Z rvosa $
# Subversion: $Rev: 192 $
package Bio::Phylo::Treedrawer;
use strict;
use Bio::Phylo::Forest::Tree;
use Bio::Phylo::Forest::Node;
use Bio::Phylo::Util::CONSTANT qw(_TREE_ looks_like_number);

my @fields = qw(WIDTH HEIGHT MODE SHAPE PADDING NODE_RADIUS TEXT_HORIZ_OFFSET TEXT_VERT_OFFSET TEXT_WIDTH TREE _SCALEX _SCALEY SCALE FORMAT);

# One line so MakeMaker sees it.
use Bio::Phylo; our $VERSION = $Bio::Phylo::VERSION;

my $tips = 0.000_000_000_000_01;


=head1 NAME

Bio::Phylo::Treedrawer - An object-oriented facade for drawing trees.

=head1 SYNOPSIS

 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;

=head1 DESCRIPTION

This module prepares a tree object for drawing (calculating coordinates for
nodes) and calls the appropriate format-specific drawer.

=head1 METHODS

=head2 CONSTRUCTOR

=over

=item new()

Treedrawer constructor.

 Type    : Constructor
 Title   : new
 Usage   : my $treedrawer = Bio::Phylo::Treedrawer->new(
               %args 
           );
 Function: Initializes a Bio::Phylo::Treedrawer object.
 Alias   :
 Returns : A Bio::Phylo::Treedrawer object.
 Args    : none.

=cut

sub new {
    my $class = shift;
    my $self = {
        'WIDTH'             => 500,
        'HEIGHT'            => 500,
        'MODE'              => 'PHYLO',
        'SHAPE'             => 'CURVY',
        'PADDING'           => 50,
        'NODE_RADIUS'       => 1,
        'TEXT_HORIZ_OFFSET' => 6,
        'TEXT_VERT_OFFSET'  => 4,
        'TEXT_WIDTH'        => 150,
        'TREE'              => undef,
        '_SCALEX'           => 1,
        '_SCALEY'           => 1,
        'FORMAT'            => 'Svg',
        'SCALE'             => undef,
    };
    bless $self, $class;
    
    if (@_) {
        my %opts = @_;
        for my $key ( keys %opts ) {
            my $mutator = lc $key;
            $mutator =~ s/^-/set_/;
            $self->$mutator( $opts{$key} );
        }
    }
    return $self;
}

=back

=head2 MUTATORS

=over

=item set_format()

Sets image format.

 Type    : Mutator
 Title   : set_format
 Usage   : $treedrawer->set_format('Svg');
 Function: Sets the drawer submodule.
 Returns :
 Args    : Name of an image format (currently 
           only Svg supported)

=cut

sub set_format {
    my ( $self, $format ) = @_;
    $format = ucfirst( lc( $format ) );
    my $class = __PACKAGE__ . '::' . $format;
    eval "require $class";
    if ( not $@ ) {
        $self->{'FORMAT'} = $format;
        return $self;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadFormat->throw(
            'error' => "'$format' is not a valid image format"
        );
    }    
}

=item set_width()

Sets image width.

 Type    : Mutator
 Title   : set_width
 Usage   : $treedrawer->set_width(1000);
 Function: sets the width of the drawer canvas.
 Returns :
 Args    : Integer width in pixels.

=cut

sub set_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->{'WIDTH'} = $width;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$width' is not a valid image width"
        );
    }
    return $self;
}

=item set_height()

Sets image height.

 Type    : Mutator
 Title   : set_height
 Usage   : $treedrawer->set_height(1000);
 Function: sets the height of the canvas.
 Returns :
 Args    : Integer height in pixels.

=cut

sub set_height {
    my ( $self, $height ) = @_;
    if ( looks_like_number $height && $height > 0 ) {
        $self->{'HEIGHT'} = $height;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$height' is not a valid image height"
        );
    }
    return $self;
}

=item set_mode()

Sets tree drawing mode.

 Type    : Mutator
 Title   : set_mode
 Usage   : $treedrawer->set_mode('clado');
 Function: Sets the tree mode, i.e. cladogram 
           or phylogram.
 Returns : Invocant.
 Args    : String, [clado|phylo]

=cut

sub set_mode {
    my ( $self, $mode ) = @_;
    if ( $mode =~ m/^(?:clado|phylo)$/i ) {
        $self->{'MODE'} = uc $mode;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadFormat->throw(
            'error' => "'$mode' is not a valid drawing mode"
        );
    }
    return $self;
}

=item set_shape()

Sets tree drawing shape.

 Type    : Mutator
 Title   : set_shape
 Usage   : $treedrawer->set_shape('rect');
 Function: Sets the tree shape, i.e. 
           rectangular, diagonal or curvy.
 Returns : Invocant.
 Args    : String, [rect|diag|curvy]

=cut

sub set_shape {
    my ( $self, $shape ) = @_;
    if ( $shape =~ m/^(?:rect|diag|curvy)$/i ) {
        $self->{'SHAPE'} = uc $shape;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadFormat->throw(
            'error' => "'$shape' is not a valid drawing shape"
        );
    }
    return $self;
}

=item set_padding()

Sets image padding.

 Type    : Mutator
 Title   : set_padding
 Usage   : $treedrawer->set_padding(100);
 Function: Sets the canvas padding.
 Returns :
 Args    : Integer value in pixels.

=cut

sub set_padding {
    my ( $self, $padding ) = @_;
    if ( looks_like_number $padding && $padding > 0 ) {
        $self->{'PADDING'} = $padding;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$padding' is not a valid padding value"
        );
    }
    return $self;
}

=item set_node_radius()

Sets node radius.

 Type    : Mutator
 Title   : set_node_radius
 Usage   : $treedrawer->set_node_radius(20);
 Function: Sets the node radius in pixels.
 Returns :
 Args    : Integer value in pixels.

=cut

sub set_node_radius {
    my ( $self, $radius ) = @_;
    if ( looks_like_number $radius && $radius >= 0 ) {
        $self->{'NODE_RADIUS'} = $radius;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$radius' is not a valid node radius value"
        );
    }
    return $self;
}

=item set_text_horiz_offset()

Sets text horizontal offset.

 Type    : Mutator
 Title   : set_text_horiz_offset
 Usage   : $treedrawer->set_text_horiz_offset(5);
 Function: Sets the distance between 
           tips and text, in pixels.
 Returns :
 Args    : Integer value in pixels.

=cut

sub set_text_horiz_offset {
    my ( $self, $offset ) = @_;
    if ( looks_like_number $offset ) {
        $self->{'TEXT_HORIZ_OFFSET'} = $offset;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$offset' is not a valid text horizontal offset value"
        );
    }
    return $self;
}

=item set_text_vert_offset()

Sets text vertical offset.

 Type    : Mutator
 Title   : set_text_vert_offset
 Usage   : $treedrawer->set_text_vert_offset(3);
 Function: Sets the text baseline 
           relative to the tips, in pixels.
 Returns :
 Args    : Integer value in pixels.

=cut

sub set_text_vert_offset {
    my ( $self, $offset ) = @_;
    if ( looks_like_number $offset ) {
        $self->{'TEXT_VERT_OFFSET'} = $offset;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$offset' is not a valid text vertical offset value"
        );
    }
    return $self;
}

=item set_text_width()

Sets text width.

 Type    : Mutator
 Title   : set_text_width
 Usage   : $treedrawer->set_text_width(150);
 Function: Sets the canvas width for 
           terminal taxon names.
 Returns :
 Args    : Integer value in pixels.

=cut

sub set_text_width {
    my ( $self, $width ) = @_;
    if ( looks_like_number $width && $width > 0 ) {
        $self->{'TEXT_WIDTH'} = $width;
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            'error' => "'$width' is not a valid text width value"
        );
    }
    return $self;
}

=item set_tree()

Sets tree to draw.

 Type    : Mutator
 Title   : set_tree
 Usage   : $treedrawer->set_tree($tree);
 Function: Sets the Bio::Phylo::Forest::Tree 
           object to unparse.
 Returns :
 Args    : A Bio::Phylo::Forest::Tree object.

=cut

sub set_tree {
    my ( $self, $tree ) = @_;
    my $type;
    eval { $type = $tree->_type };
    if ( ! $@ && $type == _TREE_ ) {
        $self->{'TREE'} = $tree->negative_to_zero;
    }
    else {
        Bio::Phylo::Util::Exceptions::ObjectMismatch->throw(
            'error' => "'$tree' is not a valid tree"
        );
    }
    return $self;
}

=item set_scale_options()

Sets time scale options.

 Type    : Mutator
 Title   : set_scale_options
 Usage   : $treedrawer->set_scale_options(
                -width => 400,
                -major => '10%', # major cross hatch interval
                -minor => '2%',  # minor cross hatch interval
                -label => 'MYA',
            );
 Function: Sets the options for time (distance) scale
 Returns :
 Args    : -width => (if a number, like 100, pixel 
                      width is assumed, if a percentage, 
                      scale width relative to longest root
                      to tip path)
           -major => ( ditto, value for major tick marks )
           -minor => ( ditto, value for minor tick marks )
           -label => ( text string displayed next to scale )

=cut

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 = @_;
        }
        if ( looks_like_number $o{'-width'} or $o{'-width'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-width'} = $o{'-width'};
        }
        else {
            Bio::Phylo::Util::Exceptions::BadArgs->throw(
                error => "\"$o{'-width'}\" is invalid for '-width'" );
        }
        if ( looks_like_number $o{'-major'} or $o{'-major'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-major'} = $o{'-major'};
        }
        else {
            Bio::Phylo::Util::Exceptions::BadArgs->throw(
                error => "\"$o{'-major'}\" is invalid for '-major'" );
        }
        if ( looks_like_number $o{'-minor'} or $o{'-minor'} =~ m/^\d+%$/ ) {
            $self->{'SCALE'}->{'-minor'} = $o{'-minor'};
        }
        else {
            Bio::Phylo::Util::Exceptions::BadArgs->throw(
                error => "\"$o{'-minor'}\" is invalid for '-minor'" );
        }
        $self->{'SCALE'}->{'-label'} = $o{'-label'};
    }
    else {
        Bio::Phylo::Util::Exceptions::OddHash->throw(
            error => 'Odd number of elements in hash assignment' );
    }
    return $self;
}

=back

=head2 ACCESSORS

=over

=item get_format()

Gets image format.

 Type    : Mutator
 Title   : get_format
 Usage   : my $format = $treedrawer->get_format;
 Function: Gets the image format.
 Returns :
 Args    : None.

=cut

sub get_format { shift->{'FORMAT'} }

=item get_width()

Gets image width.

 Type    : Mutator
 Title   : get_width
 Usage   : my $width = $treedrawer->get_width;
 Function: Gets the width of the drawer canvas.
 Returns :
 Args    : None.

=cut

sub get_width { shift->{'WIDTH'} }

=item get_height()

Gets image height.

 Type    : Accessor
 Title   : get_height
 Usage   : my $height = $treedrawer->get_height;
 Function: Gets the height of the canvas.
 Returns :
 Args    : None.

=cut

sub get_height { shift->{'HEIGHT'} }

=item get_mode()

Gets tree drawing mode.

 Type    : Accessor
 Title   : get_mode
 Usage   : my $mode = $treedrawer->get_mode('clado');
 Function: Gets the tree mode, i.e. cladogram or phylogram.
 Returns :
 Args    : None.

=cut

sub get_mode { shift->{'MODE'} }

=item get_shape()

Gets tree drawing shape.

 Type    : Accessor
 Title   : get_shape
 Usage   : my $shape = $treedrawer->get_shape;
 Function: Gets the tree shape, i.e. rectangular, 
           diagonal or curvy.
 Returns :
 Args    : None.

=cut

sub get_shape { shift->{'SHAPE'} }

=item get_padding()

Gets image padding.

 Type    : Accessor
 Title   : get_padding
 Usage   : my $padding = $treedrawer->get_padding;
 Function: Gets the canvas padding.
 Returns :
 Args    : None.

=cut

sub get_padding { shift->{'PADDING'} }

=item get_node_radius()

Gets node radius.

 Type    : Accessor
 Title   : get_node_radius
 Usage   : my $node_radius = $treedrawer->get_node_radius;
 Function: Gets the node radius in pixels.
 Returns : SCALAR
 Args    : None.

=cut

sub get_node_radius { shift->{'NODE_RADIUS'} }

=item get_text_horiz_offset()

Gets text horizontal offset.

 Type    : Accessor
 Title   : get_text_horiz_offset
 Usage   : my $text_horiz_offset = 
           $treedrawer->get_text_horiz_offset;
 Function: Gets the distance between 
           tips and text, in pixels.
 Returns : SCALAR
 Args    : None.

=cut

sub get_text_horiz_offset { shift->{'TEXT_HORIZ_OFFSET'} }

=item get_text_vert_offset()

Gets text vertical offset.

 Type    : Accessor
 Title   : get_text_vert_offset
 Usage   : my $text_vert_offset = 
           $treedrawer->get_text_vert_offset;
 Function: Gets the text baseline relative 
           to the tips, in pixels.
 Returns :
 Args    : None.

=cut

sub get_text_vert_offset { shift->{'TEXT_VERT_OFFSET'} }

=item get_text_width()

Gets text width.

 Type    : Accessor
 Title   : get_text_width
 Usage   : my $textwidth = 
           $treedrawer->get_text_width;
 Function: Returns the canvas width 
           for terminal taxon names.
 Returns :
 Args    : None.

=cut

sub get_text_width { shift->{'TEXT_WIDTH'} }

=item get_tree()

Gets tree to draw.

 Type    : Accessor
 Title   : get_tree
 Usage   : my $tree = $treedrawer->get_tree;
 Function: Returns the Bio::Phylo::Forest::Tree 
           object to unparse.
 Returns : A Bio::Phylo::Forest::Tree object.
 Args    : None.

=cut

sub get_tree { shift->{'TREE'} }

=item get_scale_options()

Gets time scale option.

 Type    : Accessor
 Title   : get_scale_options
 Usage   : my %options = %{ 
               $treedrawer->get_scale_options  
           };
 Function: Returns the time/distance 
           scale options.
 Returns : A hash ref.
 Args    : None.

=cut

sub get_scale_options { shift->{'SCALE'} }

=begin comment

 Type    : Internal method.
 Title   : _set_scalex
 Usage   : $treedrawer->_set_scalex($scalex);
 Function:
 Returns :
 Args    :

=end comment

=cut

sub _set_scalex {
    my $self = shift;
    if ( looks_like_number $_[0] ) {
        $self->{'_SCALEX'} = $_[0];
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            error => "\"$_[0]\" is not a valid number value" );
    }
    return $self;
}

sub _get_scalex { shift->{'_SCALEX'} }

=begin comment

 Type    : Internal method.
 Title   : _set_scaley
 Usage   : $treedrawer->_set_scaley($scaley);
 Function:
 Returns :
 Args    :

=end comment

=cut

sub _set_scaley {
    my $self = shift;
    if ( looks_like_number $_[0] ) {
        $self->{'_SCALEY'} = $_[0];
    }
    else {
        Bio::Phylo::Util::Exceptions::BadNumber->throw(
            error => "\"$_[0]\" is not a valid integer value" );
    }
    return $self;
}

sub _get_scaley { shift->{'_SCALEY'} }

=back

=head2 TREE DRAWING

=over

=item draw()

Creates tree drawing.

 Type    : Unparsers
 Title   : draw
 Usage   : my $drawing = $treedrawer->draw;
 Function: Unparses a Bio::Phylo::Forest::Tree 
           object into a drawing.
 Returns : SCALAR
 Args    :

=cut

sub draw {
    my $self = shift;
    my $tree = $self->get_tree;
    if ( !$tree ) {
        Bio::Phylo::Util::Exceptions::BadArgs->throw(
            error => "Can't draw an undefined tree" );
    }
    my $root = $tree->get_root;

    #Reset the stored data in the tree
    $self->_reset_internal($root);

    my $tips = $tree->calc_number_of_terminals;
    my ( $width,   $height )    = ( $self->get_width,   $self->get_height );
    my ( $padding, $textwidth ) = ( $self->get_padding, $self->get_text_width );
    my $maxpath;
    if ( $self->get_mode eq 'PHYLO' ) {
        $maxpath = $root->calc_max_path_to_tips;
        if ( not $maxpath ) {
            $tree->warn("no branch lengths on tree, switching to clado mode");
            $self->set_mode('CLADO');
        }
    }
    if ( $self->get_mode eq 'CLADO' ) {
        $maxpath = $root->calc_max_nodes_to_tips;
    }

    $self->_set_scalex(
        ( ( $width - ( ( 2 * $padding ) + $textwidth ) ) / $maxpath ) );
    $self->_set_scaley( ( ( $height - ( 2 * $padding ) ) / ( $tips + 1 ) ) );
    if ( $self->get_mode eq 'CLADO' ) {
        $self->_x_positions_clado;
    }
    else {
        $self->_x_positions;
    }
    
    
    
    $self->_y_terminals(0);
    $self->_y_terminals($root);
    $tree->get_root->set_generic('y'=>0);
    $self->_y_internals;
    my $library = __PACKAGE__ . '::' . ucfirst( lc( $self->get_format ) );
    eval "require $library";
    if ($@) {
        Bio::Phylo::Util::Exceptions::BadFormat->throw(
            error => "Can't load image drawer: $@" );
    }

    my $drawer = $library->_new(
        -tree   => $tree,
        -drawer => $self
    );
    $drawer->_draw;
}

=begin comment

 Type    : Internal method.
 Title   : _reset_internal
 Usage   : $treedrawer->_reset_internal;
 Function: resets the set_generic values stored by Treedrawer, this must be 
           called at the start of each draw command or weird results are obtained!
 Returns : nothing
 Args    : treedrawer, node being processed

=end comment

=cut

sub _reset_internal {
    my ($self, $node) = @_;
    my $tree = $self->get_tree;
    $node->set_generic('x'=>undef);
    $node->set_generic('y'=>undef);
    my $children = $node->get_children;
    foreach $node (@$children) {
        _reset_internal($self,$node);
    }

}

=begin comment

 Type    : Internal method.
 Title   : _x_positions
 Usage   : $treedrawer->_x_positions;
 Function:
 Returns :
 Args    :

=end comment

=cut

sub _x_positions {
    my $self    = shift;
    my $tree    = $self->get_tree;
    my $root    = $tree->get_root;
    my $scalex  = $self->_get_scalex;
    my $padding = $self->get_padding;
    foreach my $node ( @{ $tree->get_entities } ) {
        my $x = ( $node->calc_path_to_root * $scalex ) + $padding;
        $node->set_generic( x => $x );
    }
}

=begin comment

 Type    : Internal method.
 Title   : _x_positions_clado
 Usage   : $treedrawer->_x_positions_clado;
 Function:
 Returns :
 Args    :

=end comment

=cut

sub _x_positions_clado {
    my $self    = shift;
    my $tree    = $self->get_tree;
    my $root    = $tree->get_root;
    my $scalex  = $self->_get_scalex;
    my $padding = $self->get_padding;
    my $longest = $root->calc_max_nodes_to_tips;
    my $depth = $longest;
    my $pos = {};
    my $parents = $tree->get_terminals;
    while (1) {
        my $children = $parents;
        $parents = [];
        my $x = $depth * $scalex + $padding;
        for my $child (@$children) {
            $child->set_generic( 'x' => $x );
            my $parent = $child->get_parent;
            next unless defined $parent;
            push @$parents, $parent;
        }
        $depth--;
        last if $depth < 0;
    }    
}

=begin comment

 Type    : Internal method.
 Title   : _y_terminals
 Usage   : $treedrawer->_y_terminals;
 Function:
 Returns :
 Args    : tree root

=end comment

=cut

{

    sub _y_terminals {
        my ($self, $node) = @_;
        if ($node == 0) { $tips = 0.000_000_000_000_01; return; }
        if ( !$node->get_first_daughter ) {
            $tips++;
            $node->set_generic(
                y => ( ( $tips * $self->_get_scaley ) + $self->get_padding ) );
        }
        else {
            $node = $node->get_first_daughter;
            $self->_y_terminals($node);
            while ( $node->get_next_sister ) {
                $node = $node->get_next_sister;
                $self->_y_terminals($node);
            }
        }
    }
}

=begin comment

 Type    : Internal method.
 Title   : _y_internals
 Usage   : $treedrawer->_y_internals;
 Function:
 Returns :
 Args    :

=end comment

=cut

sub _y_internals {
    my $self = shift;
    my $tree = $self->get_tree;
    while ( !$tree->get_root->get_generic('y') ) {
        foreach my $e ( @{ $tree->get_internals } ) {
            my $y1 = $e->get_first_daughter->get_generic('y');
            my $y2 = $e->get_last_daughter->get_generic('y');
            if ( $y1 && $y2 ) {
                my $y = ( $y1 + $y2 ) / 2;
                $e->set_generic( 'y' => $y );
            }
        }
    }
}

=back

=head1 SEE ALSO

=over

=item L<Bio::Phylo>

The L<Bio::Phylo::Treedrawer> object inherits from the L<Bio::Phylo> object.
Look there for more methods applicable to the treedrawer object.

=item L<Bio::Phylo::Manual>

Also see the manual: L<Bio::Phylo::Manual>.

=back

=head1 REVISION

 $Id: Treedrawer.pm 4213 2007-07-15 03:11:27Z rvosa $

=cut

1;
