File Coverage

blib/lib/Bio/Phylo/Treedrawer/Abstract.pm

Criterion	Covered	Total	%
statement	99	263	37.6
branch	31	94	32.9
condition	6	21	28.5
subroutine	12	27	44.4
pod			n/a
total	148	405	36.5

package Bio::Phylo::Treedrawer::Abstract;
use strict;
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::Logger ':levels';

my $logger = Bio::Phylo::Util::Logger->new;
our $DEFAULT_FONT = 'Arial';
our @FONT_DIR;

=head1 NAME

Bio::Phylo::Treedrawer::Abstract - Abstract graphics writer used by treedrawer, no
serviceable parts inside

=head1 DESCRIPTION

This module is an abstract super class for the various graphics formats that
Bio::Phylo supports. There is no direct usage of this class. Consult
L for documentation on how to draw trees.

=cut

sub _new {
    my $class = shift;
    my %args  = @_;
    my $self  = {
        'TREE'   => $args{'-tree'},
        'DRAWER' => $args{'-drawer'},
        'API'    => $args{'-api'},
    };
    return bless $self, $class;
}
sub _api    { shift->{'API'} }
sub _drawer { shift->{'DRAWER'} }
sub _tree   { shift->{'TREE'} }

=begin comment

 Type    : Internal method.
 Title   : _draw
 Usage   : $svg->_draw;
 Function: Main drawing method.
 Returns :
 Args    : None.

=end comment

=cut

sub _draw {
    my $self = shift;
    my $td   = $self->_drawer;
    $self->_draw_scale;
    $self->_tree->visit_depth_first(
        '-post' => sub {
            my $node        = shift;
            my $x           = $node->get_x;
            my $y           = $node->get_y;
            my $is_terminal = $node->is_terminal;
            my $r = $is_terminal ? $td->get_tip_radius : $td->get_node_radius;
            $self->_draw_branch($node);
            if ( $node->get_collapsed ) {
                $self->_draw_collapsed($node);
            }
            else {
                if ( my $name = $node->get_name ) {
                    $name =~ s/_/ /g;
                    $name =~ s/^'(.*)'$/$1/;
                    $name =~ s/^"(.*)"$/$1/;
                    $self->_draw_text(
                        '-x'           => int( $x + $td->get_text_horiz_offset ),
                        '-y'           => int( $y + $td->get_text_vert_offset ),
                        '-text'        => $name,
                        '-rotation'    => [ $node->get_rotation, $x, $y ],
                        '-font_face'   => $node->get_font_face,
                        '-font_size'   => $node->get_font_size,
                        '-font_style'  => $node->get_font_style,
                        '-font_colour' => $node->get_font_colour,
                        '-font_weight' => $node->get_font_weight,
                        'class'        => $is_terminal ? 'taxon_text' : 'node_text',
                    );
                }
            }
            $self->_draw_circle(
                '-radius' => $r,
                '-x'      => $x,
                '-y'      => $y,
                '-width'  => $node->get_branch_width,
                '-stroke' => $node->get_node_outline_colour,
                '-fill'   => $node->get_node_colour,
                '-url'    => $node->get_link,
            );
            if ( $node->get_clade_label ) {
            	$self->_draw_clade_label($node);
            }
        }
    );
    $self->_draw_pies;
    $self->_draw_legend;
    return $self->_finish;
}

sub _draw_pies {
    my $self = shift;
    $logger->warn( ref($self) . " can't draw pies" );
}

sub _draw_legend {
    my $self = shift;
    $logger->warn( ref($self) . " can't draw a legend" );
}

sub _finish {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " won't complete its drawing";
}

sub _draw_text {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw text";
}

sub _draw_line {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw line";
}

sub _draw_arc {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw arc";
}

sub _draw_curve {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw curve";
}

sub _draw_multi {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw multi line";
}

sub _draw_triangle {
    my $self = shift;
    throw 'NotImplemented' => ref($self) . " can't draw triangle";
}

sub _draw_rectangle {
	my $self = shift;
	throw 'NotImplemented' => ref($self) . " can't draw rectangle";
}

