view variant_effect_predictor/Bio/Graphics/Glyph/cds.pm @ 3:d30fa12e4cc5 default tip

Merge heads 2:a5976b2dce6f and 1:09613ce8151e which were created as a result of a recently fixed bug.

package Bio::Graphics::Glyph::cds;

use strict;
use Bio::Graphics::Glyph::segments;
use Bio::Graphics::Util qw(frame_and_offset);
use Bio::Tools::CodonTable;
use Bio::Graphics::Glyph::translation;
use vars '@ISA';
@ISA = qw(Bio::Graphics::Glyph::segmented_keyglyph Bio::Graphics::Glyph::translation);

my %default_colors = qw(
			frame0f  cadetblue
			frame1f  blue
			frame2f  darkblue
			frame0r  darkred
			frame1r  red
			frame2r crimson
		       );

sub connector   { 0 };
sub description {
  my $self = shift;
  return if $self->level;
  return $self->SUPER::description;
};

sub default_color {
  my ($self,$key) = @_;
  return $self->factory->translate_color($default_colors{$key});
}

sub sixframe {
  my $self = shift;
  $self->{sixframe} = $self->option('sixframe')
    unless exists $self->{sixframe};
  return $self->{sixframe};
}

sub require_subparts {
  my $self = shift;
  my $rs   = $self->option('require_subparts');
  $rs      = $self->feature->type eq 'coding' if !defined $rs;  # shortcut for the "coding" aggregator
  $rs;
}

# figure out (in advance) the color of each component
sub draw {
  my $self = shift;
  my ($gd,$left,$top) = @_;

  my @parts = $self->parts;
  @parts    = $self if !@parts && $self->level == 0 && !$self->require_subparts;

  my $fits = $self->protein_fits;

  # draw the staff (musically speaking)
  my ($x1,$y1,$x2,$y2) = $self->bounds($left,$top);
  my $line_count = $self->sixframe ? 6 : 3;
  my $height = ($y2-$y1)/$line_count;
  my $grid  = $self->gridcolor;
  for (0..$line_count-1) {
    my $offset = $y1+$height*$_+1;
    $gd->line($x1,$offset,$x2,$offset,$grid);
  }

  $self->{cds_part2color} ||= {};
  my $fill   = $self->bgcolor;
  my $strand = $self->feature->strand;

  # figure out the colors of each part
  # sort minus strand features backward
  @parts = map { $_->[0] }
  sort { $b->[1] <=> $a->[1] }
  map { [$_, $_->left ] } @parts if $strand < 0;
  my $translate_table = Bio::Tools::CodonTable->new;

  for (my $i=0; $i < @parts; $i++) {
    my $part    = $parts[$i];
    my $feature = $part->feature;
    my $pos     = $strand > 0 ? $feature->start : $feature->end;
    my $phase   = eval {$feature->phase} || 0;
    my ($frame,$offset) = frame_and_offset($pos,
					   $feature->strand,
					   -$phase);
    my $suffix = $strand < 0 ? 'r' : 'f';
    my $key = "frame$frame$suffix";
    $self->{cds_frame2color}{$key} ||= $self->color($key) || $self->default_color($key) || $fill;
    $part->{cds_partcolor} = $self->{cds_frame2color}{$key};
    $part->{cds_frame}     = $frame;
    $part->{cds_offset}    = $offset;

    if ($fits && $part->feature->seq) {

      # do in silico splicing in order to find the codon that
      # arises from the splice
      my $protein = $part->feature->translate(undef,undef,$phase)->seq;
      $part->{cds_translation}  = $protein;

    BLOCK: {
	length $protein >= $feature->length/3           and last BLOCK;
	($feature->length - $phase) % 3 == 0            and last BLOCK;
	
	my $next_part    = $parts[$i+1]
	  or do {
	    $part->{cds_splice_residue} = '?';
	    last BLOCK; };
	
	my $next_feature = $next_part->feature         or  last BLOCK;
	my $next_phase   = eval {$next_feature->phase} or  last BLOCK;
	my $splice_codon = '';
	my $left_of_splice  = substr($feature->seq,-$next_phase,$next_phase);
	my $right_of_splice = substr($next_feature->seq,0,3-$next_phase);
	$splice_codon = $left_of_splice . $right_of_splice;
	length $splice_codon == 3                      or last BLOCK;
	my $amino_acid = $translate_table->translate($splice_codon);
	$part->{cds_splice_residue} = $amino_acid;
      }
    }
  }

  $self->Bio::Graphics::Glyph::generic::draw($gd,$left,$top);
}


