package EnsEMBL::Web::Component::Variation::PopulationGenotypes;
use strict;
use warnings;
no warnings "uninitialized";
use base qw(EnsEMBL::Web::Component::Variation);
use CGI qw(escapeHTML);
sub _init {
my $self = shift;
$self->cacheable( 0 );
$self->ajaxable( 1 );
}
sub content {
my $self = shift;
my $object = $self->object;
## Check we have uniquely determined variation
unless ($object->core_objects->{'parameters'}{'vf'} ){
my $html = "<p>You must select a location from the panel above to see this information</p>";
return $self->_info(
'A unique location can not be determined for this Variation',
$html
);
}
## Hacked version of $objects->freqs to allow the return of multiple rows of data per population
my $freq_data = $object->freqs_hack;
#my $freq_data = $object->freqs;
unless (%$freq_data ){
my $html = "<p>No genotypes for this variation</p>";
return $self->_info(
'Variation: '. $object->name,
$html );
}
my $table = format_frequencies($object, $freq_data);
return $table->render;
}
sub format_frequencies {
my ( $object, $freq_data ) = @_;
my %freq_data = %{ $freq_data };
my %columns;
my @rows;
my $table = new EnsEMBL::Web::Document::SpreadSheet( [], [], {'margin' => '1em 0px' } );
foreach my $pop_id (sort { $freq_data{$a}{pop_info}{Name} cmp $freq_data{$b}{pop_info}{Name}} keys %freq_data) {
my %pop_row;
# Freqs alleles ---------------------------------------------
my @allele_freq = @{ $freq_data{$pop_id}{AlleleFrequency} };
foreach my $gt ( @{ $freq_data{$pop_id}{Alleles} } ) {
my $freq = _format_number(shift @allele_freq);
$pop_row{"Alleles <br />$gt"} = $freq;
}
# Freqs genotypes ---------------------------------------------
my @genotype_freq = @{ $freq_data{$pop_id}{GenotypeFrequency} || [] };
foreach my $gt ( @{ $freq_data{$pop_id}{Genotypes} } ) {
my $freq = _format_number(shift @genotype_freq);
$pop_row{"Genotypes <br />$gt"} = $freq;
}
# Add a name, size and description if it exists ---------------------------
$pop_row{pop}= _pop_url( $object, $freq_data{$pop_id}{pop_info}{Name}, $freq_data{$pop_id}{pop_info}{PopLink})." ";
$pop_row{Size} = $freq_data{$pop_id}{pop_info}{Size};
# Descriptions too long. Only display first sentence
(my $description = $freq_data{$pop_id}{pop_info}{Description}) =~ s/International HapMap project.*/International HapMap project\.\.\./;
$description =~ s/<.*?>//g;
if (length $description > 220) {
$description = substr($description, 0, 220) ."...";
}
$pop_row{Description} = "<small>". ($description ||"-") ."</small>";
# Super and sub populations ----------------------------------------------
my $super_string = _sort_extra_pops($object, $freq_data{$pop_id}{pop_info}{"Super-Population"});
$pop_row{"Super-Population"} = $super_string;
my $sub_string = _sort_extra_pops($object, $freq_data{$pop_id}{pop_info}{"Sub-Population"});
$pop_row{"Sub-Population"} = $sub_string;
push (@rows, \%pop_row);
map { $columns{$_} = 1 if $pop_row{$_}; } (keys %pop_row);
}
# Format table columns ------------------------------------------------------
my @header_row;
foreach my $col (sort {$b cmp $a} keys %columns) {
next if $col eq 'pop';
if ($col !~ /Population|Description/) {
unshift (@header_row, {key =>$col, 'align'=>'left',
title => $col });
}
else {
push (@header_row, {key =>$col, 'align'=>'left', title => " $col " });
}
}
unshift (@header_row, {key =>"pop",'align'=>'left', title =>"Population"} );
foreach my $column (@header_row){
my %col_info = %{$column};
$table->add_columns(
{ 'key' => $col_info{'key'}, 'title' => $col_info{'title'}, 'align' => $col_info{'align'} },
);
}
foreach my $r (@rows){
my %temp = %{$r};
my $tmp_row = {};
foreach my $key (keys %temp){
if ($temp{$key}) { $tmp_row->{$key} = $temp{$key}; }
}
$table->add_row($tmp_row);
}
return $table;
}
sub _sort_extra_pops {
### Population_table
### Arg1 : data object
### Arg2 : hashref with population data
### Example : my $super_string = _sort_extra_pops($object, $freq_data{$pop_id}{pop_info}{"Super-Population"});
### Description : returns string with Population name (size)<br> description
### Returns string
my ( $object, $extra_pop ) = @_;
my @pops;
foreach my $pop_id (keys %$extra_pop ) {
my $display_pop = _pop_url( $object, $extra_pop->{$pop_id}{Name},
$extra_pop->{$pop_id}{PopLink});
my $size = $extra_pop->{$pop_id}{Size};
$size = " (Size: $size)" if $size;
my $string = "$display_pop $size";
$string .= "<br /><small>".$extra_pop->{$pop_id}{Description}."</small>" if $extra_pop->{$pop_id}{Description};
}
return (join "<br />", @pops);
}
sub _format_number {
### Population_genotype_alleles
### Arg1 : null or a number
### Returns "unknown" if null or formats the number to 3 decimal places
my $number = shift;
if ($number) {
return sprintf("%.3f", $number );
}
return "unknown";
}
sub _pop_url {
### Arg1 : data object
### Arg2 : Population name (to be displayed)
### Arg3 : dbSNP population ID (variable to be linked to)
### Example : _pop_url($object, $pop_name, $pop_dbSNPID);
### Description : makes pop_name into a link
### Returns string
my ($object, $pop_name, $pop_dbSNP) = @_;
return $pop_name unless $pop_dbSNP;
return $object->get_ExtURL_link( $pop_name, 'DBSNPPOP',$pop_dbSNP->[0] );
}
1;