# XXX incomplete, still needs work for the radial part
sub _draw_clade_label {
    my ( $self, $node ) = @_;
    $logger->info("drawing clade label ".$node->get_clade_label);
    my $td  = $self->_drawer;
    my $tho = $td->get_text_horiz_offset;
    my $tw  = $td->get_text_width;

    my $lmtl = $node->get_leftmost_terminal;
    my $rmtl = $node->get_rightmost_terminal;
    my $root = $node->get_tree->get_root;
    my $desc = $node->get_descendants;
    my $ncl  = scalar( grep { $_->get_clade_label } @{ $node->get_ancestors } );

    # copy font preferences, if any
    my %font = ( '-text' => $node->get_clade_label );
    my $f = $node->get_clade_label_font || {};
	my @properties = qw(face size style weight colour);
	for my $p ( @properties ) {
		if ( my $value = $f->{"-$p"} ) {
			$font{"-font_$p"} = $value;
		}
		else {
			my $method = "get_font_$p";
			if ( $value = $node->$method ) {
				$font{"-font_$p"} = $value;
			}
		}
	}

    # get cartesian coordinates for root and leftmost and rightmost tip
    my ( $cx, $cy ) = ( $root->get_x, $root->get_y );
    my ( $rx, $ry ) = ( $rmtl->get_x, $rmtl->get_y );
    my ( $lx, $ly ) = ( $lmtl->get_x, $lmtl->get_y );

    # handle radial projection, either phylogram or cladogram
    if ( $td->get_shape =~ /radial/i ) {

        # compute tallest node in the clade and radius from the root
        my $radius;
        if ( @$desc ) {
            for my $d ( @$desc ) {

                # pythagoras
                my ( $x1, $y1 ) = ( $d->get_x, $d->get_y );
                my $h1 = sqrt( abs($cx-$x1)*abs($cx-$x1) + abs($cy-$y1)*abs($cy-$y1) );
                $radius = $h1 if not defined $radius; # initialize
                $radius = $h1 if $h1 >= $radius; # bump up if higher value
            }
        }
        else {
                # pythagoras
                my ( $x1, $y1 ) = ( $node->get_x, $node->get_y );
                $radius = sqrt( abs($cx-$x1)*abs($cx-$x1) + abs($cy-$y1)*abs($cy-$y1) );
        }

        # compute angles and coordinates of start and end of arc
        my $offset = $td->get_clade_label_width * $ncl;
        $radius += ( $tho * 2 + $tw + $offset );
        my ( $rr, $ra ) = $td->cartesian_to_polar( ($rx-$cx), ($ry-$cy) ); # rightmost
        my ( $lr, $la ) = $td->cartesian_to_polar( ($lx-$cx), ($ly-$cy) ); # leftmost
        my ( $x1, $y1 ) = $td->polar_to_cartesian( $radius, $ra ); # + add origin!
        my ( $x2, $y2 ) = $td->polar_to_cartesian( $radius, $la ); # + add origin!

        # draw line and label
        my $ntips = $node->get_terminals;
        my $rtips = $root->get_terminals;
        my $large = (scalar(@$ntips)/scalar(@$rtips)) > 1/2 ? 1 : 0; # spans majority of tips
        $self->_draw_arc(
            '-x1' => $x1 + $cx,
            '-y1' => $y1 + $cy,
            '-x2' => $x2 + $cx,
            '-y2' => $y2 + $cy,
            '-radius' => $radius,
            '-large'  => $large,
            '-sweep'  => 0,
        );

        # include $tho
        my ( $tx1, $ty1 ) = $td->polar_to_cartesian(($radius+$tho),$ra); # + add origin!
        $self->_draw_text( %font,
        	'-x' => $tx1 + $cx,
        	'-y' => $ty1 + $cy,
        	'-rotation' => [ $ra, $tx1 + $cx, $ty1 + $cy ],
        );
    }

    # can do the same thing for clado and phylo
    else {

        # fetch the tallest node in t
        my $x1;
        for my $d ( @$desc ) {
            my $x = $d->get_x;
            $x1 = $x if not defined $x1; # initialize
            $x1 = $x if $x >= $x1; # bump if $higher
        }

        # draw line and label
        my $offset = $td->get_clade_label_width * $ncl;
        $x1 += ( $tho * 2 + $tw + $offset );
        my ( $y1, $y2 ) = ( $lmtl->get_y, $rmtl->get_y );
        $self->_draw_line(
            '-x1' => $x1,
            '-x2' => $x1,
            '-y1' => $y1,
            '-y2' => $y2,
        );
        $self->_draw_text( %font,
            '-x' => ($x1+$tho),
            '-y' => $y1,
            '-rotation' => [ 90, ($x1+$tho), $y1 ],
        );
    }


}