# draw the notes on the staff
sub draw_component {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->bounds(@_);

  my $color = $self->{cds_partcolor} or return;
  my $feature   = $self->feature;
  my $frame     = $self->{cds_frame};
  my $linecount = $self->sixframe ? 6 : 3;

  unless ($self->protein_fits) {
    my $height = ($y2-$y1)/$linecount;
    my $offset = $y1 + $height*$frame;
    $offset   += ($y2-$y1)/2 if $self->sixframe && $self->strand < 0;
    $gd->filledRectangle($x1,$offset,$x2,$offset+2,$color);
    return;
  }

  # we get here if there's room to draw the primary sequence
  my $font  = $self->font;
  my $pixels_per_residue = $self->pixels_per_residue;
  my $strand = $feature->strand;
  my $y      = $y1-1;

  $strand *= -1 if $self->{flip};

  # have to remap feature start and end into pixel coords in order to:
  # 1) correctly align the amino acids with the nucleotide seq
  # 2) correct for the phase offset
  my $start = $self->map_no_trunc($feature->start + $self->{cds_offset});
  my $stop  = $self->map_no_trunc($feature->end   + $self->{cds_offset});
  ($start,$stop) = ($stop,$start) if $self->{flip};

  my @residues = split '',$self->{cds_translation};

  push @residues,$self->{cds_splice_residue} if $self->{cds_splice_residue};
  for (my $i=0;$i<@residues;$i++) {
    my $x = $strand > 0 ? $start + $i * $pixels_per_residue
                        : $stop  - $i * $pixels_per_residue;
    next unless ($x >= $x1 && $x <= $x2);
    $gd->char($font,$x+1,$y,$residues[$i],$color);
  }
}

sub make_key_feature {
  my $self = shift;
  my @gatc = qw(g a t c);
  my $offset = $self->panel->offset;
  my $scale = 1/$self->scale;  # base pairs/pixel
  my $start = $offset;
  my $stop  = $offset + 100 * $scale;
  my $seq   = join('',map{$gatc[rand 4]} (1..1500));
  my $feature =
    Bio::Graphics::Feature->new(-start=> $start,
				-end  => $stop,
				-seq  => $seq,
				-name => $self->option('key'),
				-strand=> +1,
			       );
  $feature->add_segment(Bio::Graphics::Feature->new(
						    -start=> $start,
						    -end => $start + ($stop - $start)/2,
						    -seq  => $seq,
						    -name => $self->option('key'),
						    -strand=> +1,
						   ),
			Bio::Graphics::Feature->new(
						    -start=> $start + ($stop - $start)/2+1,
						    -end => $stop,
						    -seq  => $seq,
						    -name => $self->option('key'),
						    -phase=> 1,
						    -strand=> +1,
						   ));
  $feature;
}

# never allow our components to bump
sub bump {
  my $self = shift;
  return $self->SUPER::bump(@_) if $self->all_callbacks;
  return 0;
}

1;

__END__

=head1 NAME

Bio::Graphics::Glyph::cds - The "cds" glyph

=head1 SYNOPSIS

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

=head1 DESCRIPTION

This glyph draws features that are associated with a protein coding
region.  At high magnifications, draws a series of boxes that are
color-coded to indicate the frame in which the translation occurs.  At
low magnifications, draws the amino acid sequence of the resulting
protein.  Amino acids that are created by a splice are optionally
shown in a distinctive color.

