view release on metacpan or  search on metacpan

Ace/Graphics/Glyph/graded_segments.pm  view on Meta::CPAN

package Ace::Graphics::Glyph::graded_segments;
# package to use for drawing anything that is interrupted
# (has the segment() method) and that has a score associated
# with each segment

use strict;
use vars '@ISA';
use GD;
use Ace::Graphics::Glyph::segments;
@ISA = 'Ace::Graphics::Glyph::segments';

# override draw method
sub draw {
  my $self = shift;

  # bail out if this isn't the right kind of feature
  # handle both das-style and Bio::SeqFeatureI style,
  # which use different names for subparts.
  my @segments;
  my $f = $self->feature;
  if ($f->can('segments')) {
    @segments = $f->segments;

  } elsif ($f->can('sub_SeqFeature')) {
    @segments = $f->sub_SeqFeature;

  } else {
    return $self->SUPER::draw(@_);
  }

  # figure out the colors
  my $max_score = $self->option('max_score');
  unless ($max_score) {
    $max_score = 0;
    foreach (@segments) {
      my $s = eval { $_->score };
      $max_score = $s if $s > $max_score;
    }
  }

  # allocate colors
  my $fill   = $self->fillcolor;
  my %segcolors;
  my ($red,$green,$blue) = $self->factory->rgb($fill);
  foreach (sort {$a->start <=> $b->start} @segments) {
    my $s = eval { $_->score };
    unless (defined $s) {
      $segcolors{$_} = $fill;
      next;
    }
    my($r,$g,$b) = map {(255 - (255-$_) * ($s/$max_score))} ($red,$green,$blue);
    my $idx      = $self->factory->translate($r,$g,$b);
    $segcolors{$_} = $idx;
  }

  # get parameters
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my ($left,$top) = @_;

  my (@boxes,@skips);

  for (my $i=0; $i < @segments; $i++) {
    my $color = $segcolors{$segments[$i]};

    my ($start,$stop) = ($left + $self->map_pt($segments[$i]->start),
			 $left + $self->map_pt($segments[$i]->end));

    # probably unnecessary, but we do it out of paranaoia
    ($start,$stop) = ($stop,$start) if $start > $stop;

    push @boxes,[$start,$stop,$color];