view release on metacpan or  search on metacpan

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

    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;
}


sub description {
  my $self = shift;
  $self->feature->info;
}

1;

__END__

=head1 NAME

Ace::Graphics::Glyph::segments - The "discontinuous segments" glyph

=head1 SYNOPSIS

  See L<Ace::Graphics::Panel> and L<Ace::Graphics::Glyph>.

=head1 DESCRIPTION

This glyph draws a sequence feature that consists of multiple
discontinuous segments, such as the exons on a transcript or a gapped
alignment.  The representation is a series of filled rectangles
connected by line segments.

The features passed to it must either respond to the
Bio::SequenceFeatureI-style subSeqFeatures() method, or the
AcePerl/Das-style segments() or merged_segments() methods.

=head2 OPTIONS

In addition to the common options, this glyph recognizes the
b<-stranded> argument.  If b<-stranded> is true and the feature is an
alignment (has the target() method) then the glyph will draw little
arrows in the segment boxes to indicate the direction of the
alignment.

=head1 BUGS

Please report them.

=head1 SEE ALSO

L<Ace::Sequence>, L<Ace::Sequence::Feature>, L<Ace::Graphics::Panel>,
L<Ace::Graphics::Track>,
L<Ace::Graphics::Glyph::anchored_arrow>,
L<Ace::Graphics::Glyph::arrow>,
L<Ace::Graphics::Glyph::box>,
L<Ace::Graphics::Glyph::primers>,
L<Ace::Graphics::Glyph::segments>,
L<Ace::Graphics::Glyph::toomany>,
L<Ace::Graphics::Glyph::transcript>,

=head1 AUTHOR

Lincoln Stein <lstein@cshl.org>.