=head2 OPTIONS

The following options are standard among all Glyphs.  See
L<Bio::Graphics::Glyph> for a full explanation.

  Option      Description                      Default
  ------      -----------                      -------

  -fgcolor      Foreground color	       black

  -outlinecolor	Synonym for -fgcolor

  -bgcolor      Background color               turquoise

  -fillcolor    Synonym for -bgcolor

  -linewidth    Line width                     1

  -height       Height of glyph		       10

  -font         Glyph font		       gdSmallFont

  -connector    Connector type                 0 (false)

  -connector_color
                Connector color                black

  -label        Whether to draw a label	       0 (false)

  -description  Whether to draw a description  0 (false)

  -strand_arrow Whether to indicate            0 (false)
                 strandedness

In addition, the alignment glyph recognizes the following
glyph-specific options:

  Option      Description                  Default
  ------      -----------                  -------

  -frame0f    Color for first (+) frame    background color

  -frame1f    Color for second (+) frame   background color

  -frame2f    Color for third (+) frame    background color

  -frame0r    Color for first (-) frame    background color

  -frame1r    Color for second (-) frame   background color

  -frame2r    Color for third (-) frame    background color

  -gridcolor  Color for the "staff"        lightslategray

  -sixframe   Draw a six-frame staff       0 (false; usually draws 3 frame)

  -require_subparts
              Don't draw the reading frame 0 (false)
              unless it is a feature
              subpart.

The -require_subparts option is suggested when rendering spliced
transcripts which contain multiple CDS subparts.  Otherwise, the glyph
will hickup when zoomed way down onto an intron between two CDSs (a
phantom reading frame will appear).  For unspliced sequences, do *not*
use -require_subparts.

=head1 SUGGESTED STANZA FOR GENOME BROWSER

Using the "coding" aggregator, this produces a nice gbrowse display.

 [CDS]
 feature      = coding
 glyph        = cds
 frame0f      = cadetblue
 frame1f      = blue
 frame2f      = darkblue
 frame0r      = darkred
 frame1r      = red
 frame2r      = crimson
 description  = 0
 height       = 13
 label        = CDS frame
 key          = CDS
 citation     = This track shows CDS reading frames.

=head1 BUGS

Please report them.

=head1 SEE ALSO

L<Bio::Graphics::Panel>,
L<Bio::Graphics::Glyph>,
L<Bio::Graphics::Glyph::arrow>,
L<Bio::Graphics::Glyph::cds>,
L<Bio::Graphics::Glyph::crossbox>,
L<Bio::Graphics::Glyph::diamond>,
L<Bio::Graphics::Glyph::dna>,
L<Bio::Graphics::Glyph::dot>,
L<Bio::Graphics::Glyph::ellipse>,
L<Bio::Graphics::Glyph::extending_arrow>,
L<Bio::Graphics::Glyph::generic>,
L<Bio::Graphics::Glyph::graded_segments>,
L<Bio::Graphics::Glyph::heterogeneous_segments>,
L<Bio::Graphics::Glyph::line>,
L<Bio::Graphics::Glyph::pinsertion>,
L<Bio::Graphics::Glyph::primers>,
L<Bio::Graphics::Glyph::rndrect>,
L<Bio::Graphics::Glyph::segments>,
L<Bio::Graphics::Glyph::ruler_arrow>,
L<Bio::Graphics::Glyph::toomany>,
L<Bio::Graphics::Glyph::transcript>,
L<Bio::Graphics::Glyph::transcript2>,
L<Bio::Graphics::Glyph::translation>,
L<Bio::Graphics::Glyph::triangle>,
L<Bio::DB::GFF>,
L<Bio::SeqI>,
L<Bio::SeqFeatureI>,
L<Bio::Das>,
L<GD>

=head1 AUTHOR

Lincoln Stein E<lt>[e-mail]<gt>

Copyright (c) 2001 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut