view release on metacpan or  search on metacpan

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

=cut

my $logger = Bio::Phylo::Util::Logger->new;
my $black  = 0;
my $white  = 255;
my %colors;
my $PI = _PI_;

sub _new {
    my $class = shift;
    my %args  = @_;
    my $commands;
    my $self = $class->SUPER::_new( %args, '-api' => \$commands );
    return bless $self, $class;
}

sub _draw_pies {
    my $self = shift;
    my $api  = $self->_api;
    $self->_tree->visit_level_order(
        sub {
            my $node = shift;
            if ( not $node->get_collapsed ) {
                my $cx = sprintf( "%.3f", $node->get_x );
                my $cy = sprintf( "%.3f", $node->get_y );
                my $r;
                if ( $node->is_internal ) {
                    $r =
                      sprintf( "%.3f", $self->_drawer->get_node_radius($node) );
                }
                else {
                    $r =
                      sprintf( "%.3f", $self->_drawer->get_tip_radius($node) );
                }
                if ( my $pievalues = $node->get_generic('pie') ) {
                    my @keys  = keys %{$pievalues};
                    my $start = 0;
                    my $total;
                    $total += $pievalues->{$_} for @keys;
                    for my $i ( 0 .. $#keys ) {
                        next if not $pievalues->{ $keys[$i] };
                        my $slice =
                          $pievalues->{ $keys[$i] } / $total * 2 * $PI;
                        my $color = $colors{ $keys[$i] };
                        if ( not $color ) {
                            $colors{ $keys[$i] } = $color =
                              int( ( $i / $#keys ) * 256 );
                        }
                        my $stop = $start + $slice;
                        $$api .=
                          "    drawArc($cx,$cy,$r,0,1,$color,$start,$stop);\n";
                        $start += $slice;
                    }
                }
            }
        }
    );
}

sub _draw_legend {
    my $self = shift;
    if (%colors) {
        my $api  = $self->_api;
        my $tree = $self->_tree;
        my $draw = $self->_drawer;
        my @keys = keys %colors;
        my $increment =
          ( $tree->get_tallest_tip->get_x - $tree->get_root->get_x ) /
          scalar @keys;
        my $x = sprintf( "%.3f", $tree->get_root->get_x + 5 );
        foreach my $key (@keys) {
            my $y      = sprintf( "%.3f", $draw->get_height - 90 );
            my $width  = sprintf( "%.3f", $increment - 10 );
            my $height = sprintf( "%.3f", 10.0 );
            my $color  = int $colors{$key};
            $$api .= "    drawRectangle($x,$y,$width,$height,$color);\n";
            $self->_draw_text(
                '-x'    => int($x),
                '-y'    => int( $draw->get_height - 60 ),
                '-text' => $key || ' ',
            );
            $x += $increment;
        }
        $self->_draw_text(
            '-x' => int(
                $tree->get_tallest_tip->get_x + $draw->get_text_horiz_offset
            ),
            '-y'    => int( $draw->get_height - 80 ),
            '-text' => 'Node value legend',
        );
    }
}

sub _finish {
    my $self     = shift;
    my $commands = $self->_api;
    my $tmpl     = do { local $/; <DATA> };
    return sprintf( $tmpl,
        __PACKAGE__, my $time = localtime(),
        $self->_drawer->get_width, $self->_drawer->get_height,
        $white, $$commands );
}

sub _draw_text {
    my $self = shift;
    my %args = @_;
    my ( $x, $y, $text, $url, $stroke ) = @args{qw(-x -y -text -url -color)};
    $stroke = $black if not defined $stroke;
    my $api = $self->_api;
    $$api .= "    drawText(\"$text\",$x,$y,$stroke);\n";
}

sub _draw_line {
    my $self = shift;
    my %args = @_;
    my @keys = qw(-x1 -y1 -x2 -y2 -width -color);
    my ( $x1, $y1, $x2, $y2, $width, $color ) = @args{@keys};
    $color = $black if not defined $color;
    $width = 1      if not defined $width;
    my $api = $self->_api;
    $$api .= sprintf("    drawLine(%u,%u,%u,%u,%u,%u);\n",$x1,$y1,$x2,$y2,$color,$width);
}

sub _draw_curve {
    my $self = shift;
    my $api  = $self->_api;
    my %args = @_;
    my @keys = qw(-x1 -y1 -x2 -y2 -width -color);
    my ( $x1, $y1, $x3, $y3, $width, $color ) = @args{@keys};
    $x1 = sprintf( "%.3f", $x1 );
    $x3 = sprintf( "%.3f", $x3 );
    $y1 = sprintf( "%.3f", $y1 );
    $y3 = sprintf( "%.3f", $y3 );
    $color = $black if not defined $color;
    $width = 1      if not defined $width;
    $$api .= "    drawCurve($x1,$y1,$x3,$y3,$color,$width);\n";
}

sub _draw_arc {
    my $self = shift;
    my $api  = $self->_api;
    my %args = @_;
    my @keys = qw(-x1 -y1 -x2 -y2 -radius -width -color);
    my ( $x1, $y1, $x2, $y2, $radius, $lineWidth, $lineColor ) = @args{@keys};
    $lineColor = $black if not defined $lineColor;
    $lineWidth = 1      if not defined $lineWidth;
    $radius = 0         if not defined $radius;
    $radius *= 2;
    my $fillColor = $white;