view release on metacpan or  search on metacpan

lib/Bio/Graphics/Glyph/wiggle_density.pm  view on Meta::CPAN

        # $scores is the numerator; $defined is the denominator
        $scores += $val if defined $val;
        $defined++ if defined $val;

        # keep incrementing until we exceed 2 pixels
        # the step is a fraction of a pixel, not an integer
        $pixels += $pixelstep;
      }
  }
}

sub draw_plot {
    my $self            = shift;
    my $parts           = shift;
    my ($gd,$dx,$dy)    = @_;

    my $x_scale     = $self->scale;
    my $panel_start = $self->panel->start;
    my $feature     = $self->feature;
    my $f_start     = $feature->start > $panel_start 
	                  ? $feature->start 
			  : $panel_start;

    my ($left,$top,$right,$bottom) = $self->calculate_boundaries($dx,$dy);

    # There is a minmax inherited from xyplot as well as wiggle_data, 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->minmax($parts);
    my $rescale  = $self->option('autoscale') eq 'z_score';

    my ($scaled_min,$scaled_max);
    if ($rescale) {
	$scaled_min = int(($min_score-$mean)/$stdev + 0.5);
	$scaled_max = int(($max_score-$mean)/$stdev + 0.5);
	my $bound  = $self->z_score_bound;
	$scaled_max = $bound  if $scaled_max > $bound;
	$scaled_min = -$bound if $scaled_min < -$bound;
    } else {
	($scaled_min,$scaled_max) = ($min_score,$max_score);
    }

    my $pivot    = $self->bicolor_pivot;
    my $positive = $self->pos_color;
    my $negative = $self->neg_color;
    my $midpoint = $self->midpoint;
    my ($rgb_pos,$rgb_neg,$rgb);
    if ($pivot) {
	$rgb_pos = [$self->panel->rgb($positive)];
	$rgb_neg = [$self->panel->rgb($negative)];
    } else {
	$rgb = $scaled_max > $scaled_min ? ([$self->panel->rgb($positive)] || [$self->panel->rgb($self->bgcolor)]) 
	                                 : ([$self->panel->rgb($negative)] || [$self->panel->rgb($self->bgcolor)]);
    }

    my %color_cache;
    my $flip     = $self->{flip};

    $self->panel->startGroup($gd);
    foreach (@$parts) {
	my ($start,$end,$score) = @$_;
	next unless defined $score; # undefined (absent) score transparent
	$score    = ($score-$mean)/$stdev if $rescale;
	$score    = $scaled_min if $scaled_min > $score;
	$score    = $scaled_max if $scaled_max < $score;

	my $x1     = $left    + ($start - $f_start) * $x_scale;
	my $x2     = $left    + ($end   - $f_start) * $x_scale;
	if ($flip) {
	    $x1 = $right - ($x1-$left);
	    $x2 = $right - ($x2-$left);
	    ($x1,$x2) = ($x2,$x1);
	}

	my ($r,$g,$b)  = $pivot
	  ? ($score > $midpoint ? $self->calculate_color($score,$rgb_pos,
							  $midpoint,$scaled_max)
	                        : $self->calculate_color($score,$rgb_neg,
							  $midpoint,$scaled_min)
	  )
          : $self->calculate_color($score,$rgb,
				   $scaled_min,$scaled_max);
	my $idx        = $color_cache{$r,$g,$b} ||= $self->panel->translate_color($r,$g,$b);
	$self->filled_box($gd,$x1,$top,$x2,$bottom,$idx,$idx);
    }
    return 1;
}

sub _draw_coverage {
    my $self    = shift;
    my $feature = shift;
    my $array   = shift;

    $array      = [split ',',$array] unless ref $array;
    return unless @$array;

    my ($start,$end)    = $self->effective_bounds($feature);
    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];
	#$v         = 0 unless defined $v; # don't want undefined values
	push @parts,[$s,$s,$v];
    }
    $self->Bio::Graphics::Glyph::wiggle_density::draw_plot(\@parts,@_);
}

sub calculate_color {
  my $self = shift;
  my ($s,$rgb,$min_score,$max_score) = @_;
  $s ||= $min_score;

  return (255,255,255) unless $max_score - $min_score; # avoid div by zero

  my $relative_score = ($s-$min_score)/($max_score-$min_score);
  $relative_score    = 0 if $relative_score < 0;
  $relative_score    = 1 if $relative_score > 1;
  return map { int(255 - (255-$_) * $relative_score) } @$rgb;