view release on metacpan or  search on metacpan

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

    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;
            $logger->debug("going to draw branch");
            $self->_draw_branch($node);
            if ( $node->get_collapsed ) {
            	$logger->debug("going to draw collapsed clade");
                $self->_draw_collapsed($node);
            }
            else {
                if ( my $name = $node->get_name ) {
                	$logger->debug("going to draw node label '$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,
                        '-url'         => $node->get_link,
                        'class'        => $is_terminal ? 'taxon_text' : 'node_text',
                    );
                }
            }
            if ( $r ) {
				$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 ) {
            	if ( not $self->_tree->get_meta_object('map:tree_size') ) {
            		my $tips = $self->_tree->get_root->get_terminals;
            		$self->_tree->set_meta_object( 'map:tree_size' => scalar(@$tips) );
            	}
            	$logger->debug("going to draw clade label");
            	$self->_draw_clade_label($node);
            }
        }
    );
    $logger->debug("going to draw node pie charts");
    $self->_draw_pies;
    $logger->debug("going to draw legend");
    $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 $desc = $node->get_descendants;
    my $ntips = [ grep { $_->is_terminal } @$desc ];
    my $lmtl = $node->get_leftmost_terminal;
    my $rmtl = $node->get_rightmost_terminal;
    my $root = $node->get_tree->get_root;    
    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 || {};