view release on metacpan or  search on metacpan

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

package Ace::Graphics::Glyph::segments;
# package to use for drawing anything that is interrupted
# (has the segment() method)

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

use constant GRAY  => 'lightgrey';
my %BRUSHES;

# override right to allow for label
sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);

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

# 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('merged_segments')) {
    @segments = $f->merged_segments;

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

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

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

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

  my $gray = $self->color(GRAY);

  my (@boxes,@skips);
  my $stranded = $self->option('stranded');

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

    my $strand = 0;
    my $target;

    if ($stranded
	&& $segments[$i]->can('target') 
	&& ($target = $segments[$i]->target) 
	&& $target->can('start')) {
      $strand = $target->start < $target->end ? 1 : -1;
    }

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

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

    if (my $next_segment = $segments[$i+1]) {
      my ($next_start,$next_stop) = ($left + $self->map_pt($next_segment->start),
				     $left + $self->map_pt($next_segment->end));
      # probably unnecessary, but we do it out of paranaoia
      ($next_start,$next_stop) = ($next_stop,$next_start) if $next_start > $next_stop;

      # fudge boxes that are within two pixels of each other
      if ($next_start - $stop < 2) {
	$boxes[-1][1] = $next_start;
      }
      push @skips,[$stop+1,$next_start-1];
    }
  }

  my $fg     = $self->fgcolor;
  my $fill   = $self->fillcolor;
  my $center = ($y1 + $y2)/2;

  # each segment becomes a box
  for my $e (@boxes) {
    my @rect = ($e->[0],$y1,$e->[1],$y2);
    if ($e->[2] == 0 || !$stranded) {
      $self->filled_box($gd,@rect);
    } else {
#      $self->filled_arrow($gd,1,@rect);
      $self->oriented_box($gd,$e->[2],@rect);
    }
  }

  # each skip becomes a simple line
  for my $i (@skips) {
    next unless $i->[1] - $i->[0] >= 1;
    $gd->line($i->[0],$center,$i->[1],$center,$gray);
  }

  # draw label
  $self->draw_label($gd,@_) if $self->option('label');
}

sub oriented_box {
  my $self = shift;
  my $gd  = shift;
  my $orientation = shift;
  my ($x1,$y1,$x2,$y2) = @_;
  $self->filled_box($gd,@_);
  return unless $x2 - $x1 >= 4;
  $BRUSHES{$orientation} ||= $self->make_brush($orientation);
  my $top = int(1.5 + $y1 + ($y2 - $y1 - ($BRUSHES{$orientation}->getBounds)[1])/2);
  $gd->setBrush($BRUSHES{$orientation});
  $gd->setStyle(0,0,0,1);
  $gd->line($x1+2,$top,$x2-2,$top,gdStyledBrushed);
}

sub make_brush {
  my $self = shift;
  my $orientation = shift;

  my $brush   = GD::Image->new(3,3);
  my $bgcolor = $brush->colorAllocate(255,255,255); #white
  $brush->transparent($bgcolor);
  my $fgcolor   = $brush->colorAllocate($self->factory->panel->rgb($self->fgcolor));
  if ($orientation > 0) {
    $brush->setPixel(0,0,$fgcolor);
    $brush->setPixel(1,1,$fgcolor);
    $brush->setPixel(0,2,$fgcolor);
  } else {
    $brush->setPixel(1,0,$fgcolor);
    $brush->setPixel(0,1,$fgcolor);
    $brush->setPixel(1,2,$fgcolor);
  }
  $brush;