view release on metacpan or  search on metacpan

lib/Bio/Phylo/Treedrawer/Png.pm  view on Meta::CPAN

package Bio::Phylo::Treedrawer::Png;
use strict;
use warnings;
use base 'Bio::Phylo::Treedrawer::Abstract';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw'looks_like_hash _PI_';
use Bio::Phylo::Util::Dependency qw'GD::Simple GD::Polyline GD::Polygon GD';
use Bio::Phylo::Util::Logger;

my $logger   = Bio::Phylo::Util::Logger->new;
my $PI       = _PI_;
my $AA       = 3;
my $whiteHex = 'FFFFFF';
my $blackHex = '000000';
my %colors;

=begin comment

This module does all the heavy lifting for PNG, GIF and JPEG bitmap images. It
achieves anti-aliasing by first multiplying all coordinates, radii and line-
widths with a constant (default is $AA), then in the last-before-final step
the entire bitmap is downsampled, during which GD averages adjacent pixels,
which has the effect of anti-aliasing. This approach is taken because GD
doesn't seem to recognize line-widths if anti-aliasing has been turned on.
Because TrueType fonts are already anti-aliased we record where text needs to
end up after downsampling, and then in the last step we add the text into the
downsampled image.

=end comment

=head1 NAME

Bio::Phylo::Treedrawer::Png - Graphics format writer used by treedrawer, no
serviceable parts inside

=head1 DESCRIPTION

This module creates a png file from a Bio::Phylo::Forest::DrawTree
object. It is called by the L<Bio::Phylo::Treedrawer> object, so look there to
learn how to create tree drawings.


=begin comment

Translates a six-letter HEX code to rgb, i.e. three numbers between 0 and 255

=end comment

=cut

sub _hex2rgb ($) {
    my $hex = shift;
    my ( $r, $g, $b ) = ( 0, 0, 0 );
    if ( $hex =~ m/^(..)(..)(..)$/ ) {
        $r = hex($1);
        $g = hex($2);
        $b = hex($3);
    }
    return $r, $g, $b;
}

=begin comment

Allocates colors in the index, uses caching

=end comment

=cut

sub _make_color {
    my ( $self, $hex ) = @_;
    $hex = uc $hex;
    if ( exists $colors{$hex} ) {
        return $colors{$hex};
    }
    if ( not $hex ) {
        if ( not $colors{$blackHex} ) {
            $colors{$blackHex} = $self->_api->colorAllocate( _hex2rgb $blackHex );
        }
        return $colors{$blackHex};
    }
    my $colorObj = $self->_api->colorAllocate( _hex2rgb $hex );
    $colors{$hex} = $colorObj;
    return $colorObj;
}

# returns multiplication factor for anti-aliasing

sub _aa { shift->{'AA'} || $AA }

# multiplies all arguments by the anti-aliasing upsampling factor

sub _upsample {
    my ( $self, @value ) = @_;
    my $aa = $self->_aa;
    my @result;
    push @result, $_ * $aa for @value;
    return @result;
}

=begin comment

 Type    : Constructor
 Title   : _new
 Usage   : my $png = Bio::Phylo::Treedrawer::Png->_new(%args);
 Function: Initializes a Bio::Phylo::Treedrawer::Png object.
 Alias   :
 Returns : A Bio::Phylo::Treedrawer::Png object.
 Args    : none.

=end comment

=cut

sub _new {
    my $class = shift;
    my %opt   = looks_like_hash @_;
    
    # instantiate object
    my $aa = $opt{'-aa'} || $AA;
    my $td = $opt{'-drawer'};
    delete $opt{'-aa'};
    my $self = $class->SUPER::_new( %opt );
    $self->{'AA'}  = $aa;
    $self->{'TXT'} = [];
    $self->{'API'} = GD::Image->new(
        $self->_upsample( $td->get_width, $td->get_height ),
        1,
    );
    
    # set background color
    $self->_api->fill( 0,0, $self->_make_color( $whiteHex ) );
    
    return $self;    
}

=begin comment

Downsamples the bitmap that has been created so far, in order to achieve an
anti-aliasing effect. Then adds the text strings in the correct coordinates
for the downsampled image.

=end comment

=cut

sub _downsample {
    $logger->debug("downsampling");
    my $self = shift;
    my ( $w, $h ) = ( $self->_drawer->get_width, $self->_drawer->get_height );
    my $aa = $self->_aa;
    my $result = GD::Image->new( $w, $h, 1 );
    $result->copyResampled( $self->_api, 0, 0, 0, 0, $w, $h, $w * $aa, $h * $aa);
    for my $txtargs ( @{ $self->{'TXT'} } ) {
        $result->stringFT( @{ $txtargs } );
    }   
    return $result;
}

=begin comment

# finish drawing, export PNG

=end comment

=cut

sub _finish {