view release on metacpan or  search on metacpan

lib/Bio/Graphics/Glyph/processed_transcript.pm  view on Meta::CPAN

package Bio::Graphics::Glyph::processed_transcript;

use strict;
use base qw(Bio::Graphics::Glyph::transcript2);
use constant DEFAULT_UTR_COLOR => '#D0D0D0';

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
  $self->guess_options if !defined $self->option('implied_utrs') 
    && !defined $self->option('adjust_exons');
  $self;
}

sub guess_options {
  my $self = shift;
  my ($exons,$utrs,$cds);
  foreach ($self->parts) {
    $exons++ if $_->feature->type =~ /exon/i;
    $utrs++  if $_->feature->type =~ /utr$/i;
    $cds++   if $_->feature->type =~ /^cds/i;
    $self->configure(implied_utrs=>1) if $exons && $cds && !$utrs;
    $self->configure(adjust_exons=>1) if $exons && $utrs;
  }
}

# this option will generate implied UTRs by subtracting the
# CDS features from the exons.
sub create_implied_utrs {
  my $self = shift;
  return if $self->{'.implied_utrs'}++;

  # parts should be ordered from left to right
  my @features = sort {$a->start <=> $b->start} map {$_->feature} $self->parts;

  my @exons   = grep {$_->type =~ /^exon/} @features;
  my @cds     = grep {$_->type =~ /^CDS/ } @features;
  my @old_utr = grep {$_->type =~ /UTR/  } @features;

  # if there are already UTRs then we don't modify anything
  return if @old_utr;

  # if exons or CDS features are missing, then we abandon ship
  return unless @exons && @cds;

  my $first_cds = $cds[0];
  my $last_cds  = $cds[-1];
  my $strand = $self->feature->strand;

  my $factory    = $self->factory;

  # make the left-hand UTRs
  for (my $i=0;$i<@exons;$i++) {
    my $start = $exons[$i]->start;
    last if $start >= $first_cds->start;
    my $end  = $first_cds->start > $exons[$i]->end ? $exons[$i]->end : $first_cds->start-1;
    my $utr = Bio::Graphics::Feature->new(-start=>$start,
					  -end=>$end,
					  -strand=>$strand,
					  -type=>$strand >= 0 ? 'five_prime_UTR' : 'three_prime_UTR');
    unshift @{$self->{parts}},$factory->make_glyph($self->{level}+1,$utr);
  }
  # make the right-hand UTRs
  for (my $i=$#exons; $i>=0; $i--) {
    my $end = $exons[$i]->end;
    last if $end <= $last_cds->end;
    my $start = $last_cds->end < $exons[$i]->start ? $exons[$i]->start : $last_cds->end+1;
    my $utr = Bio::Graphics::Feature->new(-start=>$start,
					  -end=>$end,
					  -strand=>$strand,
					  -type=>$strand >= 0 ? 'three_prime_UTR' : 'five_prime_UTR');
    push @{$self->{parts}},$factory->make_glyph($self->{level}+1,$utr);
  }
}