#!/usr/bin/perl
use strict;
use warnings;
use Bio::Graphics;
use Bio::Graphics::Panel;
use Bio::Graphics::Glyph::decorated_transcript;
use Bio::DB::SeqFeature::Store;
use Bio::SeqFeature::Generic;
use Data::Dumper;
# load features
my $store = Bio::DB::SeqFeature::Store->new
(
-adaptor => 'memory',
-dsn => 'data/decorated_transcript_t1.gff'
);
my ($gene1) = $store->features(-name => 'PFA0680c');
#print Dumper($rna1);
# draw panel
my $panel = Bio::Graphics::Panel->new
(
-length => $gene1->end-$gene1->start+102,
-offset => $gene1->start-100,
-key_style => 'between',
-width => 1024,
-pad_left => 100
);
# ruler
$panel->add_track
(
Bio::SeqFeature::Generic->new(-start => $gene1->start-100, -end => $gene1->end),
-glyph => 'arrow',
-bump => 0,
-double => 1,
-tick => 2
);
$panel->add_track
(
$gene1,
-glyph => 'decorated_gene',
-label_transcripts => 1,
-description => 'Signal peptide spans intron, isoform1 has extra callback decoration, isoform2 lacks TM domain',
-label => 1,
-height => 12,
-decoration_visible => sub {
my ($feature, $option_name, $part_no, $total_parts, $glyph) = @_;
return 0 if ($glyph->active_decoration->name eq "TM"
and $glyph->active_decoration->score < 8);
},
-decoration_color => sub {
my ($feature, $option_name, $part_no, $total_parts, $glyph) = @_;
return 'black' if ($glyph->active_decoration->name eq "TM");
return 'red' if ($glyph->active_decoration->name eq "VTS");
},
-decoration_label_color => sub {
my ($feature, $option_name, $part_no, $total_parts, $glyph) = @_;
return 'white' if ($glyph->active_decoration->name eq "VTS");
},
-additional_decorations => sub {
my $feature = shift;
my ($id) = $feature->get_tag_values('load_id');
my %add_h = ( "rna_PFA0680c-1" => "test:callback:100:130:0" );
return $add_h{$id};
}
);
# decoration outside transcript boundaries, transparent background
my ($gene2) = $store->features(-name => 'test1');
{
$panel->add_track
(
$gene2,
-glyph => 'decorated_gene',
-description => sub { "Gene label and description do not bump with extended decoration boundaries" },
-label => 1,
-label_position => 'top',
-height => 12,
-decoration_visible => 1,
-decoration_border => "dashed",
-decoration_color => "transparent",
-decoration_label_position => "above",
-decoration_label => 1,
-decoration_height => 17,
-decoration_border_color => "blue"
);
}
# use of decorated_transcript glyph directly, with mRNA feature
{
my ($rna2) = $gene2->get_SeqFeatures('mRNA');
$panel->add_track
(
$rna2,
-glyph => 'decorated_transcript',
-description => sub { "This text should not bump with decoration label" },
-label => 1,
-label_position => 'top',
-height => 16,
-decoration_visible => 1,
-decoration_border => "solid",
-decoration_color => "yellow",
-decoration_label_position => sub {
return "below" if ($_[4]->active_decoration->type eq "method1");
return "inside";
},
-decoration_label => sub {
return "another interesting region"
if ($_[4]->active_decoration->type eq "method1");
return 1; # return 1 to draw default label
},
-decoration_height => 20,
-decoration_border_color => "red"
);
}
# gene with UTR
{
my ($gene) = $store->features(-name => 'PVX_000640');
$panel->add_track
(
$gene,
-glyph => 'decorated_gene',
-description => 1,
-label => 1,
-height => 12,
-decoration_color => "yellow",
-label_position => 'top',
-decoration_visible => 1,
);
}
# write image
my $imgfile = "data/decorated_transcript_t1.png";
open(IMG,">$imgfile") or die "could not write to file $imgfile";
print IMG $panel->png;
close(IMG);
print "Image written to $imgfile\n";