File Coverage

blib/lib/Bio/Phylo/Matrices/TypeSafeData.pm

Criterion	Covered	Total	%
statement	84	95	88.4
branch	18	26	69.2
condition	10	21	47.6
subroutine	19	21	90.4
pod	12	12	100.0
total	143	175	81.7

package Bio::Phylo::Matrices::TypeSafeData;
use strict;
use base 'Bio::Phylo::Listable';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw'_MATRIX_ /looks_like/';
use Bio::Phylo::Matrices::Datatype;
{
    my $logger = __PACKAGE__->get_logger;
    my %type;
    my $MATRIX_CONSTANT = _MATRIX_;

=head1 NAME

Bio::Phylo::Matrices::TypeSafeData - Superclass for objects that contain
character data

=head1 SYNOPSIS

 # No direct usage

=head1 DESCRIPTION

This is a superclass for objects holding character data. Objects that inherit
from this class (typically matrices and datum objects) yield functionality to
handle datatype objects and use them to validate data such as DNA sequences,
continuous data etc.

=head1 METHODS

=head2 CONSTRUCTOR

=over

=item new()

TypeSafeData constructor.

 Type    : Constructor
 Title   : new
 Usage   : No direct usage, is called by child class;
 Function: Instantiates a Bio::Phylo::Matrices::TypeSafeData
 Returns : a Bio::Phylo::Matrices::TypeSafeData child class
 Args    : -type        => (data type - required)
           Optional:
           -missing     => (the symbol for missing data)
           -gap         => (the symbol for gaps)
           -lookup      => (a character state lookup hash)
           -type_object => (a datatype object)

=cut

    sub new : Constructor {

        # is child class
        my $class = shift;

        # process args
        my %args = looks_like_hash @_;

        # notify user
        if ( not $args{'-type'} and not $args{'-type_object'} ) {
            $logger->info("No data type provided, will use 'standard'");
            unshift @_, '-type', 'standard';
        }
        if ( $args{'-characters'} ) {
            if ( $args{'-type'} ) {
                $args{'-characters'}->set_type( $args{'-type'} );
            }
            elsif ( $args{'-type_object'} ) {
                $args{'-characters'}->set_type_object( $args{'-type_object'} );
            }
        }

        # notify user
        $logger->debug("constructor called for '$class'");

        # go up inheritance tree, eventually get an ID
        return $class->SUPER::new(@_);
    }

=back

=head2 MUTATORS

=over

=item set_type()

Set data type.

 Type    : Mutator
 Title   : set_type
 Usage   : $obj->set_type($type);
 Function: Sets the object's datatype.
 Returns : Modified object.
 Args    : Argument must be a string, one of
           continuous, custom, dna, mixed,
           protein, restriction, rna, standard

=cut

    sub set_type {
        my $self = shift;
        my $arg  = shift;
        my ( $type, @args );
        if ( looks_like_instance( $arg, 'ARRAY' ) ) {
            @args = @{$arg};
            $type = shift @args;
        }
        else {
            @args = @_;
            $type = $arg;
        }
        $logger->info("setting type '$type'");
        my $obj = Bio::Phylo::Matrices::Datatype->new( $type, @args );
        $self->set_type_object($obj);
        if ( UNIVERSAL::can($self,'_type') and $self->_type == $MATRIX_CONSTANT ) {
            for my $row ( @{ $self->get_entities } ) {
                $row->set_type_object($obj);
            }
        }
        return $self;
    }

=item set_missing()

Set missing data symbol.

 Type    : Mutator
 Title   : set_missing
 Usage   : $obj->set_missing('?');
 Function: Sets the symbol for missing data
 Returns : Modified object.
 Args    : Argument must be a single
           character, default is '?'

=cut

    sub set_missing {
        my ( $self, $missing ) = @_;
        if ( $self->can('get_matchchar') and $self->get_matchchar and $missing eq $self->get_matchchar )
        {
            throw 'BadArgs' =>
              "Missing character '$missing' already in use as match character";
        }
        $logger->info("setting missing '$missing'");
        $self->get_type_object->set_missing($missing);
        $self->validate;
        return $self;
    }

=item set_gap()

Set gap data symbol.

 Type    : Mutator
 Title   : set_gap
 Usage   : $obj->set_gap('-');
 Function: Sets the symbol for gaps
 Returns : Modified object.
 Args    : Argument must be a single
           character, default is '-'

=cut

    sub set_gap {
        my ( $self, $gap ) = @_;
        if ( $self->can('get_matchchar') and $self->get_matchchar and $self->get_matchchar eq $gap ) {
            throw 'BadArgs' =>
              "Gap character '$gap' already in use as match character";
        }
        $logger->info("setting gap '$gap'");
        $self->get_type_object->set_gap($gap);
        $self->validate;
        return $self;
    }

=item set_lookup()

Set ambiguity lookup table.

 Type    : Mutator
 Title   : set_lookup
 Usage   : $obj->set_gap($hashref);
 Function: Sets the symbol for gaps
 Returns : Modified object.
 Args    : Argument must be a hash
           reference that maps allowed
           single character symbols
           (including ambiguity symbols)
           onto the equivalent set of
           non-ambiguous symbols

=cut

    sub set_lookup {
        my ( $self, $lookup ) = @_;
        $logger->info("setting character state lookup hash");
        $self->get_type_object->set_lookup($lookup);
        $self->validate;
        return $self;
    }

=item set_type_object()

Set data type object.

 Type    : Mutator
 Title   : set_type_object
 Usage   : $obj->set_gap($obj);
 Function: Sets the datatype object
 Returns : Modified object.
 Args    : Argument must be a subclass
           of Bio::Phylo::Matrices::Datatype

=cut

    sub set_type_object : Clonable DeepClonable {
        my ( $self, $obj ) = @_;
        $logger->info("setting character type object");
        $type{ $self->get_id } = $obj;
        eval { $self->validate };
        if ($@) {
            undef($@);
            if ( my @char = $self->get_char ) {
                $self->clear;
                $logger->warn(
"Data contents of $self were invalidated by new type object."
                );
            }
        }
        return $self;
    }

=back

=head2 ACCESSORS

=over

=item get_type()

Get data type.

 Type    : Accessor
 Title   : get_type
 Usage   : my $type = $obj->get_type;
 Function: Returns the object's datatype
 Returns : A string
 Args    : None

=cut

    sub get_type {
        my $to = shift->get_type_object;
        if ($to) {
            return $to->get_type;
        }
        else {
            throw 'API' => "Missing data type object!";
        }
    }

=item get_missing()

Get missing data symbol.

 Type    : Accessor
 Title   : get_missing
 Usage   : my $missing = $obj->get_missing;
 Function: Returns the object's missing data symbol
 Returns : A string
 Args    : None

=cut

    sub get_missing {
        my $to = shift->get_type_object;
        if ($to) {
            return $to->get_missing;
        }
        else {
            throw 'API' => "Missing data type object!";
        }
    }

=item get_gap()

Get gap symbol.

 Type    : Accessor
 Title   : get_gap
 Usage   : my $gap = $obj->get_gap;
 Function: Returns the object's gap symbol
 Returns : A string
 Args    : None

=cut

    sub get_gap { shift->get_type_object->get_gap }

=item get_lookup()

Get ambiguity lookup table.

 Type    : Accessor
 Title   : get_lookup
 Usage   : my $lookup = $obj->get_lookup;
 Function: Returns the object's lookup hash
 Returns : A hash reference
 Args    : None

=cut

    sub get_lookup { shift->get_type_object->get_lookup }

=item get_type_object()

Get data type object.

 Type    : Accessor
 Title   : get_type_object
 Usage   : my $obj = $obj->get_type_object;
 Function: Returns the object's linked datatype object
 Returns : A subclass of Bio::Phylo::Matrices::Datatype
 Args    : None

=cut

    sub get_type_object { $type{ $_[0]->get_id } }

=back

=head2 INTERFACE METHODS

=over

=item validate()

Validates the object's contents

 Type    : Interface method
 Title   : validate
 Usage   : $obj->validate
 Function: Validates the object's contents
 Returns : True or throws Bio::Phylo::Util::Exceptions::InvalidData
 Args    : None
 Comments: This is an abstract method, i.e. this class doesn't
           implement the method, child classes have to

=cut

    sub validate {
        shift->_validate;
    }

    sub _validate {
        throw 'NotImplemented' => 'Not implemented!';
    }

    sub _cleanup {
        my $self = shift;
        if ( $self and defined( my $id = $self->get_id ) ) {
            delete $type{ $self->get_id };
        }
    }
}

=back

=cut

# podinherit_insert_token

=head1 SEE ALSO

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

=over

=item L

This object inherits from L, so the methods defined
therein are also applicable to L objects.

=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;