Bio-Phylo
view release on metacpan or search on metacpan
lib/Bio/Phylo.pm view on Meta::CPAN
package Bio::Phylo;
use strict;
use warnings;
use Bio::PhyloRole;
use base 'Bio::PhyloRole';
# don't use Scalar::Util::looks_like_number directly, use wrapped version
use Scalar::Util qw'weaken blessed';
use Bio::Phylo::Util::CONSTANT '/looks_like/';
use Bio::Phylo::Util::IDPool; # creates unique object IDs
use Bio::Phylo::Util::Exceptions 'throw'; # defines exception classes and throws
use Bio::Phylo::Util::Logger; # for logging, like log4perl/log4j
use Bio::Phylo::Util::MOP; # for traversing inheritance trees
use Bio::Phylo::Identifiable; # for storing unique IDs inside an instance
our ( $logger, $COMPAT ) = Bio::Phylo::Util::Logger->new;
use version 0.77; our $VERSION = qv("v2.0.2");
# mediates one-to-many relationships between taxon and nodes,
# taxon and sequences, taxa and forests, taxa and matrices.
# Read up on the Mediator design pattern to learn how this works.
require Bio::Phylo::Mediators::TaxaMediator;
{
my $taxamediator = 'Bio::Phylo::Mediators::TaxaMediator';
my $mop = 'Bio::Phylo::Util::MOP';
sub import {
my $class = shift;
if (@_) {
my %opt = looks_like_hash @_;
while ( my ( $key, $value ) = each %opt ) {
if ( $key =~ qr/^VERBOSE$/i ) {
$logger->VERBOSE( '-level' => $value, '-class' => $class );
}
elsif ( $key =~ qr/^COMPAT$/i ) {
$COMPAT = ucfirst( lc($value) );
}
else {
throw 'BadArgs' => "'$key' is not a valid argument for import";
}
}
}
return 1;
}
# the following hashes are used to hold state of inside-out objects. For
# example, $obj->set_name("name") is implemented as $name{ $obj->get_id }
# = $name. To avoid memory leaks (and subtle bugs, should a new object by
# the same id appear (though that shouldn't happen)), the hash slots
# occupied by $obj->get_id need to be reclaimed in the destructor. This
# is done by recursively calling the $obj->_cleanup methods in all of $obj's
# superclasses. To make that method easier to write, we create an array
# with the local inside-out hashes here, so that we can just iterate over
# them anonymously during destruction cleanup. Other classes do something
# like this as well.
my @fields = \(
my (
%guid,
%desc,
%score,
%generic,
%cache,
%container, # XXX weak reference
%objects # XXX weak reference
)
);
lib/Bio/Phylo.pm view on Meta::CPAN
This is the base class for the Bio::Phylo package for phylogenetic analysis using
object-oriented perl5. In this file, methods are defined that are performed by other
objects in the Bio::Phylo release that inherit from this base class (which you normally
wouldn't use directly).
For general information on how to use Bio::Phylo, consult the manual
(L<Bio::Phylo::Manual>).
If you come here because you are trying to debug a problem you run into in
using Bio::Phylo, you may be interested in the "exceptions" system as discussed
in L<Bio::Phylo::Util::Exceptions>. In addition, you may find the logging system
in L<Bio::Phylo::Util::Logger> of use to localize problems.
=head1 METHODS
=head2 CONSTRUCTOR
=over
=item new()
The Bio::Phylo root constructor is rarely used directly. Rather, many other
objects in Bio::Phylo internally go up the inheritance tree to this constructor.
The arguments shown here can therefore also be passed to any of the child
classes' constructors, which will pass them on up the inheritance tree. Generally,
constructors in Bio::Phylo subclasses can process as arguments all methods that
have set_* in their names. The arguments are named for the methods, but "set_"
has been replaced with a dash "-", e.g. the method "set_name" becomes the
argument "-name" in the constructor.
Type : Constructor
Title : new
Usage : my $phylo = Bio::Phylo->new;
Function: Instantiates Bio::Phylo object
Returns : a Bio::Phylo object
Args : Optional, any number of setters. For example,
Bio::Phylo->new( -name => $name )
will call set_name( $name ) internally
=cut
sub new : Constructor {
# $class could be a child class, called from $class->SUPER::new(@_)
# or an object, e.g. $node->new(%args) in which case we create a new
# object that's bless into the same class as the invocant. No, that's
# not the same thing as a clone.
my $class = shift;
if ( my $reference = ref $class ) {
$class = $reference;
}
# happens only and exactly once because this
# root class is visited from every constructor
my $self = $class->SUPER::new();
# register for get_obj_by_id
my $id = $self->get_id;
$objects{$id} = $self;
weaken( $objects{$id} );
# notify user
$logger->info("constructor called for '$class' - $id");
# processing arguments
if ( @_ and @_ = looks_like_hash @_ ) {
$logger->info("processing arguments");
# process all arguments
ARG: while (@_) {
my $key = shift @_;
my $value = shift @_;
# this is a bioperl arg, meant to set
# verbosity at a per class basis. In
# bioperl, the $verbose argument is
# subsequently carried around in that
# class, here we delegate that to the
# logger, which has roughly the same
# effect.
if ( $key eq '-verbose' ) {
$logger->VERBOSE(
'-level' => $value,
'-class' => $class,
);
next ARG;
}
# notify user
$logger->debug("processing constructor arg '${key}' => '${value}'");
# don't access data structures directly, call mutators
# in child classes or __PACKAGE__
my $mutator = $key;
$mutator =~ s/^-/set_/;
# backward compat fixes:
$mutator =~ s/^set_pos$/set_position/;
$mutator =~ s/^set_matrix$/set_raw/;
eval { $self->$mutator($value); };
if ($@) {
if ( blessed $@ and $@->can('rethrow') ) {
$@->rethrow;
}
elsif ( not ref($@) and $@ =~ /^Can't locate object method / ) {
throw 'BadArgs' => "The named argument '${key}' cannot be passed to the constructor of ${class}";
}
else {
throw 'Generic' => $@;
}
}
}
}
$logger->info("done processing constructor arguments");
# register with mediator
# TODO this is irrelevant for some child classes,
# so should be re-factored into somewhere nearer the
# tips of the inheritance tree. The hack where we
# skip over direct instances of Writable is so that
lib/Bio/Phylo.pm view on Meta::CPAN
# child classes probably should have a method like this,
# if their objects hold internal state anyway (b/c they'll
# be inside-out objects).
sub _cleanup : Destructor {
my $self = shift;
my $id = $self->get_id;
# cleanup local fields
if ( defined $id ) {
for my $field (@fields) {
delete $field->{$id};
}
}
}
=begin comment
Type : Internal method
Title : _get_container
Usage : $phylo->_get_container;
Function: Retrieves the object that contains the invocant (e.g. for a node,
returns the tree it is in).
Returns : Bio::Phylo::* object
Args : None
=end comment
=cut
# this is the converse of $listable->get_entities, i.e.
# every entity in a listable object holds a reference
# to its container. We actually use this surprisingly
# rarely, and because I read somewhere (heh) it's bad
# to have the objects of a has-a relationship fiddle with
# their container we hide this method from abuse. Then
# again, sometimes it's handy ;-)
sub _get_container { $container{ shift->get_id } }
=begin comment
Type : Internal method
Title : _set_container
Usage : $phylo->_set_container($obj);
Function: Creates a reference from the invocant to the object that contains
it (e.g. for a node, creates a reference to the tree it is in).
Returns : Bio::Phylo::* object
Args : A Bio::Phylo::Listable object
=end comment
=cut
sub _set_container {
my ( $self, $container ) = @_;
my $id = $self->get_id;
if ( blessed $container ) {
if ( $container->can('can_contain') ) {
if ( $container->can_contain($self) ) {
if ( $container->contains($self) ) {
$container{$id} = $container;
weaken( $container{$id} );
}
else {
throw 'ObjectMismatch' => "'$self' not in '$container'";
}
}
else {
throw 'ObjectMismatch' =>
"'$container' cannot contain '$self'";
}
}
else {
throw 'ObjectMismatch' => "Invalid objects";
}
}
else {
delete $container{$id};
#throw 'BadArgs' => "Argument not an object";
}
return $self;
}
=item to_js()
Serializes to simple JSON. For a conversion to NeXML/JSON, use C<to_json>.
Type : Serializer
Title : to_js
Usage : my $json = $object->to_js;
Function: Serializes to JSON
Returns : A JSON string
Args : None.
Comments:
=cut
sub to_js {JSON::to_json(shift->_json_data,{'pretty'=>1}) if looks_like_class 'JSON'}
sub _json_data {
my $self = shift;
my %data = %{ $self->get_generic };
$data{'guid'} = $self->get_guid if $self->get_guid;
$data{'desc'} = $self->get_desc if $self->get_desc;
$data{'score'} = $self->get_score if $self->get_score;
return \%data;
}
=back
=head1 SEE ALSO
There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo>
for any user or developer questions and discussions.
Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>
=head1 CITATION
If you use Bio::Phylo in published research, please cite it:
B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
( run in 0.748 second using v1.01-cache-2.11-cpan-4ef0a570458 )