sub _draw_collapsed {
    $logger->info("drawing collapsed node");
    my ( $self, $node ) = @_;
    my $td = $self->_drawer;
    $node->set_collapsed(0);

    # Get the height of the tallest node above the collapsed clade; for cladograms this
    # is 1, for phylograms it's the sum of the branch lengths. Then, compute x1 and x2,
    # i.e. the tip and the base of the triangle, which consequently are different between
    # cladograms and phylograms.
    my $tallest = 0;
    my ( $x1, $x2 );
    my $clado = $td->get_mode =~ m/clado/i;
    if ( $clado ) {
        $tallest = 1;
        $x1 = $node->get_x - $tallest * $td->_get_scalex;
        $x2 = $node->get_x;
    }
    else {
        $node->visit_depth_first(
            '-pre' => sub {
                my $n = shift;
                my $height = $n->get_parent->get_generic('height') + $n->get_branch_length;
                $n->set_generic( 'height' => $height );
                $tallest = $height if $height > $tallest;
            }
        );
        $tallest -= $node->get_branch_length;
        $x1 = $node->get_x;
        $x2 = ( $tallest * $td->_get_scalex + $node->get_x );
    }

    # draw the collapsed triangle
    my $padding = $td->get_padding;
    my $cladew  = $td->get_collapsed_clade_width($node);
    my $y1 = $node->get_y;
    $self->_draw_triangle(
        '-fill'   => $node->get_node_colour,
        '-stroke' => $node->get_node_outline_colour,
        '-width'  => $td->get_branch_width($node),
        '-url'    => $node->get_link,
        'id'      => 'collapsed' . $node->get_id,
        'class'   => 'collapsed',
        '-x1'     => $x1,
        '-y1'     => $y1,
        '-x2'     => $x2,
        '-y2'     => $y1 + $cladew / 2 * $td->_get_scaley,
        '-x3'     => $x2,
        '-y3'     => $y1 - $cladew / 2 * $td->_get_scaley,
    );

    # draw the collapsed clade label
    if ( my $name = $node->get_name ) {
        $name =~ s/_/ /g;
        $name =~ s/^'(.*)'$/$1/;
        $name =~ s/^"(.*)"$/$1/;
        $self->_draw_text(
            'id'           => 'collapsed_text' . $node->get_id,
            'class'        => 'collapsed_text',
            '-font_face'   => $node->get_font_face,
            '-font_size'   => $node->get_font_size,
            '-font_style'  => $node->get_font_style,
            '-font_colour' => $node->get_font_colour,
            '-font_weight' => $node->get_font_weight,
            '-x'           => int( $x2 + $td->get_text_horiz_offset ),
            '-y'           => int( $y1 + $td->get_text_vert_offset ),
            '-text'        => $name,
        );
    }
    $node->set_collapsed(1);
}

=begin comment

 Type    : Internal method.
 Title   : _draw_scale
 Usage   : $svg->_draw_scale();
 Function: Draws scale for phylograms
 Returns :
 Args    : None

=end comment

=cut

