view release on metacpan or  search on metacpan

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

=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'           => 0,
        'TIP_RADIUS'            => 0,
        'TEXT_HORIZ_OFFSET'     => 6,
        'TEXT_VERT_OFFSET'      => 4,
        'TEXT_WIDTH'            => 150,
        'TREE'                  => undef,
        '_SCALEX'               => 1,
        '_SCALEY'               => 1,
        'FORMAT'                => 'Svg',
        'SCALE'                 => undef,
        'BRANCH_WIDTH'          => 1,
        'COLLAPSED_CLADE_WIDTH' => 6,
        'CLADE_LABEL_WIDTH'     => 36,
        'PIE_COLORS'            => {},
    };
    bless $self, $class;
    if (@_) {
        my %opts = looks_like_hash @_;
        for my $key ( keys %opts ) {
            my $mutator = lc $key;
            $mutator =~ s/^-/set_/;
            $self->$mutator( $opts{$key} );
        }
    }
    return $self;
}

sub _cascading_setter {
    my ( $self, $value ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ( my $tree = $self->get_tree ) {
        if ( $tree->can($subroutine) ) {
            $tree->$subroutine($value);
        }
    }
    $subroutine =~ s/^set_//;
    $self->{ uc $subroutine } = $value;
    return $self;
}

sub _cascading_getter {
    my ( $self, $invocant ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ( $invocant ) {
        
        # The general idea is that there are certain properties that can potentially be
        # set globally (i.e. in this package) or at the level of the object it applies
        # to. For example, maybe we want to set the node radius globally here, or maybe
        # we want to set it on the node. The idea, here, is then that we might first
        # check to see if the values are set on $invocant, and if not, return the global
        # value. The way this used to be done was by calling ->can(), however, because of
        # the way in which method calls are handled by the Draw*Role classes, we can't
        # do that.
        #if ( $invocant->can($subroutine) ) {
            my $value = $invocant->$subroutine();
            if ( defined $value ) {
                return $value;
            }
        #}
    }
    $subroutine =~ s/^get_//;
    return $self->{ uc $subroutine };
}

=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

=cut

sub set_format {
    my ( $self, $format ) = @_;
    $format = ucfirst( lc($format) );
    if ( looks_like_class __PACKAGE__ . '::' . $format ) {
        $self->{'FORMAT'} = $format;
        return $self;
    }
    else {
        throw 'BadFormat' => "'$format' is not a valid image format";
    }
}

=item set_width()

Sets image width.

 Type    : Mutator
 Title   : set_width