view release on metacpan or  search on metacpan

Bio/Species.pm  view on Meta::CPAN

reponsive experts will be able look at the problem and quickly 
address it. Please include a thorough description of the problem 
with code and data examples if at all possible.

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://github.com/bioperl/bioperl-live/issues

=head1 AUTHOR

James Gilbert email B<jgrg@sanger.ac.uk>

=head1 CONTRIBUTORS

Sendu Bala, bix@sendu.me.uk
Chris Fields, cjfields at bioperl dot org

=head1 APPENDIX

The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _

=cut

#' Let the code begin...

package Bio::Species;
use strict;
use warnings;

use Bio::DB::Taxonomy;
use Bio::Tree::Tree;
use Bio::Taxon;
use base qw(Bio::Root::Root Bio::Tree::NodeI);

=head2 new

 Title   : new
 Usage   : my $obj = Bio::Species->new(-classification => \@class)
 Function: Build a new Species object
 Returns : Bio::Species object
 Args    : -ncbi_taxid     => NCBI taxonomic ID (optional)
           -classification => arrayref of classification

=cut

sub new {
    my($class, @args) = @_;
    
    my $self = $class->SUPER::new(@args);
    
    # Bio::Species is now just a proxy object that just observes the NodeI
    # interface methods but delegates them to the proper classes (Bio::Taxon and
    # Bio::Tree::Tree). This will be surplanted by the much simpler
    # Bio::Taxon/Bio::DB::Taxonomy modules in the future.
    
    # Using a proxy allows proper GC w/o using weaken().  This just wraps the
    # older instances, which have no reciprocal refs (thus no circular refs).
    # This can then run proper cleanup
    
    $self->taxon(Bio::Taxon->new(@args));
    
    my ($org, $sp, $var, $classification) =
        $self->_rearrange([qw(ORGANELLE
                            SUB_SPECIES
                            VARIANT
                            CLASSIFICATION)], @args);
    
    if (defined $classification && ref($classification) eq "ARRAY" && @{$classification}) {
        $self->classification(@$classification);
    }
    else {
        $self->tree(Bio::Tree::Tree->new());
    }
    
    defined $org && $self->organelle($org);
    defined $sp  && $self->sub_species($sp); 
    defined $var && $self->variant($var);
    
    return $self;
}

=head2 classification

 Title   : classification
 Usage   : $self->classification(@class_array);
           @classification = $self->classification();
 Function: Get/set the lineage of this species. The array provided must be in
           the order ... ---> SPECIES, GENUS ---> KINGDOM ---> etc.
 Example : $obj->classification(qw( 'Homo sapiens' Homo Hominidae
           Catarrhini Primates Eutheria Mammalia Vertebrata
           Chordata Metazoa Eukaryota));
 Returns : Classification array
 Args    : Classification array 
                 OR
           A reference to the classification array. In the latter case
           if there is a second argument and it evaluates to true,
           names will not be validated. NB: in any case, names are never
           validated anyway.

=cut

sub classification {
    my ($self, @vals) = @_;

    my $taxon = $self->taxon;

    if (@vals) {
        if (ref($vals[0]) eq 'ARRAY') {
            @vals = @{$vals[0]};
        }
        
        $vals[1] ||= '';
        # make sure the lineage contains us as first or second element
        # (lineage may have subspecies, species, genus ...)
        my $name = $taxon->node_name;
        my ($genus, $species) = (quotemeta($vals[1]), quotemeta($vals[0]));

Bio/Species.pm  view on Meta::CPAN

			$self->sub_species($sub_species) if $sub_species;
		}

		$self->{_species} = $species;
    }
	return $self->{_species};
}

=head2 genus

 Title   : genus
 Usage   : $self->genus( $genus );
           $genus = $self->genus();
 Function: Get or set the scientific genus name.
 Example : $self->genus('Homo');
 Returns : Scientific genus name as string
 Args    : Scientific genus name as string

=cut

sub genus {
    my ($self, $genus) = @_;

    # TODO: instead of caching the raw name, cache the actual node instance.
    if ($genus) {
        $self->{_genus} = $genus;
    }
    unless (defined $self->{_genus}) {
        my $genus_taxon = $self->tree->find_node(-rank => 'genus');
        unless ($genus_taxon) {
            # just assume our ancestor is rank genus
            $genus_taxon = $self->taxon->ancestor;
        }
        
        $self->{_genus} = $genus_taxon->scientific_name if $genus_taxon;
    }
    
    return $self->{_genus};
}

=head2 sub_species

 Title   : sub_species
 Usage   : $obj->sub_species($newval)
 Function: Get or set the scientific subspecies name.
 Returns : value of sub_species
 Args    : newvalue (optional)

=cut

sub sub_species {
    my ($self, $sub) = @_;
    
    # TODO: instead of caching the raw name, cache the actual node instance.
    if (!defined $self->{'_sub_species'}) {
        my $ss_taxon = $self->tree->find_node(-rank => 'subspecies');
        if ($ss_taxon) {
            if ($sub) {
                $ss_taxon->scientific_name($sub);
                
                # *** weakening ref to our root node in species() to solve a
                # memory leak means that we have a subspecies taxon to set
                # during the first call to species(), but it has vanished by
                # the time a user subsequently calls sub_species() to get the
                # value. So we 'cheat' and just store the subspecies name in
                # our self hash, instead of the tree. Is this a problem for
                # a Species object? Can't decide --sendu
                
                # This can now be changed to deal with this information on the
                # fly.  For now, the caching remains, but maybe we should just
                # let these things deal with mutable data as needed? -- cjfields
                
                $self->{'_sub_species'} = $sub;
            }
            return $ss_taxon->scientific_name;
        }
        else {
            # should we create a node here to be added to the tree?
        }
    }
    
    # fall back to direct storage on self
    $self->{'_sub_species'} = $sub if $sub;
    return $self->{'_sub_species'};
}

=head2 variant

 Title   : variant
 Usage   : $obj->variant($newval)
 Function: Get/set variant information for this species object (strain,
           isolate, etc).
 Example : 
 Returns : value of variant (a scalar)
 Args    : new value (a scalar or undef, optional)

=cut

sub variant{
    my ($self, $var) = @_;
    
    # TODO: instead of caching the raw name, cache the actual node instance.
    if (!defined $self->{'_variant'}) {
        my $var_taxon = $self->tree->find_node(-rank => 'variant');
        if ($var_taxon) {
            if ($var) {
                $var_taxon->scientific_name($var);
            }
            return $var_taxon->scientific_name;
        }
        else {
            # should we create a node here to be added to the tree?
        }
    }
    
    # fall back to direct storage on self
    $self->{'_variant'} = $var if $var;
    return $self->{'_variant'};
}

=head2 binomial