sub _draw_scale {
    my $self   = shift;
    my $drawer = $self->_drawer;

    # if not options provided, won't attempt to draw a scale
    if ( my $options = $drawer->get_scale_options ) {
		my $tree   = $self->_tree;
		my $root   = $tree->get_root;
		my $rootx  = $root->get_x;
		my $height = $drawer->get_height;

    	# read and convert the font preferences for the _draw_text method
        my %font;
        if ( $options->{'-font'} and ref $options->{'-font'} eq 'HASH' ) {
            for my $key ( keys %{ $options->{'-font'} } ) {
                my $nk = $key;
                $nk =~ s/-/-font_/;
                $font{$nk} = $options->{'-font'}->{$key};
            }
        }

		# convert width and major/minor ticks to absolute pixel values
        my ( $major, $minor ) = ( $options->{'-major'}, $options->{'-minor'} );
        my $width  = $options->{'-width'};
        my $blocks = $options->{'-blocks'};

        # find the tallest tip, irrespective of it being collapsed
        my ($tt) = sort { $b->get_x <=> $a->get_x } @{ $tree->get_entities };
        my $ttx = $tt->get_x;
        my $ptr = $tt->calc_path_to_root;
        if ( $width =~ m/^(\d+)%$/ ) {
            $width = ( $1 / 100 ) * ( $ttx - $rootx );
        }
        if ( my $units = $options->{'-units'} ) {

            # now we need to calculate how much each branch length unit (e.g.
            # substitutions) is in pixels. The $width then becomes the length
            # of one branch length unit in pixels times $units
            my $unit_in_pixels = ( $ttx - $rootx ) / $ptr;
            $width = $units * $unit_in_pixels;
        }
        if ( $major =~ m/^(\d+)%$/ ) {
            $major = ( $1 / 100 ) * $width;
        }
        if ( $minor =~ m/^(\d+)%$/ ) {
            $minor = ( $1 / 100 ) * $width;
        }
        if ( $blocks and $blocks =~ m/^(\d+)%$/ ) {
        	$blocks = ( $1 / 100 ) * $width;
        }

        # draw scale line and apply label
        my $x1 = $options->{'-reverse'} ? $ttx : $rootx;
        my $ws = $options->{'-reverse'} ? -1 : 1;
        my $ts = $options->{'-reverse'} ?  0 : 1;
        $self->_draw_line(
            '-x1'   => $x1,
            '-y1'   => ( $height - 40 ),
            '-x2'   => $x1 + ($width*$ws),
            '-y2'   => ( $height - 40 ),
            'class' => 'scale_bar',
        );
        $self->_draw_text( %font,
            '-x'    => ( $x1 + ($width*$ts) + $drawer->get_text_horiz_offset ),
            '-y'    => ( $height - 30 ),
            '-text' => $options->{'-label'} || ' ',
            'class' => 'scale_label',
        );

        # pre-compute indexes so we can reverse
        my ( @maji, @mini, @blocksi, $j ); # major/minor/blocks indexes
        if ( $options->{'-reverse'} ) {
            for ( my $i = $ttx ; $i >= ( $ttx - $width ) ; $i -= $minor ) {
                if ( not $j % sprintf('%.0f', $major/$minor) ) {
                	push @maji, $i;
                	if ( $blocks and not scalar(@maji) % 2 ) {
                		push @blocksi, $i;
                	}
                }
                push @mini, $i;
                $j++;
            }
        }
        else {
            for ( my $i = $rootx ; $i <= ( $rootx + $width ) ; $i += $minor ) {
                if ( not $j % sprintf('%.0f', $major/$minor) ) {
                	push @maji, $i;
                	if ( $blocks and not scalar(@maji) % 2 ) {
                		push @blocksi, $i;
                	}
                }
                push @mini, $i;
                $j++;
            }
        }

        # draw ticks and labels
        my $major_text = 0;
        my $major_scale = ( $major / $width ) * $ptr;
        my $tmpl = $options->{'-tmpl'} || '%s';
        my $code = ref $tmpl ? $tmpl : sub { sprintf $tmpl, shift };
        for my $i ( @maji ) {
            $self->_draw_line(
                '-x1'   => $i,
                '-y1'   => ( $height - 40 ),
                '-x2'   => $i,
                '-y2'   => ( $height - 25 ),
                'class' => 'scale_major',
            );
            $self->_draw_text( %font,
                '-x'    => $i,
                '-y'    => ( $height - 5 ),
                '-text' => $code->( $major_text ),
                'class' => 'major_label',
            );
            $major_text += $major_scale;
        }
        for my $i ( @mini ) {
            next if not $i % $major;
            $self->_draw_line(
                '-x1'   => $i,
                '-y1'   => ( $height - 40 ),
                '-x2'   => $i,
                '-y2'   => ( $height - 35 ),
                'class' => 'scale_minor',
            );
        }

        # draw blocks
        if ( @blocksi ) {
        	my @y = map { $_->get_y } sort { $a->get_y <=> $b->get_y } @{ $tree->get_entities };
        	my $y = $y[0] - 20;
        	my $height = ( $y[-1] - $y[0] ) + 40;
        	my $width  = ( $blocksi[0] - $blocksi[1] ) / 2;
			for my $i ( @blocksi ) {
				$self->_draw_rectangle(
					'-x'      => $i,
					'-y'      => $y,
					'-height' => $height,
					'-width'  => $width,
					'-fill'   => 'whitesmoke',
					'-stroke_width' => 0,
					'-stroke'       => 'whitesmoke',
				);
			}
        }
    }
}

=begin comment

 Type    : Internal method.
 Title   : _draw_branch
 Usage   : $svg->_draw_branch($node);
 Function: Draws internode between $node and $node->get_parent, if any
 Returns :
 Args    :

