Raw content of Bio::EnsEMBL::Variation::DBSQL::PopulationAdaptor
<![CDATA[#
# Ensembl module for Bio::EnsEMBL::Variation::DBSQL::PopulationAdaptor
#
# Copyright (c) 2004 Ensembl
#
# You may distribute this module under the same terms as perl itself
#
#
=head1 NAME
Bio::EnsEMBL::Variation::DBSQL::PopulationAdaptor
=head1 SYNOPSIS
$db = Bio::EnsEMBL::Variation::DBSQL::DBAdaptor->new(...);
$pa = $db->get_PopulationAdaptor();
# Get a Population by its internal identifier
$pop = $pa->fetch_by_dbID(145);
# fetch a population by its name
$pop = $pa->fetch_by_name('PACIFIC');
# fetch all sub populations of a population
foreach $sub_pop (@{$pa->fetch_all_by_super_Population($pop)}) {
print $sub_pop->name(), " is a sub population of ", $pop->name(), "\n";
}
# fetch all super populations
foreach $super_pop (@{$pa->fetch_all_by_sub_Population($pop)}) {
print $pop->name(), " is a sub population of ", $super_pop->name(), "\n";
}
=head1 DESCRIPTION
This adaptor provides database connectivity for Population objects.
Populations may be retrieved from the Ensembl variation database by
several means using this module.
=head1 AUTHOR - Graham McVicker
=head1 CONTACT
Post questions to the Ensembl development list ensembl-dev@ebi.ac.uk
=head1 METHODS
=cut
use strict;
use warnings;
package Bio::EnsEMBL::Variation::DBSQL::PopulationAdaptor;
use Bio::EnsEMBL::Variation::DBSQL::SampleAdaptor;
use Bio::EnsEMBL::Utils::Exception qw(throw warning);
use Bio::EnsEMBL::Variation::Population;
our @ISA = ('Bio::EnsEMBL::Variation::DBSQL::SampleAdaptor');
=head2 fetch_population_by_synonym
Arg [1] : $population_synonym
Example : my $pop = $pop_adaptor->fetch_population_by_synonym($population_synonym,$source);
Description : Retrieves populations for the synonym given in the source. If no source is provided, retrieves all the synonyms
Returntype : list of Bio::EnsEMBL::Variation::Population
Exceptions : none
Caller : general
Status : At Risk
=cut
sub fetch_population_by_synonym{
my $self = shift;
my $synonym_name = shift;
my $source = shift;
my $pops;
my $pop;
#return all sample_id from the database
my $samples = $self->SUPER::fetch_sample_by_synonym($synonym_name, $source);
foreach my $sample_id (@{$samples}){
#get the ones that are individuals
$pop = $self->fetch_by_dbID($sample_id);
push @{$pops}, $pop if (defined $pop);
}
return $pops;
}
=head2 fetch_by_name
Arg [1] : string $name
Example : $pop = $pop_adaptor->fetch_by_name('NUSPAE:Singapore_HDL');
Description: Retrieves a population object via its name
Returntype : Bio::EnsEMBL::Variation::Population
Exceptions : throw if name argument is not defined
Caller : general
Status : At Risk
=cut
sub fetch_by_name {
my $self = shift;
my $name = shift;
throw('name argument expected') if(!defined($name));
my $sth = $self->prepare(q{SELECT p.sample_id, s.name, s.size, s.description
FROM population p, sample s
WHERE s.name = ?
AND s.sample_id = p.sample_id});
$sth->bind_param(1,$name,SQL_VARCHAR);
$sth->execute();
my $result = $self->_objs_from_sth($sth);
$sth->finish();
return undef if(!@$result);
return $result->[0];
}
=head2 fetch_all_by_super_Population
Arg [1] : Bio::EnsEMBL::Variation::Population $pop
Example : foreach $sub_pop (@{$pa->fetch_all_by_super_Population($pop)}) {
print $sub_pop->name(), "\n";
}
Description: Retrieves all sub populations of a provided population.
Returntype : Bio::EnsEMBL::Population
Exceptions : throw on bad argument
Caller : general
Status : At Risk
=cut
sub fetch_all_by_super_Population {
my $self = shift;
my $pop = shift;
if(!ref($pop) || !$pop->isa('Bio::EnsEMBL::Variation::Population')) {
throw('Bio::EnsEMBL::Variation::Population argument expected');
}
if(!$pop->dbID()) {
warning("Cannot retrieve sub populations for population without dbID");
return [];
}
my $sth = $self->prepare(q{SELECT p.sample_id, s.name, s.size,
s.description
FROM population p, population_structure ps, sample s
WHERE p.sample_id = ps.sub_population_sample_id
AND ps.super_population_sample_id = ?
AND p.sample_id = s.sample_id});
$sth->bind_param(1,$pop->dbID,SQL_INTEGER);
$sth->execute();
my $result = $self->_objs_from_sth($sth);
$sth->finish();
return $result;
}
=head2 fetch_all_by_sub_Population
Arg [1] : Bio::EnsEMBL::Variation::Population $pop
Example : foreach $super_pop (@{$pa->fetch_all_by_sub_Population($pop)}) {
print $super_pop->name(), "\n";
}
Description: Retrieves all super populations for a provided population
Returntype : Bio::EnsEMBL::Population
Exceptions : throw on bad argument
Caller : general
Status : At Risk
=cut
sub fetch_all_by_sub_Population {
my $self = shift;
my $pop = shift;
if(!ref($pop) || !$pop->isa('Bio::EnsEMBL::Variation::Population')) {
throw('Bio::EnsEMBL::Variation::Population argument expected');
}
if(!$pop->dbID()) {
warning("Cannot retrieve super populations for population without dbID");
return [];
}
my $sth = $self->prepare(q{SELECT p.sample_id, s.name, s.size,
s.description
FROM population p, population_structure ps, sample s
WHERE p.sample_id = ps.super_population_sample_id
AND ps.sub_population_sample_id = ?
AND p.sample_id = s.sample_id});
$sth->bind_param(1,$pop->dbID,SQL_INTEGER);
$sth->execute();
my $result = $self->_objs_from_sth($sth);
$sth->finish();
return $result;
}
=head2 fetch_default_LDPopulation
Args : none
Example : $population = $pop_adaptor->fetch_default_LDPopulation();
Description : Obtains the population it is used as a default in the LD display of the pairwise LD data
ReturnType : Bio::EnsEMBL::Variation::Population
Exceptions : none
Caller : general
Status : At Risk
=cut
sub fetch_default_LDPopulation{
my $self = shift;
my $population_id;
my $sth = $self->prepare(qq{SELECT meta_value from meta where meta_key = ?});
$sth->bind_param(1,'pairwise_ld.default_population',SQL_VARCHAR);
$sth->execute();
$sth->bind_columns(\$population_id);
$sth->fetch();
$sth->finish;
if (defined $population_id){
return $self->fetch_by_dbID($population_id);
}
else{
return undef;
}
}
=head2 fetch_all_by_Individual
Arg [1] : Bio::EnsEMBL::Variation::Individual $ind
Example : my $ind = $ind_adaptor->fetch_by_name('NA12004');
foreach my $pop (@{$pop_adaptor->fetch_all_by_Individual($ind)}){
print $pop->name,"\n";
}
Description : Retrieves all populations from a specified individual
ReturnType : reference to list of Bio::EnsEMBL::Variation::Population objects
Exceptions : throw if incorrect argument is passed
warning if provided individual does not have a dbID
Caller : general
Status : At Risk
=cut
sub fetch_all_by_Individual{
my $self = shift;
my $ind = shift;
if(!ref($ind) || !$ind->isa('Bio::EnsEMBL::Variation::Individual')) {
throw("Bio::EnsEMBL::Variation::Individual arg expected");
}
if(!$ind->dbID()) {
warning("Individual does not have dbID, cannot retrieve Individuals");
return [];
}
my $sth = $self->prepare(qq{SELECT p.sample_id, s.name, s.size, s.description
FROM population p, individual_population ip, sample s
WHERE s.sample_id = ip.population_sample_id
AND s.sample_id = p.sample_id
AND ip.individual_sample_id = ?
});
$sth->bind_param(1,$ind->dbID,SQL_INTEGER);
$sth->execute();
my $results = $self->_objs_from_sth($sth);
$sth->finish();
return $results;
}
=head2 fetch_tagged_Population
Arg [1] : Bio::EnsEMBL::Variation::VariationFeature $vf
Example : my $vf = $vf_adaptor->fetch_by_name('rs205621');
my $populations_tagged = $vf->is_tagged();
foreach my $pop (@{$vf_adaptor->is_tagged}){
print $pop->name," has been tagged using a 0.99 r2 criteria\n";
}
Description : Retrieves all populations from a specified variation feature that have been tagged
ReturnType : reference to list of Bio::EnsEMBL::Variation::Population objects
Exceptions : throw if incorrect argument is passed
warning if provided variation feature does not have a dbID
Caller : general
Status : At Risk
=cut
sub fetch_tagged_Population{
my $self = shift;
my $variation_feature = shift;
if(!ref($variation_feature) || !$variation_feature->isa('Bio::EnsEMBL::Variation::VariationFeature')) {
throw("Bio::EnsEMBL::Variation::VariationFeature arg expected");
}
if(!$variation_feature->dbID()) {
warning("Variation feature does not have dbID, cannot retrieve tagged populations");
return [];
}
my $sth = $self->prepare(qq{SELECT p.sample_id, s.name, s.size, s.description
FROM population p, tagged_variation_feature tvf, sample s
WHERE p.sample_id = tvf.sample_id
AND s.sample_id = p.sample_id
AND tvf.variation_feature_id = ?
});
$sth->bind_param(1,$variation_feature->dbID,SQL_INTEGER);
$sth->execute();
my $results = $self->_objs_from_sth($sth);
$sth->finish();
return $results;
}
#
# private method, creates population objects from an executed statement handle
# ordering of columns must be consistant
#
sub _objs_from_sth {
my $self = shift;
my $sth = shift;
my @pops;
my ($pop_id, $name, $size, $desc);
$sth->bind_columns(\$pop_id, \$name, \$size, \$desc);
while($sth->fetch()) {
push @pops, Bio::EnsEMBL::Variation::Population->new
(-dbID => $pop_id,
-ADAPTOR => $self,
-NAME => $name,
-DESCRIPTION => $desc,
-SIZE => $size);
}
return \@pops;
}
sub _tables{return (['population','p'],
['sample','s']);}
sub _columns{
return qw(s.sample_id s.name s.size s.description);
}
sub _default_where_clause{
return 's.sample_id = p.sample_id';
}
1;
]]>