view release on metacpan or  search on metacpan

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

package Ace::Graphics::Glyph::transcript;
# package to use for drawing transcripts

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

use constant IMPLIED_INTRON_COLOR  => 'gray';
use constant ARROW => 4;

# override the left and right methods in order to
# provide extra room for arrows at the end
sub calculate_left {
  my $self = shift;
  my $val = $self->SUPER::calculate_left(@_);
  $val -= ARROW if $self->feature->strand < 0 && $val >= 4;
  $val;
}

sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);
  $val = $left + ARROW if $left + ARROW > $val;

  if ($self->option('label') && (my $description = $self->description)) {
    my $description_width = $self->font->width * length $description;
    $val = $left + $description_width if $left + $description_width > $val;
  }
  $val;
}

# override the bottom method in order to provide extra room for
# the label
sub calculate_height {
  my $self = shift;
  my $val = $self->SUPER::calculate_height(@_);
  $val += $self->labelheight if $self->option('label') && $self->description;
  $val;
}

# override filled_box method
sub filled_box {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2,$color) = @_;

  my $linewidth = $self->option('linewidth') || 1;
  $color ||= $self->fillcolor;
  $gd->filledRectangle($x1,$y1,$x2,$y2,$color);
  $gd->rectangle($x1,$y1,$x2,$y2,$self->fgcolor);

  # if the left end is off the end, then cover over
  # the leftmost line
  my ($width) = $gd->getBounds;
  $gd->line($x1,$y1,$x1,$y2,$color)
    if $x1 < 0;

  $gd->line($x2,$y1,$x2,$y2,$color)
    if $x2 > $width;
}

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

  # bail out if this isn't the right kind of feature
  return $self->SUPER::draw(@_) unless $self->feature->can('segments');

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

  my $implied_intron_color = $self->option('implied_intron_color') || IMPLIED_INTRON_COLOR;
  my $gray = $self->factory->translate($implied_intron_color);
  my $fg     = $self->fgcolor;
  my $fill   = $self->fillcolor;
  my $fontcolor = $self->fontcolor;
  my $curated_exon   = $self->option('curatedexon')   ? $self->color('curatedexon') : $fill;
  my $curated_intron = $self->option('curatedintron') ? $self->color('curatedintron') : $fg;

  my @exons   = sort {$a->start<=>$b->start} $self->feature->segments;
  my @introns = $self->feature->introns if $self->feature->can('introns');

  # fill in missing introns
  my (%istart,@intron_boxes,@implied_introns,@exon_boxes);
  foreach (@introns) {
    my ($start,$stop) = ($_->start,$_->end);
    ($start,$stop) = ($stop,$start) if $start > $stop;
    $istart{$start}++;
    my $color = $_->source_tag eq 'curated' ? $curated_intron : $fg;
    push @intron_boxes,[$left+$self->map_pt($start),$left+$self->map_pt($stop),$color];
  }

  for (my $i=0; $i < @exons; $i++) {
    my ($start,$stop) = ($exons[$i]->start,$exons[$i]->end);
    ($start,$stop) = ($stop,$start) if $start > $stop;
    my $color = $exons[$i]->source_tag eq 'curated' ? $curated_exon : $fill;

    push @exon_boxes,[$left+$self->map_pt($start),my $stop_pos = $left + $self->map_pt($stop),$color];

    next unless my $next_exon = $exons[$i+1];

    my $next_start = $next_exon->start < $next_exon->end ?
      $next_exon->start : $next_exon->end;

    my $next_start_pos = $left + $self->map_pt($next_start);
    # fudge boxes that are within two pixels of each other
    if ($next_start_pos - $stop_pos < 2) {
      $exon_boxes[-1][1] = $next_start_pos;

    } elsif ($next_exon && !$istart{$stop+1}) {
      push @implied_introns,[$stop_pos,$next_start_pos,$gray];
    }
}

  my $center  = ($y1 + $y2)/2;
  my $quarter = $y1 + ($y2-$y1)/4;

  # each intron becomes an angly thing
  for my $i (@intron_boxes,@implied_introns) {