=end comment

=cut

sub _draw_branch {
    my ( $self, $node ) = @_;
    $logger->info( "Drawing branch for " . $node->get_internal_name );
    if ( my $parent = $node->get_parent ) {
        my ( $x1, $x2 ) = ( int $parent->get_x, int $node->get_x );
        my ( $y1, $y2 ) = ( int $parent->get_y, int $node->get_y );
        my $shape = $self->_drawer->get_shape;
        my $drawer = '_draw_curve';
        if ( $shape =~ m/CURVY/i ) {
            $drawer = '_draw_curve';
        }
        elsif ( $shape =~ m/RECT/i ) {
            $drawer = '_draw_multi';
        }
        elsif ( $shape =~ m/DIAG/i ) {
            $drawer = '_draw_line';
        }
        elsif ( $shape =~ m/UNROOTED/i ) {
            $drawer = '_draw_line';
        }
        elsif ( $shape =~ m/RADIAL/i ) {
            return $self->_draw_radial_branch($node);
        }
        return $self->$drawer(
            '-x1'    => $x1,
            '-y1'    => $y1,
            '-x2'    => $x2,
            '-y2'    => $y2,
            '-width' => $self->_drawer->get_branch_width($node),
            '-color' => $node->get_branch_color
        );
    }
}

=begin comment

 Type    : Internal method.
 Title   : _draw_radial_branch
 Usage   : $svg->_draw_radial_branch($node);
 Function: Draws radial internode between $node and $node->get_parent, if any
 Returns :
 Args    :

=end comment

=cut

sub _draw_radial_branch {
    my ( $self, $node ) = @_;

    if ( my $parent = $node->get_parent ) {
        my $td = $self->_drawer;
        my $center_x = $td->get_width / 2;
        my $center_y = $td->get_height / 2;
        my $width    = $td->get_branch_width($node);

        # first the straight piece up to the arc
        my ( $x1, $y1 ) = ( $node->get_x, $node->get_y );
        my $rotation = $node->get_rotation;
        my $parent_radius = $parent->get_generic('radius');
        my ( $x2, $y2 ) = $td->polar_to_cartesian( $parent_radius, $rotation );
        $x2 += $center_x;
        $y2 += $center_y;
        $self->_draw_line(
            '-x1'      => $x1,
            '-y1'      => $y1,
            '-x2'      => $x2,
            '-y2'      => $y2,
            '-width'   => $width,
            '-color'   => $node->get_branch_color,
            '-linecap' => 'square'
        );

        # then the arc
        my ( $x3, $y3 ) = ( $parent->get_x, $parent->get_y );
        if ( $parent->get_rotation < $rotation ) {
            ( $x2, $x3 ) = ( $x3, $x2 );
            ( $y2, $y3 ) = ( $y3, $y2 );
        }
        $self->_draw_arc(
            '-x1'      => $x2,
            '-y1'      => $y2,
            '-x2'      => $x3,
            '-y2'      => $y3,
            '-radius'  => $parent_radius,
            '-width'   => $width,
            '-color'   => $node->get_branch_color,
            '-linecap' => 'square'
        )
    }
}

sub _font_path {
    my $self = shift;
    my $font = shift || $DEFAULT_FONT;
    if ( $^O =~ /darwin/ ) {
        push @FONT_DIR, '/System/Library/Fonts', '/Library/Fonts';
    }
    elsif ( $^O =~ /linux/ ) {
        push @FONT_DIR, '/usr/share/fonts';
    }
    elsif ( $^O =~ /MSWin/ ) {
        push @FONT_DIR, $ENV{'WINDIR'} . '\Fonts';
    }
    else {
        $logger->warn("Don't know where fonts are on $^O");
    }
    for my $dir ( @FONT_DIR ) {
        if ( -e "${dir}/${font}.ttf" ) {
            return "${dir}/${font}.ttf";
        }
    }
    $logger->warn("Couldn't find font $font");
}

=head1 SEE ALSO

There is a mailing list at L
for any user or developer questions and discussions.

=over

=item L

Treedrawer subclasses are called by the L object. Look
there to learn how to create tree drawings.

=item L

Also see the manual: L and L.

=back

=head1 CITATION

If you use Bio::Phylo in published research, please cite it:

B, B, B, B
and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
I B<12>:63.
L

=cut

1;