Skip to content
Browse files

Support for normalizing quantitative plots across entire track; Suppo…

…rt for transparency within tracks, allowing features to overlap.
  • Loading branch information...
1 parent c00cd00 commit ecc17af7fea1fa408752a84cf1af2efaa48b559d @lstein lstein committed Jan 5, 2012
View
4 Changes
@@ -1,5 +1,9 @@
Revision history for Perl extension Bio::Graphics.
+2.26
+ - Support for normalizing quantitative plots across entire track.
+ - Support for transparency within tracks, allowing features to overlap.
+
2.25
- Deprecate xyplot "histogram" subtype and default to "boxes".
- Add xyplot overlay feature.
View
1 MANIFEST
@@ -188,3 +188,4 @@ t/data/t3/version8.png
t/data/t3/version9.png
t/data/wig_data.wig
t/Wiggle.t
+META.json
View
2 lib/Bio/Graphics.pm
@@ -2,7 +2,7 @@ package Bio::Graphics;
use strict;
use Bio::Graphics::Panel;
-our $VERSION = '2.24';
+our $VERSION = '2.25';
1;
View
50 lib/Bio/Graphics/Glyph.pm
@@ -88,6 +88,13 @@ sub my_options {
undef,
'Rarely-used option to flood-fill entire glyph with a single color',
'prior to rendering it.'],
+ opacity => [
+ 'float',
+ '1.0',
+ 'Default opacity to apply to glyph background and foreground colors.',
+ 'This is a value between 0.0 (completely transparent) to 1.0 (completely opaque.',
+ 'If the color contains an explicit opacity (alpha) value, the default value',
+ 'will be ignored'],
linewidth => [
'integer',
1,
@@ -646,8 +653,15 @@ sub color {
sub translate_color {
my $self = shift;
my $color = shift;
- # turn into a color index
- return $self->factory->translate_color($color);
+ return $self->_translate_color($color);
+}
+
+sub _translate_color {
+ my $self = shift;
+ my $color = shift;
+ my $opacity = $self->default_opacity;
+ return $opacity < 1 ? $self->factory->transparent_color($opacity,$color)
+ : $self->factory->translate_color($color);
}
# return value:
@@ -672,6 +686,12 @@ sub hbumppad {
return $self->{_hbumppad}= $hbumppad;
}
+sub default_opacity {
+ my $self = shift;
+ return $self->{default_opacity} if defined $self->{default_opacity};
+ return $self->{default_opacity} = $self->option('opacity') || 0;
+}
+
# we also look for the "color" option for Ace::Graphics compatibility
sub fgcolor {
my $self = shift;
@@ -686,8 +706,7 @@ sub fgcolor {
} elsif ($index eq 'featureScore') {
$index = $self->score_to_color;
}
-
- $self->factory->translate_color($index);
+ return $self->_translate_color($index);
}
#add for compatibility
@@ -710,8 +729,7 @@ sub bgcolor {
} elsif ($index eq 'featureScore') {
$index = $self->score_to_color;
}
-
- $self->factory->translate_color($index);
+ return $self->_translate_color($index);
}
# for compatibility with UCSC genome browser useScore option
@@ -859,11 +877,20 @@ sub layout {
return $self->{layout_height} = $self->optimized_layout(\@parts)
+ $self->pad_bottom + $self->pad_top -1;# - $self->top + 1;
}
+
my (%bin1,%bin2);
my $limit = 0;
my $recent_pos = 0;
my $max_pos = 0;
+ # strand bumping turns on bumping for features that are in opposite strands!
+ # features in the same strand are allowed to overlap
+ my $strand_bumping;
+ if ($bump_direction eq 'overlap') {
+ $bump_direction = 1;
+ $strand_bumping++;
+ }
+
for my $g ($self->layout_sort(@parts)) {
my $height = $g->{layout_height};
@@ -881,6 +908,7 @@ sub layout {
my $bumplevel = 0;
my $left = $g->left;
my $right = $g->right;
+ my $strand = $g->strand || 0;
my $search_mode = 'down';
@@ -897,8 +925,9 @@ sub layout {
# look for collisions
my $bottom = $pos + $height;
- my $collision = $self->collides(\%bin1,CM1,CM2,$left,$pos,$right,$bottom) or last;
- # my $collision = $self->collides(\%bin2,CM3,CM4,$left,$pos,$right,$bottom) or last;
+ my $bin = \%bin1;
+ $bin = $strand >= 0 ? \%bin1 : \%bin2 if $strand_bumping;
+ my $collision = $self->collides($bin,CM1,CM2,$left,$pos,$right,$bottom) or last;
if ($bump_direction > 0) {
$pos = $collision->[3] + BUMP_SPACING; # collision, so bump
@@ -911,7 +940,9 @@ sub layout {
$g->move(0,$pos);
- $self->add_collision(\%bin1,CM1,CM2,$left,$g->top,$right,$g->bottom);
+ my $bin = \%bin1;
+ $bin = $strand >= 0 ? \%bin2 : \%bin1 if $strand_bumping; # note reversed order - features in opposite strands bump
+ $self->add_collision($bin,CM1,CM2,$left,$g->top,$right,$g->bottom);
$recent_pos = $pos;
$max_pos = $pos if $pos > $max_pos;
@@ -1084,7 +1115,6 @@ sub parent_feature {
sub draw_connectors {
my $self = shift;
-
return if $self->{overbumped};
my $gd = shift;
my ($dx,$dy) = @_;
View
20 lib/Bio/Graphics/Glyph/Factory.pm
@@ -285,6 +285,26 @@ sub translate_color {
$self->panel->translate_color($color_name);
}
+=head2 transparent_color
+
+ Title : transparent_color
+ Usage : $index = $f->transparent_color($opacity,$color_name)
+ Function : translate symbolic color names into GD indexes, with
+ an opacity value taken into account
+ Returns : an integer
+ Args : an opacity value from 0-1.0, plus a color name in format "green" or "#00FF00"
+ Status : Internal to Bio::Graphics
+
+The real work is done by the panel, but factory subclasses can
+override if desired.
+
+=cut
+
+sub transparent_color {
+ my $self = shift;
+ $self->panel->transparent_color(@_);
+}
+
=head2 make_glyph
Title : make_glyph
View
11 lib/Bio/Graphics/Glyph/track.pm
@@ -30,6 +30,10 @@ sub draw {
}
my @parts = $self->parts;
+
+ # give the glyph a chance to do track-wide normalization if it supports it
+ $self->normalize_track(@parts);
+
for (my $i=0; $i<@parts; $i++) {
$parts[$i]->draw_highlight($gd,$left,$top);
$parts[$i]->draw($gd,$left,$top,0,1);
@@ -41,6 +45,13 @@ sub draw {
# do nothing for components
# sub draw_component { }
+sub normalize_track {
+ my $self = shift;
+ my @parts = @_;
+ @parts = map {$_->isa('Bio::Graphics::Glyph::group') ? $_->parts : $_} @parts;
+ $parts[0]->normalize_track(@parts) if $parts[0]->can('normalize_track');
+}
+
sub bump {
my $self = shift;
return 1 if $self->option('group_subtracks');
View
1 lib/Bio/Graphics/Glyph/wiggle_minmax.pm
@@ -19,6 +19,7 @@ sub minmax {
my ($min,$max,$mean,$stdev) = eval {$self->bigwig_stats($autoscale,$self->feature)};
$min_score = $min if $do_min;
$max_score = $max if $do_max;
+ warn "($min,$max,$mean,$stdev)";
return $self->sanity_check($min_score,$max_score,$mean,$stdev);
}
View
2 lib/Bio/Graphics/Glyph/wiggle_whiskers.pm
@@ -2,7 +2,7 @@ package Bio::Graphics::Glyph::wiggle_whiskers;
use strict;
use base qw(Bio::Graphics::Glyph::wiggle_minmax
- Bio::Graphics::Glyph::xyplot
+ Bio::Graphics::Glyph::wiggle_xyplot
);
View
179 lib/Bio/Graphics/Glyph/wiggle_xyplot.pm
@@ -94,33 +94,23 @@ sub draw {
my ($gd,$dx,$dy) = @_;
my $feature = $self->feature;
- my ($wigfile) = eval{$feature->get_tag_values('wigfile')};
- return $self->draw_wigfile($feature,$self->rel2abs($wigfile),@_) if $wigfile;
-
- my ($wigdata) = eval{$feature->get_tag_values('wigdata')};
- return $self->draw_wigdata($feature,$wigdata,@_) if $wigdata;
-
- my ($densefile) = eval{$feature->get_tag_values('densefile')};
- return $self->draw_densefile($feature,$self->rel2abs($densefile),@_) if $densefile;
-
- my ($coverage) = eval{$feature->get_tag_values('coverage')};
- return $self->draw_coverage($feature,$coverage,@_) if $coverage;
-
- # support for BigWig/BigBed
- if ($feature->can('statistical_summary')) {
- my $stats = $feature->statistical_summary($self->width);
- $stats ||= [];
- my @vals = map {$_->{validCount} ? $_->{sumData}/$_->{validCount}:0} @$stats;
- return $self->draw_coverage($feature,\@vals,@_);
- }
-
+ my $datatype = $self->datatype;
+
+ # REFACTOR HERE USING DATATYPE
+ return $self->draw_wigfile($feature,@_) if $datatype eq 'wigfile';
+ return $self->draw_wigdata($feature,@_) if $datatype eq 'wigdata';
+ return $self->draw_densefile($feature,@_) if $datatype eq 'densefile';
+ return $self->draw_coverage($feature,@_) if $datatype eq 'coverage';
+ return $self->draw_statistical_summary($feature,@_) if $datatype eq 'statistical_summary';
return $self->SUPER::draw(@_);
}
sub draw_wigfile {
my $self = shift;
my $feature = shift;
- my $wigfile = shift;
+
+ my ($wigfile) = eval{$feature->get_tag_values('wigfile')};
+ $wigfile = $self->rel2abs($wigfile);
eval "require Bio::Graphics::Wiggle" unless Bio::Graphics::Wiggle->can('new');
my $wig = ref $wigfile && $wigfile->isa('Bio::Graphics::Wiggle')
@@ -136,7 +126,8 @@ sub draw_wigfile {
sub draw_wigdata {
my $self = shift;
my $feature = shift;
- my $data = shift;
+
+ my ($data) = eval{$feature->get_tag_values('wigdata')};
if (ref $data eq 'ARRAY') {
my ($start,$end) = $self->effective_bounds($feature);
@@ -156,9 +147,56 @@ sub draw_wigdata {
}
}
+sub draw_densefile {
+ my $self = shift;
+ my $feature = shift;
+
+ my ($densefile) = eval{$feature->get_tag_values('densefile')};
+ $densefile = $self->rel2abs($densefile);
+
+ my ($denseoffset) = eval{$feature->get_tag_values('denseoffset')};
+ my ($densesize) = eval{$feature->get_tag_values('densesize')};
+ $denseoffset ||= 0;
+ $densesize ||= 1;
+
+ my $smoothing = $self->get_smoothing;
+ my $smooth_window = $self->smooth_window;
+ my $start = $self->smooth_start;
+ my $end = $self->smooth_end;
+
+ my $fh = IO::File->new($densefile) or die "can't open $densefile: $!";
+ eval "require Bio::Graphics::DenseFeature" unless Bio::Graphics::DenseFeature->can('new');
+ my $dense = Bio::Graphics::DenseFeature->new(-fh=>$fh,
+ -fh_offset => $denseoffset,
+ -start => $feature->start,
+ -smooth => $smoothing,
+ -recsize => $densesize,
+ -window => $smooth_window,
+ ) or die "Can't initialize DenseFeature: $!";
+ my $parts = $self->get_parts;
+ $self->draw_plot($parts);
+}
+
sub draw_coverage {
my $self = shift;
my $feature = shift;
+
+ my ($array) = eval{$feature->get_tag_values('coverage')};
+ $self->_draw_coverage($feature,$array,@_);
+}
+
+sub draw_statistical_summary {
+ my $self = shift;
+ my $feature = shift;
+ my $stats = $feature->statistical_summary($self->width);
+ $stats ||= [];
+ my @vals = map {$_->{validCount} ? $_->{sumData}/$_->{validCount}:0} @$stats;
+ return $self->_draw_coverage($feature,\@vals,@_);
+}
+
+sub _draw_coverage {
+ my $self = shift;
+ my $feature = shift;
my $array = shift;
$array = [split ',',$array] unless ref $array;
@@ -185,12 +223,41 @@ sub _draw_wigfile {
$wig->smoothing($self->get_smoothing);
$wig->window($self->smooth_window);
+ $self->wig($wig);
+ my $parts = $self->get_parts;
+ $self->draw_plot($parts,@_);
+}
+sub datatype {
+ my $self = shift;
+ my $feature = $self->feature;
+ my ($tag,$value);
+
+ foreach $tag ('wigfile','wigdata','densefile','coverage') {
+ ($value) = eval{$feature->get_tag_values($tag)};
+ last if $value;
+ }
+ unless ($value) {
+ $tag = 'statistical_summary';
+ $value = eval{$feature->statistical_summary};
+ }
+ unless ($value) {
+ $tag = 'generic';
+ }
+ return wantarray ? ($tag,$value) : $tag;
+}
+
+sub get_parts {
+ my $self = shift;
+ my $feature = $self->feature;
my ($start,$end) = $self->effective_bounds($feature);
+ my ($datatype,$data) = $self->datatype;
- $self->wig($wig);
- my $parts = $self->create_parts_for_dense_feature($wig,$start,$end);
- $self->draw_plot($parts,@_);
+ return $self->subsample($data,$start,$end) if $datatype eq 'wigdata';
+ return $self->create_parts_for_dense_feature($data,$start,$end) if $datatype eq 'densefile';
+ return $self->create_parts_from_coverage($data,$start,$end) if $datatype eq 'coverage';
+ return $self->create_parts_from_summary($data,$start,$end) if $datatype eq 'statistical_summary';
+ return [];
}
sub effective_bounds {
@@ -207,6 +274,39 @@ sub effective_bounds {
return ($start,$end);
}
+sub minmax {
+ my $self = shift;
+ my $parts = shift;
+ return $self->Bio::Graphics::Glyph::wiggle_minmax::minmax($parts);
+}
+
+sub create_parts_from_coverage {
+ my $self = shift;
+ my ($array,$start,$end) = @_;
+ $array = [split ',',$array] unless ref $array;
+ return unless @$array;
+
+ my $bases_per_bin = ($end-$start)/@$array;
+ my $pixels_per_base = $self->scale;
+ my @parts;
+ for (my $pixel=0;$pixel<$self->width;$pixel++) {
+ my $offset = $pixel/$pixels_per_base;
+ my $s = $start + $offset;
+ my $e = $s+1; # fill in gaps
+ my $v = $array->[$offset/$bases_per_bin];
+ push @parts,[$s,$s,$v];
+ }
+ return \@parts;
+}
+
+sub create_parts_from_summary {
+ my $self = shift;
+ my ($stats,$start,$end) = @_;
+ $stats ||= [];
+ my @vals = map {$_->{validCount} ? $_->{sumData}/$_->{validCount}:0} @$stats;
+ return \@vals;
+}
+
sub draw_plot {
my $self = shift;
my $parts = shift;
@@ -219,7 +319,7 @@ sub draw_plot {
# There is a minmax inherited from xyplot as well as wiggle_minmax, and I don't want to
# rely on Perl's multiple inheritance DFS to find the right one.
- my ($min_score,$max_score,$mean,$stdev) = $self->Bio::Graphics::Glyph::wiggle_minmax::minmax($parts);
+ my ($min_score,$max_score,$mean,$stdev) = $self->minmax($parts);
my $rescale = $self->option('autoscale') eq 'z_score';
my $side = $self->_determine_side();
@@ -400,33 +500,6 @@ sub draw_label {
}
-sub draw_densefile {
- my $self = shift;
- my $feature = shift;
- my $densefile = shift;
-
- my ($denseoffset) = eval{$feature->get_tag_values('denseoffset')};
- my ($densesize) = eval{$feature->get_tag_values('densesize')};
- $denseoffset ||= 0;
- $densesize ||= 1;
-
- my $smoothing = $self->get_smoothing;
- my $smooth_window = $self->smooth_window;
- my $start = $self->smooth_start;
- my $end = $self->smooth_end;
-
- my $fh = IO::File->new($densefile) or die "can't open $densefile: $!";
- eval "require Bio::Graphics::DenseFeature" unless Bio::Graphics::DenseFeature->can('new');
- my $dense = Bio::Graphics::DenseFeature->new(-fh=>$fh,
- -fh_offset => $denseoffset,
- -start => $feature->start,
- -smooth => $smoothing,
- -recsize => $densesize,
- -window => $smooth_window,
- ) or die "Can't initialize DenseFeature: $!";
- my $parts = $self->create_parts_for_dense_feature($dense,$start,$end);
- $self->draw_plot($parts);
-}
# BUG: the next two subroutines should be merged
sub create_parts_for_dense_feature {
View
33 lib/Bio/Graphics/Glyph/xyplot.pm
@@ -228,6 +228,29 @@ sub lookup_draw_method {
return;
}
+sub normalize_track {
+ my $self = shift;
+ my @glyphs_in_track = @_;
+ my ($global_min,$global_max);
+ warn "trackwide normalization(@glyphs_in_track)";
+ for my $g (@glyphs_in_track) {
+ my ($min_score,$max_score) = $g->minmax($g->get_parts);
+ warn "$g: ($min_score,$max_score)";
+ $global_min = $min_score if !defined $global_min || $min_score < $global_min;
+ $global_max = $max_score if !defined $global_max || $max_score > $global_max;
+ }
+ for my $g (@glyphs_in_track) {
+ $g->configure(-min_score => $global_min);
+ $g->configure(-max_score => $global_max);
+ }
+}
+
+sub get_parts {
+ my $self = shift;
+ my @parts = $self->parts;
+ return \@parts;
+}
+
sub score {
my $self = shift;
my $s = $self->option('score');
@@ -346,7 +369,7 @@ sub _draw_boxes {
# special check here for the part_color being defined so as not to introduce lots of
# checking overhead when it isn't
if ($partcolor) {
- $color = $factory->translate_color($factory->option($part,'part_color',0,0));
+ $color = $self->translate_color($factory->option($part,'part_color',0,0));
$negcolor = $color;
} else {
$color = $positive;
@@ -416,7 +439,7 @@ sub _draw_points {
my $color;
if ($partcolor) {
- $color = $factory->translate_color($factory->option($part,'part_color',0,0));
+ $color = $self->translate_color($factory->option($part,'part_color',0,0));
} else {
$color = $fgcolor;
}
@@ -452,8 +475,8 @@ sub _draw_scale {
my $y_scale = $self->minor_ticks($min,$max,$y1,$y2);
my $p = $self->panel;
- my $gc = $p->translate_color($p->gridcolor);
- my $mgc= $p->translate_color($p->gridmajorcolor);
+ my $gc = $self->translate_color($p->gridcolor);
+ my $mgc= $self->translate_color($p->gridmajorcolor);
# if ($side ne 'none') {
# for (my $y = $y2-$y_scale; $y > $y1; $y -= $y_scale) {
@@ -524,7 +547,7 @@ sub _draw_grid {
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($dx,$dy);
my $p = $self->panel;
- my $gc = $p->translate_color($p->gridcolor);
+ my $gc = $self->translate_color($p->gridcolor);
my $y_scale = $self->minor_ticks($min,$max,$y1,$y2);
for (my $y = $y2-$y_scale; $y > $y1; $y -= $y_scale) {
View
41 lib/Bio/Graphics/Panel.pm
@@ -82,6 +82,7 @@ sub new {
pad_bottom => $options{-pad_bottom}||0,
pad_left => $options{-pad_left}||0,
pad_right => $options{-pad_right}||0,
+ global_alpha => $options{-alpha} || 0,
length => $length,
offset => $offset,
gridcolor => $gridcolor,
@@ -516,14 +517,14 @@ sub gd {
}
my %translation_table;
+ my $global_alpha = $self->{global_alpha} || 0;
for my $name (keys %COLORS) {
my $idx = $gd->colorAllocate(@{$COLORS{$name}});
$translation_table{$name} = $idx;
}
$self->{translations} = \%translation_table;
$self->{gd} = $gd;
-
eval {$gd->alphaBlending(0)};
if ($self->bgcolor) {
@@ -965,26 +966,42 @@ sub rgb {
return $gd->rgb($idx);
}
+sub transparent_color {
+ my $self = shift;
+ my ($opacity,@colors) = @_;
+ return $self->_translate_color($opacity,@colors);
+}
+
sub translate_color {
+ my $self = shift;
+ my @colors = @_;
+ return $self->_translate_color(1.0,@colors);
+}
+
+sub _translate_color {
my $self = shift;
- my @colors = @_;
+ my ($opacity,@colors) = @_;
+ $opacity = '1.0' if $opacity == 1;
+ my $default_alpha = $self->adjust_alpha($opacity);
+ $default_alpha ||= 127;
- return $self->{closestcache}{"@colors"} if exists $self->{closestcache}{"@colors"};
+ my $ckey = "@{colors}_${default_alpha}";
+ return $self->{closestcache}{$ckey} if exists $self->{closestcache}{$ckey};
my $index;
my $gd = $self->gd or return 1;
my $table = $self->{translations} or return 1;
if (@colors == 3) {
- $index = $self->colorClosest($gd,@colors);
+ $index = $gd->colorAllocateAlpha(@colors,$default_alpha);
}
elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
my ($r,$g,$b,$alpha) = (hex($1),hex($2),hex($3),hex($4));
$index = $gd->colorAllocateAlpha($r,$g,$b,$alpha);
}
elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
my ($r,$g,$b) = (hex($1),hex($2),hex($3));
- $index = $self->colorClosest($gd,$r,$g,$b);
+ $index = $gd->colorAllocateAlpha($r,$g,$b,$default_alpha);
}
elsif ($colors[0] =~ /^(\d+),(\d+),(\d+),([\d.]+)$/i ||
$colors[0] =~ /^rgba\((\d+),(\d+),(\d+),([\d.]+)\)$/) {
@@ -996,7 +1013,7 @@ sub translate_color {
$colors[0] =~ /^rgb\((\d+),(\d+),(\d+)\)$/i
) {
my (@rgb) = map {/(\d+)%/ ? int(255 * $1 / 100) : $_} ($1,$2,$3);
- $index = $self->colorClosest($gd,@rgb);
+ $index = $self->colorAllocateAlpha($gd,@rgb,$default_alpha);
}
elsif ($colors[0] eq 'transparent') {
$index = $gd->colorAllocateAlpha(255,255,255,127);
@@ -1006,10 +1023,14 @@ sub translate_color {
my $alpha = $self->adjust_alpha($2);
$index = $gd->colorAllocateAlpha(@rgb,$alpha);
}
+ elsif ($default_alpha < 127) {
+ my @rgb = $self->color_name_to_rgb($colors[0]);
+ $index = $gd->colorAllocateAlpha(@rgb,$default_alpha);
+ }
else {
$index = defined $table->{$colors[0]} ? $table->{$colors[0]} : 1;
}
- return $self->{closestcache}{"@colors"} = $index;
+ return $self->{closestcache}{$ckey} = $index;
}
# change CSS opacity values (0-1.0) into GD opacity values (127-0)
@@ -2218,6 +2239,12 @@ for filled boxes and other "solid" glyphs. The foreground color
controls the color of lines and strings. The -tkcolor argument
controls the background color of the entire track.
+B<Default opacity:>For truecolor images, you can apply a default opacity
+value to both foreground and background colors by supplying a B<-opacity>
+argument. This is specified as a CSS-style floating point number from
+0.0 to 1.0. If the color has an explicit alpha, then the default is
+ignored.
+
B<Track color:> The -tkcolor option used to specify the background of
the entire track.

0 comments on commit ecc17af

Please sign in to comment.
Something went wrong with that request. Please try again.