[med-svn] [SCM] libbio-graphics-perl branch, upstream, updated. upstream/2.32-1-gfc9ea5c
Olivier Sallou
olivier.sallou at debian.org
Mon Jul 29 06:25:30 UTC 2013
The following commit has been merged in the upstream branch:
commit fc9ea5cfb0ec8bd2953411b242bcac0b8b583c7a
Author: Olivier Sallou <olivier.sallou at debian.org>
Date: Mon Jul 29 08:25:01 2013 +0200
Imported Upstream version 2.37
diff --git a/Build.PL b/Build.PL
index 7edef23..9e6c9cf 100755
--- a/Build.PL
+++ b/Build.PL
@@ -18,7 +18,7 @@ my $build = Module::Build->new(
recommends => {
'GD::SVG' => 0.32,
'Text::ParseWords' => 3.26, # required for Bio::Graphics::Wiggle::Loader
- 'Bio::SCF' => 1.01, # required for Bio::Graphics::Glyph::trace
+# 'Bio::SCF' => 1.01, # required for Bio::Graphics::Glyph::trace
},
script_files => ['scripts/contig_draw.pl',
'scripts/feature_draw.pl',
diff --git a/Changes b/Changes
index 2820f15..779759e 100755
--- a/Changes
+++ b/Changes
@@ -1,4 +1,27 @@
Revision history for Perl extension Bio::Graphics.
+2.37
+ - Merge fix for incorrect parsing of feature_file sections (issue #6)
+ - Added decorated_transcript glyph
+ - Added nathanweeks fix for broken heatmap glyph
+
+2.36
+ - Fix regression in glyph parent_feature() method so that it once again returns
+ the parent of the current feature.
+ - Remove recommended prerequisite of Bio::SCF, which is hardly used now.
+
+2.35
+ - Change Glyph/segments.pm to work with both variants of CIGAR strings.
+ - Workaround for broken useFontConfig() support in versions of GD prior to 2.50.
+ - Fix "gdTinyFont doesn't support height() method error in xyplot".
+
+2.34 Thu May 16 15:42:25 CDT 2013
+ - Fixed silent crashes when rendering with the GD::SVG class.
+
+2.33 Fri Feb 22 15:58:10 EST 2013
+ - Add truetype support. Enable by passing -truetype=>1 to Bio::Graphics::Panel->new()
+
+2.32 Mon Dec 10 05:47:45 EST 2012
+ - Clean up appearance of crossbox to avoid odd black bar in the middle.
2.32 Mon Dec 10 05:47:45 EST 2012
- Clean up appearance of crossbox to avoid odd black bar in the middle.
diff --git a/MANIFEST b/MANIFEST
index 98a2bb5..d80b0bb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -14,6 +14,7 @@ lib/Bio/Graphics/FeatureBase.pm
lib/Bio/Graphics/FeatureDir.pm
lib/Bio/Graphics/FeatureFile.pm
lib/Bio/Graphics/FeatureFile/Iterator.pm
+lib/Bio/Graphics/GDWrapper.pm
lib/Bio/Graphics/Glyph.pm
lib/Bio/Graphics/Glyph/alignment.pm
lib/Bio/Graphics/Glyph/allele_tower.pm
@@ -26,6 +27,8 @@ lib/Bio/Graphics/Glyph/christmas_arrow.pm
lib/Bio/Graphics/Glyph/cross.pm
lib/Bio/Graphics/Glyph/crossbox.pm
lib/Bio/Graphics/Glyph/dashed_line.pm
+lib/Bio/Graphics/Glyph/decorated_gene.pm
+lib/Bio/Graphics/Glyph/decorated_transcript.pm
lib/Bio/Graphics/Glyph/diamond.pm
lib/Bio/Graphics/Glyph/dna.pm
lib/Bio/Graphics/Glyph/dot.pm
@@ -126,7 +129,11 @@ scripts/index_cov_files.pl
scripts/render_msa.pl
scripts/search_overview.pl
t/BioGraphics.t
+t/data/decorated_transcript_t1.gff
+t/data/decorated_transcript_t1.png
t/data/feature_data.txt
+t/data/t1.gif
+t/data/t1.png
t/data/t1/version1.gif
t/data/t1/version1.png
t/data/t1/version10.png
@@ -136,6 +143,8 @@ t/data/t1/version12.gif
t/data/t1/version12.png
t/data/t1/version13.gif
t/data/t1/version13.png
+t/data/t1/version14.gif
+t/data/t1/version14.png
t/data/t1/version2.gif
t/data/t1/version2.png
t/data/t1/version3.gif
@@ -147,6 +156,8 @@ t/data/t1/version7.png
t/data/t1/version8.png
t/data/t1/version9.gif
t/data/t1/version9.png
+t/data/t2.gif
+t/data/t2.png
t/data/t2/version1.gif
t/data/t2/version1.png
t/data/t2/version10.png
@@ -166,6 +177,8 @@ t/data/t2/version19.gif
t/data/t2/version19.png
t/data/t2/version2.gif
t/data/t2/version2.png
+t/data/t2/version20.gif
+t/data/t2/version20.png
t/data/t2/version3.gif
t/data/t2/version3.png
t/data/t2/version4.png
@@ -174,6 +187,8 @@ t/data/t2/version6.png
t/data/t2/version7.png
t/data/t2/version8.png
t/data/t2/version9.png
+t/data/t3.gif
+t/data/t3.png
t/data/t3/version1.gif
t/data/t3/version1.png
t/data/t3/version10.gif
@@ -186,6 +201,8 @@ t/data/t3/version13.gif
t/data/t3/version13.png
t/data/t3/version14.gif
t/data/t3/version14.png
+t/data/t3/version15.gif
+t/data/t3/version15.png
t/data/t3/version2.gif
t/data/t3/version2.png
t/data/t3/version3.gif
@@ -198,4 +215,5 @@ t/data/t3/version8.gif
t/data/t3/version8.png
t/data/t3/version9.png
t/data/wig_data.wig
+t/decorated_transcript_t1.pl
t/Wiggle.t
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index d537914..3083cfa 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -10,3 +10,4 @@ Build$
^[^/]+\.gff3
MANIFEST\.bak
~$
+\.patch
diff --git a/META.json b/META.json
index efc64b6..e1bd058 100644
--- a/META.json
+++ b/META.json
@@ -21,7 +21,6 @@
},
"runtime" : {
"recommends" : {
- "Bio::SCF" : "1.01",
"GD::SVG" : "0.32",
"Text::ParseWords" : "3.26"
},
@@ -35,7 +34,7 @@
"provides" : {
"Bio::Graphics" : {
"file" : "lib/Bio/Graphics.pm",
- "version" : "2.32"
+ "version" : "2.37"
},
"Bio::Graphics::ConfiguratorI" : {
"file" : "lib/Bio/Graphics/ConfiguratorI.pm",
@@ -69,6 +68,10 @@
"file" : "lib/Bio/Graphics/FeatureDir.pm",
"version" : 0
},
+ "Bio::Graphics::GDWrapper" : {
+ "file" : "lib/Bio/Graphics/GDWrapper.pm",
+ "version" : 0
+ },
"Bio::Graphics::Glyph" : {
"file" : "lib/Bio/Graphics/Glyph.pm",
"version" : 0
@@ -121,6 +124,14 @@
"file" : "lib/Bio/Graphics/Glyph/dashed_line.pm",
"version" : 0
},
+ "Bio::Graphics::Glyph::decorated_gene" : {
+ "file" : "lib/Bio/Graphics/Glyph/decorated_gene.pm",
+ "version" : 0
+ },
+ "Bio::Graphics::Glyph::decorated_transcript" : {
+ "file" : "lib/Bio/Graphics/Glyph/decorated_transcript.pm",
+ "version" : 0
+ },
"Bio::Graphics::Glyph::diamond" : {
"file" : "lib/Bio/Graphics/Glyph/diamond.pm",
"version" : 0
@@ -472,5 +483,5 @@
"http://dev.perl.org/licenses/"
]
},
- "version" : "2.32"
+ "version" : "2.37"
}
diff --git a/META.yml b/META.yml
index 8782fd7..343d703 100644
--- a/META.yml
+++ b/META.yml
@@ -15,7 +15,7 @@ name: Bio-Graphics
provides:
Bio::Graphics:
file: lib/Bio/Graphics.pm
- version: 2.32
+ version: 2.37
Bio::Graphics::ConfiguratorI:
file: lib/Bio/Graphics/ConfiguratorI.pm
version: 0
@@ -40,6 +40,9 @@ provides:
Bio::Graphics::FileSplitter:
file: lib/Bio/Graphics/FeatureDir.pm
version: 0
+ Bio::Graphics::GDWrapper:
+ file: lib/Bio/Graphics/GDWrapper.pm
+ version: 0
Bio::Graphics::Glyph:
file: lib/Bio/Graphics/Glyph.pm
version: 0
@@ -79,6 +82,12 @@ provides:
Bio::Graphics::Glyph::dashed_line:
file: lib/Bio/Graphics/Glyph/dashed_line.pm
version: 0
+ Bio::Graphics::Glyph::decorated_gene:
+ file: lib/Bio/Graphics/Glyph/decorated_gene.pm
+ version: 0
+ Bio::Graphics::Glyph::decorated_transcript:
+ file: lib/Bio/Graphics/Glyph/decorated_transcript.pm
+ version: 0
Bio::Graphics::Glyph::diamond:
file: lib/Bio/Graphics/Glyph/diamond.pm
version: 0
@@ -338,7 +347,6 @@ provides:
file: lib/Bio/Graphics/Wiggle/Loader.pm
version: 0
recommends:
- Bio::SCF: 1.01
GD::SVG: 0.32
Text::ParseWords: 3.26
requires:
@@ -347,4 +355,4 @@ requires:
Statistics::Descriptive: 2.6
resources:
license: http://dev.perl.org/licenses/
-version: 2.32
+version: 2.37
diff --git a/lib/Bio/Graphics.pm b/lib/Bio/Graphics.pm
index d1e4055..2894b28 100755
--- a/lib/Bio/Graphics.pm
+++ b/lib/Bio/Graphics.pm
@@ -2,7 +2,7 @@ package Bio::Graphics;
use strict;
use Bio::Graphics::Panel;
-our $VERSION = '2.32';
+our $VERSION = '2.37';
1;
diff --git a/lib/Bio/Graphics/FeatureFile.pm b/lib/Bio/Graphics/FeatureFile.pm
index 6ce16f3..002715f 100755
--- a/lib/Bio/Graphics/FeatureFile.pm
+++ b/lib/Bio/Graphics/FeatureFile.pm
@@ -842,7 +842,7 @@ sub _state_transition {
return 'data' if $line =~ /^reference\s*=/; # feature-file reference sequence directive
return 'config' if $line =~ /^\s*$/; #empty line
- return 'config' if $line =~ m/^\[([^\]]+)\]/; # section beginning
+ return 'config' if $line =~ m/^\[(.+)\]/; # section beginning
return 'config' if $line =~ m/^[\w:\s]+=/
&& $self->{current_config}; # configuration line
return 'config' if $line =~ m/^\s+(.+)/
@@ -870,7 +870,7 @@ sub parse_config_line {
return 1;
}
- elsif (/^\[([^\]]+)\]/) { # beginning of a configuration section
+ elsif (/^\[(.+)\]/) { # beginning of a configuration section
my $label = $1;
my $cc = $label =~ /^(general|default)$/i ? 'general' : $label; # normalize
push @{$self->{types}},$cc unless $cc eq 'general';
diff --git a/lib/Bio/Graphics/GDWrapper.pm b/lib/Bio/Graphics/GDWrapper.pm
new file mode 100644
index 0000000..7f9a3bc
--- /dev/null
+++ b/lib/Bio/Graphics/GDWrapper.pm
@@ -0,0 +1,91 @@
+package Bio::Graphics::GDWrapper;
+
+use base 'GD::Image';
+use Memoize 'memoize';
+use Carp 'cluck';
+memoize('_match_font');
+
+my $DefaultFont;
+
+#from http://reeddesign.co.uk/test/points-pixels.html
+my %Pixel2Point = (
+ 8 => 6,
+ 9 => 7,
+ 10 => 7.5,
+ 11 => 8,
+ 12 => 9,
+ 13 => 10,
+ 14 => 10.5,
+ 15 =>11,
+ 16 => 12,
+ 17 => 13,
+ 18 => 13.5,
+ 19 => 14,
+ 20 => 14.5,
+ 21 => 15,
+ 22 => 16,
+ 23 => 17,
+ 24 => 18,
+ 25 => 19,
+ 26 => 20
+ );
+my $GdInit;
+
+sub new {
+ my $self = shift;
+ my ($gd,$default_font) = @_;
+ $DefaultFont = $default_font unless $default_font eq '1';
+ $gd->useFontConfig(1);
+ return bless $gd,ref $self || $self;
+}
+
+sub default_font { return $DefaultFont || 'Arial' }
+
+# print with a truetype string
+sub string {
+ my $self = shift;
+ my ($font,$x,$y,$string,$color) = @_;
+ return $self->SUPER::string(@_) if $self->isa('GD::SVG');
+ my $fontface = $self->_match_font($font);
+# warn "$font => $fontface";
+ my ($fontsize) = $fontface =~ /-(\d+)/;
+ $self->stringFT($color,$fontface,$fontsize,0,$x,$y+$fontsize+1,$string);
+}
+
+sub string_width {
+ my $self = shift;
+ my ($font,$string) = @_;
+ my $fontface = $self->_match_font($font);
+ my ($fontsize) = $fontface =~ /-([\d.]+)/;
+ my @bounds = GD::Image->stringFT(0,$fontface,$fontsize,0,0,0,$string);
+ return abs($bounds[2]-$bounds[0]);
+}
+
+sub string_height {
+ my $self = shift;
+ my ($font,$string) = @_;
+ my $fontface = $self->_match_font($font);
+ my ($fontsize) = $fontface =~ /-(\d+)/;
+ my @bounds = GD::Image->stringFT(0,$fontface,$fontsize,0,0,0,$string);
+ return abs($bounds[5]-$bounds[3]);
+}
+
+# find a truetype match for a built-in font
+sub _match_font {
+ my $self = shift;
+ my $font = shift;
+ return $font unless ref $font && $font->isa('GD::Font');
+
+ # work around older versions of GD that require useFontConfig to be called from a GD::Image instance
+ $GdInit++ || eval{GD::Image->useFontConfig(1)} || GD::Image->new(10,10)->useFontConfig(1);
+
+ my $fh = $font->height-1;
+ my $height = $Pixel2Point{$fh} || $fh;
+ my $style = $font eq GD->gdMediumBoldFont ? 'bold'
+ :$font eq GD->gdGiantFont ? 'bold'
+ :'normal';
+ my $ttfont = $self->default_font;
+ return "$ttfont-$height:$style";
+}
+
+1;
diff --git a/lib/Bio/Graphics/Glyph.pm b/lib/Bio/Graphics/Glyph.pm
index 21376ef..b6d2587 100755
--- a/lib/Bio/Graphics/Glyph.pm
+++ b/lib/Bio/Graphics/Glyph.pm
@@ -8,12 +8,13 @@ use Bio::Graphics::Layout;
use Memoize 'memoize';
memoize('options') unless $^O =~ /mswin/i;
-# memoize('option'); # helps ??
+# memoize('option',NORMALIZER=>'_normalize_objects'); # helps ??
+my %OptionCache; # works better?
use base qw(Bio::Root::Root);
my %LAYOUT_COUNT;
-my @FEATURE_STACK;
+our @FEATURE_STACK;
# the CM1 and CM2 constants control the size of the hash used to
# detect collisions.
@@ -205,6 +206,7 @@ sub demo_feature {
return;
}
+sub gd { shift->panel->current_gd }
# a bumpable graphical object that has bumpable graphical subparts
@@ -221,6 +223,8 @@ sub new {
my $level = $arg{-level} || 0;
my $flip = $arg{-flip};
+ push @FEATURE_STACK,($feature,undef);
+
my $self = bless {},$class;
$self->{feature} = $feature;
$self->{factory} = $factory;
@@ -260,13 +264,13 @@ sub new {
$self->feature_has_subparts(@subfeatures>0);
if (@visible_subfeatures) {
- # dynamic glyph resolution
- @subglyphs = map { $_->[0] }
+ # dynamic glyph resolution
+ @subglyphs = map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [$_, $_->left ] }
$self->make_subglyph($level+1, at visible_subfeatures);
- $self->{feature_count} = scalar @subglyphs;
- $self->{parts} = \@subglyphs;
+ $self->{feature_count} = scalar @subglyphs;
+ $self->{parts} = \@subglyphs;
}
# warn "type=",$feature->type,", glyph=$self, subglyphs=@subglyphs";
@@ -293,7 +297,7 @@ sub new {
}
$self->{point} = $arg{-point} ? $self->height : undef;
-
+ splice(@FEATURE_STACK,-2);
return $self;
}
@@ -471,7 +475,10 @@ sub width {
}
sub layout_height {
my $self = shift;
- return $self->layout;
+ push @FEATURE_STACK,$self->feature;
+ my $result = $self->layout;
+ pop @FEATURE_STACK;
+ return $result;
}
sub layout_width {
my $self = shift;
@@ -533,90 +540,101 @@ sub unfilled_box {
sub boxes {
my $self = shift;
+ push @FEATURE_STACK,$self->feature;
+
my ($left,$top,$parent) = @_;
$top += 0; $left += 0;
my @result;
- $self->layout;
- $parent ||= $self;
- my $subparts = $self->box_subparts || 0;
-
- for my $part ($self->parts) {
- my $type = $part->feature->primary_tag || '';
- if ($type eq 'group' or $subparts > $part->level) {
- push @result,$part->boxes($left,$top+$self->top+$self->pad_top,$parent);
- next if $type eq 'group';
- }
- my ($x1,$y1,$x2,$y2) = $part->box;
- $x2++ if $x1==$x2;
- push @result,[$part->feature,
- $left + $x1,$top+$self->top+$self->pad_top+$y1,
- $left + $x2,$top+$self->top+$self->pad_top+$y2,
- $parent];
- }
+ $self->layout;
+ $parent ||= $self;
+ my $subparts = $self->box_subparts || 0;
+
+ for my $part ($self->parts) {
+ my $type = $part->feature->primary_tag || '';
+ if ($type eq 'group' or $subparts > $part->level) {
+ push @result,$part->boxes($left,$top+$self->top+$self->pad_top,$parent);
+ next if $type eq 'group';
+ }
+ my ($x1,$y1,$x2,$y2) = $part->box;
+ $x2++ if $x1==$x2;
+ push @result,[$part->feature,
+ $left + $x1,$top+$self->top+$self->pad_top+$y1,
+ $left + $x2,$top+$self->top+$self->pad_top+$y2,
+ $parent];
+ }
+
+ pop @FEATURE_STACK;
+ return wantarray ? @result : \@result;
+ }
- return wantarray ? @result : \@result;
-}
+ sub box_subparts {
+ my $self = shift;
+ return $self->{box_subparts} if exists $self->{box_subparts};
+ return $self->{box_subparts} = $self->_box_subparts;
+ }
-sub box_subparts {
- my $self = shift;
- return $self->{box_subparts} if exists $self->{box_subparts};
- return $self->{box_subparts} = $self->_box_subparts;
-}
+ sub _box_subparts { shift->option('box_subparts') }
-sub _box_subparts { shift->option('box_subparts') }
+ # this should be overridden for labels, etc.
+ # allows glyph to make itself thicker or thinner depending on
+ # domain-specific knowledge
+ sub pad_top {
+ my $self = shift;
+ return 0;
+ }
+ sub pad_bottom {
+ my $self = shift;
+ return 0;
+ }
+ sub pad_left {
+ my $self = shift;
+ my @parts = $self->parts or return 0;
+ my $max = 0;
+ foreach (@parts) {
+ my $pl = $_->pad_left;
+ $max = $pl if $max < $pl;
+ }
+ $max;
+ }
+ sub pad_right {
+ my $self = shift;
+ my @parts = $self->parts or return 0;
+ my $max = 0;
+ my $max_right = 0;
+ foreach (@parts) {
+ my $right = $_->right;
+ my $pr = $_->pad_right;
+ if ($max_right < $pr+$right) {
+ $max = $pr;
+ $max_right = $pr+$right;
+ }
+ }
+ $max;
+ }
-# this should be overridden for labels, etc.
-# allows glyph to make itself thicker or thinner depending on
-# domain-specific knowledge
-sub pad_top {
- my $self = shift;
- return 0;
-}
-sub pad_bottom {
- my $self = shift;
- return 0;
-}
-sub pad_left {
- my $self = shift;
- my @parts = $self->parts or return 0;
- my $max = 0;
- foreach (@parts) {
- my $pl = $_->pad_left;
- $max = $pl if $max < $pl;
- }
- $max;
-}
-sub pad_right {
- my $self = shift;
- my @parts = $self->parts or return 0;
- my $max = 0;
- foreach (@parts) {
- my $pr = $_->pad_right;
- $max = $pr if $max < $pr;
- }
- $max;
-}
+ # move relative to parent
+ sub move {
+ my $self = shift;
+ my ($dx,$dy) = @_;
+ $self->{left} += $dx;
+ $self->{top} += $dy;
-# move relative to parent
-sub move {
- my $self = shift;
- my ($dx,$dy) = @_;
- $self->{left} += $dx;
- $self->{top} += $dy;
+ # because the feature parts use *absolute* not relative addressing
+ # we need to move each of the parts horizontally, but not vertically
+ $_->move($dx,0) foreach $self->parts;
+ }
- # because the feature parts use *absolute* not relative addressing
- # we need to move each of the parts horizontally, but not vertically
- $_->move($dx,0) foreach $self->parts;
-}
-
-# get an option
-sub option {
- my $self = shift;
- my $option_name = shift;
- my @args = ($option_name,@{$self}{qw(partno total_parts)});
- my $factory = $self->{factory} or return;
- return $factory->option($self, at args)
+ # get an option
+ sub option {
+ my $self = shift;
+ my $option_name = shift;
+ local $^W=0;
+ my $cache_key = join ';',(%$self,$option_name);
+ return $OptionCache{$cache_key} if exists $OptionCache{$cache_key};
+ my @args = ($option_name,@{$self}{qw(partno total_parts)});
+ my $factory = $self->{factory} or return;
+ return $OptionCache{$cache_key} = $factory->option($self, at args);
}
# get an option that might be a code reference
@@ -762,23 +780,9 @@ sub getfont {
my $font = $self->option($option) || $default;
return unless $font;
- my $img_class = $self->image_class;
-
- unless (UNIVERSAL::isa($font,$img_class . '::Font')) {
- my $ref = {
- gdTinyFont => $img_class->gdTinyFont(),
- gdSmallFont => $img_class->gdSmallFont(),
- gdMediumBoldFont => $img_class->gdMediumBoldFont(),
- gdLargeFont => $img_class->gdLargeFont(),
- gdGiantFont => $img_class->gdGiantFont(),
- sanserif => $img_class->gdSmallFont(),
- };
-
- my $gdfont = $ref->{$font} || $ref->{gdSmallFont};
- $self->configure($option => $gdfont);
- return $gdfont;
- }
- return $font;
+ my $gdfont = $self->panel->gdfont($font);
+ $self->configure($option => $gdfont);
+ return $gdfont;
}
sub tkcolor { # "track color"
@@ -848,6 +852,7 @@ sub layout_sort {
# handle collision detection
sub layout {
my $self = shift;
+
return $self->{layout_height} if exists $self->{layout_height};
my @parts = $self->parts;
@@ -1028,7 +1033,7 @@ sub optimized_layout {
$_->{layout_height}+BUMP_SPACING
]
} $self->layout_sort(@$parts);
-
+
my $layout = Bio::Graphics::Layout->new(0,$self->panel->right);
my $overbumped;
while (@rects) {
@@ -1044,13 +1049,18 @@ sub optimized_layout {
return $overbumped && $overbumped < $layout->totalHeight ? $overbumped : $layout->totalHeight;
}
+sub draw_it {
+ my $self = shift;
+ push @FEATURE_STACK,$self->feature;
+ $self->draw(@_);
+ pop @FEATURE_STACK;
+}
+
sub draw {
my $self = shift;
my $gd = shift;
my ($left,$top,$partno,$total_parts) = @_;
- push @FEATURE_STACK,$self->feature;
-
$self->panel->startGroup($gd);
my $connector = $self->connector;
@@ -1071,7 +1081,7 @@ sub draw {
my $fake_x = $x;
$fake_x-- if defined $last_x && $parts[$i]->left - $last_x == 1;
$parts[$i]->draw_highlight($gd,$fake_x,$y);
- $parts[$i]->draw($gd,$fake_x,$y,$i,scalar(@parts));
+ $parts[$i]->draw_it($gd,$fake_x,$y,$i,scalar(@parts));
$last_x = $parts[$i]->right;
}
}
@@ -1083,9 +1093,6 @@ sub draw {
}
$self->panel->endGroup($gd);
-
- pop @FEATURE_STACK;
-
}
sub connector { return }
@@ -1110,6 +1117,7 @@ sub parent_feature {
$ancestors = 1 unless defined $ancestors;
return unless @FEATURE_STACK;
+
my $index = $#FEATURE_STACK - $ancestors;
return unless $index >= 0;
return $FEATURE_STACK[$index];
@@ -1467,6 +1475,30 @@ sub linewidth {
shift->option('linewidth') || 1;
}
+sub font_width {
+ my $self = shift;
+ my $font = shift;
+ $self->panel->string_width($font||$self->font,'m');
+}
+
+sub font_height {
+ my $self = shift;
+ my $font = shift;
+ $self->panel->string_height($font||$self->font,'hj');
+}
+
+sub string_width {
+ my $self = shift;
+ my ($string,$font) = @_;
+ $self->panel->string_width($font||$self->font,$string||'m');
+}
+
+sub string_height {
+ my $self = shift;
+ my ($string,$font) = @_;
+ $self->panel->string_height($font||$self->font,$string||'hj');
+}
+
sub fill {
my $self = shift;
my $gd = shift;
@@ -1821,7 +1853,12 @@ sub _pod_options {
return $pod;
}
-
+# normalizer for memoize
+sub _normalize_objects {
+ my ($obj,$option_name) = @_;
+ my @args = (%$obj,$option_name);
+ return "@args";
+}
1;
diff --git a/lib/Bio/Graphics/Glyph/Factory.pm b/lib/Bio/Graphics/Glyph/Factory.pm
index 9e1bf06..1661255 100755
--- a/lib/Bio/Graphics/Glyph/Factory.pm
+++ b/lib/Bio/Graphics/Glyph/Factory.pm
@@ -53,6 +53,8 @@ use strict;
use Carp qw(:DEFAULT cluck);
use Bio::Root::Version;
use base qw(Bio::Root::Root);
+#use Memoize 'memoize';
+#memoize('option');
my %LOADED_GLYPHS = ();
my %GENERIC_OPTIONS = (
diff --git a/lib/Bio/Graphics/Glyph/anchored_arrow.pm b/lib/Bio/Graphics/Glyph/anchored_arrow.pm
index 1cb3b1c..3300f6d 100755
--- a/lib/Bio/Graphics/Glyph/anchored_arrow.pm
+++ b/lib/Bio/Graphics/Glyph/anchored_arrow.pm
@@ -48,7 +48,7 @@ sub draw_label {
my $x = $self->left + $left;
my $font = $self->option('labelfont') || $self->font;
my $middle = $self->left + $left + ($self->right - $self->left) / 2;
- my $label_width = $font->width * length($label);
+ my $label_width = $self->string_width($label,$font);
if ($label_align eq 'center') {
my $new_x = $middle - $label_width / 2;
$x = $new_x if ($new_x > $x);;
diff --git a/lib/Bio/Graphics/Glyph/arrow.pm b/lib/Bio/Graphics/Glyph/arrow.pm
index 0b582c8..e699a74 100755
--- a/lib/Bio/Graphics/Glyph/arrow.pm
+++ b/lib/Bio/Graphics/Glyph/arrow.pm
@@ -113,7 +113,7 @@ my %UNITS = (p => 1e-12,
sub pad_bottom {
my $self = shift;
my $val = $self->SUPER::pad_bottom(@_);
- $val += $self->font->height if $self->option('tick');
+ $val += $self->string_height($self->font) if $self->option('tick');
$val;
}
@@ -190,7 +190,7 @@ sub draw_parallel {
if ($self->option('tick')) {
local $^W = 0; # dumb uninitialized variable warning
my $font = $self->font;
- my $width = $font->width;
+ my $width = $self->string_width('m',$font);
my $font_color = $self->fontcolor;
my $height = $self->height;
diff --git a/lib/Bio/Graphics/Glyph/cds.pm b/lib/Bio/Graphics/Glyph/cds.pm
index a36af48..f87e245 100755
--- a/lib/Bio/Graphics/Glyph/cds.pm
+++ b/lib/Bio/Graphics/Glyph/cds.pm
@@ -284,7 +284,7 @@ sub draw_component {
}
# we get here if there's room to draw the primary sequence
- my $font = $self->font;
+ my $font = $self->mono_font;
my $pixels_per_residue = $self->pixels_per_residue;
my $strand = $feature->strand;
my $y = $y1-1;
diff --git a/lib/Bio/Graphics/Glyph/decorated_gene.pm b/lib/Bio/Graphics/Glyph/decorated_gene.pm
new file mode 100644
index 0000000..1518098
--- /dev/null
+++ b/lib/Bio/Graphics/Glyph/decorated_gene.pm
@@ -0,0 +1,159 @@
+package Bio::Graphics::Glyph::decorated_gene;
+
+use strict;
+use base 'Bio::Graphics::Glyph::decorated_transcript';
+
+sub extra_arrow_length {
+ my $self = shift;
+ return 0 unless $self->{level} == 1;
+ local $self->{level} = 0; # fake out superclass
+ return $self->SUPER::extra_arrow_length;
+}
+
+sub pad_left {
+ my $self = shift;
+ my $type = $self->feature->primary_tag;
+ return 0 unless $type =~ /gene|mRNA/;
+ $self->SUPER::pad_left;
+}
+
+sub pad_right {
+ my $self = shift;
+ return 0 unless $self->{level} < 2; # don't invoke this expensive call on exons
+ my $strand = $self->feature->strand;
+ $strand *= -1 if $self->{flip};
+ my $pad = $self->SUPER::pad_right;
+ return $pad unless defined($strand) && $strand > 0;
+ my $al = $self->arrow_length;
+ return $al > $pad ? $al : $pad;
+}
+
+sub pad_bottom {
+ my $self = shift;
+ return 0 unless $self->{level} < 2; # don't invoke this expensive call on exons
+ return $self->SUPER::pad_bottom;
+}
+
+sub pad_top {
+ my $self = shift;
+ return 0 unless $self->{level} < 2; # don't invoke this expensive call on exons
+ return $self->SUPER::pad_top;
+}
+
+sub bump {
+ my $self = shift;
+ return 1 if $self->{level} == 0; # top level bumps, other levels don't unless specified in config
+ return $self->SUPER::bump;
+}
+
+sub label {
+ my $self = shift;
+ return unless $self->{level} < 2;
+ if ($self->label_transcripts && $self->{feature}->primary_tag eq 'mRNA') { # the mRNA
+ return $self->_label;
+ } else {
+ return $self->SUPER::label;
+ }
+}
+
+sub label_position {
+ my $self = shift;
+ return 'top' if $self->{level} == 0;
+ return 'left';
+}
+
+sub label_transcripts {
+ my $self = shift;
+ return $self->{label_transcripts} if exists $self->{label_transcripts};
+ return $self->{label_transcripts} = $self->_label_transcripts;
+}
+
+sub _label_transcripts {
+ my $self = shift;
+ return $self->option('label_transcripts');
+}
+
+sub draw_connectors {
+ my $self = shift;
+ return if $self->feature->primary_tag eq 'gene';
+ $self->SUPER::draw_connectors(@_);
+}
+
+sub maxdepth {
+ my $self = shift;
+ my $md = $self->Bio::Graphics::Glyph::maxdepth;
+ return $md if defined $md;
+ return 2;
+}
+
+
+sub _subfeat {
+ my $class = shift;
+ my $feature = shift;
+ return $feature->get_SeqFeatures('mRNA') if $feature->primary_tag eq 'gene';
+
+ my @subparts;
+ if ($class->option('sub_part')) {
+ @subparts = $feature->get_SeqFeatures($class->option('sub_part'));
+ }
+ else {
+
+ @subparts = $feature->get_SeqFeatures(qw(CDS five_prime_UTR three_prime_UTR UTR));
+ }
+
+ # The CDS and UTRs may be represented as a single feature with subparts or as several features
+ # that have different IDs. We handle both cases transparently.
+ my @result;
+ foreach (@subparts) {
+ if ($_->primary_tag =~ /CDS|UTR/i) {
+ my @cds_seg = $_->get_SeqFeatures;
+ if (@cds_seg > 0) { push @result, at cds_seg } else { push @result,$_ }
+ } else {
+ push @result,$_;
+ }
+ }
+ return @result;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bio::Graphics::Glyph::decorated_gene - A GFF3-compatible gene glyph with protein decorations
+
+=head1 SYNOPSIS
+
+ See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
+
+=head1 DESCRIPTION
+
+This glyph has the same functionality as the L<Bio::Graphics::Glyph::gene> glyph, but uses
+the L<Bio::Graphics::Glyph::decorated_transcript> glyph instead of the
+L<Bio::Graphics::Glyph::processed_transcript> glyph to draw transcripts.
+
+One usecase for the 'decorated_gene' glyph is to highlight protein features
+of different splice forms of the same gene to see how splice forms differ in terms of protein
+features, for example the presence of predicted signal peptides or protein domains.
+
+See L<Bio::Graphics::Glyph::decorated_transcript> for a description of how to provide
+protein decorations for transcripts.
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+
+L<Bio::Graphics::Glyph::gene>,
+L<Bio::Graphics::Glyph::decorated_transcript>
+
+=head1 AUTHOR
+
+Christian Frech E<lt>cfa24 at sfu.caE<gt>
+
+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
diff --git a/lib/Bio/Graphics/Glyph/decorated_transcript.pm b/lib/Bio/Graphics/Glyph/decorated_transcript.pm
new file mode 100644
index 0000000..77ab3b5
--- /dev/null
+++ b/lib/Bio/Graphics/Glyph/decorated_transcript.pm
@@ -0,0 +1,1153 @@
+package Bio::Graphics::Glyph::decorated_transcript;
+
+use strict;
+use warnings;
+
+use Bio::Graphics::Panel;
+use List::Util qw[min max];
+
+use constant DECORATION_TAG_NAME => 'protein_decorations';
+use constant DEBUG => 0;
+
+my @color_names = Bio::Graphics::Panel::color_names;
+
+use base
+ qw(Bio::Graphics::Glyph::processed_transcript Bio::Graphics::Glyph::segments);
+
+sub my_descripton {
+ return <<END;
+This glyph extends the functionality of the Bio::Graphics::Glyph::processed_transcript glyph
+and allows to draw protein decorations (e.g., signal peptides, transmembrane domains, protein domains)
+on top of gene models. Currently, the glyph can draw decorations in form of colored or outlined boxes
+inside or around CDS segments. Protein decorations are specified at the 'mRNA' transcript level
+in protein coordinates. Protein coordinates are automatically mapped to nucleotide coordinates by the glyph.
+Decorations are allowed to span exon-exon junctions, in which case decorations are split between exons.
+By default, the glyph automatically assigns different colors to different types of protein decorations, whereas
+decorations of the same type are always assigned the same color.
+
+Protein decorations are provided either with mRNA features inside GFF files (see example below) or
+dynamically via callback function using the B<additional_decorations> option (see glyph options).
+The following line is an example of an mRNA feature in a GFF file that contains two protein decorations,
+one signal peptide predicted by SignalP and one transmembrane domain predicted by TMHMM:
+
+chr1 my_source mRNA 74796 75599 . + . ID=rna_gene-1;protein_decorations=SignalP40:SP:1:23:0:my_comment,TMHMM:TM:187:209:0
+
+Each protein decoration consists of six fields separated by a colon:
+
+1) Type. For example used to specify decoration source (e.g. 'SignalP40')
+2) Name. Decoration name. Used as decoration label by default (e.g. 'SP' for signal peptide)
+3) Start. Start coordinate at the protein-level (1-based coordinate)
+4) End. End coordinate at the protein-level
+5) Score. Optional. Score associated with a decoration (e.g. Pfam E-value). This score can be used
+ to dynamically filter or color decorations via callbacks (see glyph options).
+6) Description. Optional. User-defined description of decoration. The glyph ignores this description,
+ but it will be made available to callback functions for inspection. Special characters
+ like ':' or ',' that might interfere with the GFF tag parser should be avoided.
+
+If callback functions are used as glyph parameters (see below), the callback is called for each
+decoration separately. That is, the callback can be called multiple times for the same CDS feature,
+but each time with a different decoration. The currently drawn (active) decoration is made available
+to the callback via the glyph method 'active_decoration'. The active decoration is returned in form
+of a Bio::Graphics::Feature object, with decoration data fields mapped to corresponding feature
+attributes in the following way:
+
+ type --> \$glyph->active_decoration->type
+ name --> \$glyph->active_decoration->name
+ nucleotide start coordinate --> \$glyph->active_decoration->start
+ nucleotide end coordinate --> \$glyph->active_decoration->end
+ protein start coordinate --> \$glyph->active_decoration->get_tag_values('p_start')
+ protein end coordinate --> \$glyph->active_decoration->get_tag_values('p_end')
+ score --> \$glyph->active_decoration->score
+ description --> \$glyph->active_decoration->description
+
+In addition, the glyph passed to the callback allows access to the parent glyph and
+parent feature if required (use \$glyph->parent or \$glyph->parent->feature).
+
+END
+}
+
+sub my_options {
+ return {
+ decoration_visible => [
+ 'boolean',
+ 'false',
+ 'Specifies whether decorations should be visible or not. For selective display of individual',
+ 'decorations, specify a callback function and return 1 or 0 after inspecting the active',
+ 'decoration of the glyph. '],
+ decoration_color => [
+ 'color',
+ undef,
+ 'Decoration background color. If no color is specified, colors are assigned automatically',
+ 'by decoration type and name, whereas decorations of identical type and name are assigned',
+ 'the same color. A special color \'transparent\' can be used here in combination with',
+ 'the option \'decoration_border\' to draw decorations as outlines.'],
+ decoration_border => [
+ ['none', 'solid', 'dashed'],
+ 'none',
+ 'Decoration border style. By default, decorations are drawn without border (\'none\' or',
+ '0). Other valid options here include \'solid\' or \'dashed\'.'],
+ decoration_border_color => [
+ 'color',
+ 'black',
+ 'Color of decoration boder.'],
+ decoration_label => [
+ 'string',
+ undef,
+ 'Decoration label. If not specified, the second data field of the decoration is used',
+ 'as label. Set this option to 0 to get unlabeled decorations. If the label text',
+ 'extends beyond the size of the decorated segment, the label will be clipped. Clipping',
+ 'does not occur for SVG output.'],
+ decoration_label_position => [
+ ['inside', 'above', 'below'],
+ undef,
+ 'Position of decoration label. Labels can be drawn \'inside\' decorations (default)',
+ 'or \'above\' and \'below\' decorations.'],
+ decoration_label_color => [
+ 'color',
+ 'undef',
+ 'Decoration label color. If not specified, this color is complementary to',
+ 'decoration_color (e.g., yellow text on blue background, white on black, etc.). If the',
+ 'decoration background color is transparent and no decoration label color is specified,',
+ 'the foreground color of the underlying transcript glyph is used as default.'],
+ additional_decorations => [
+ 'string',
+ undef,
+ 'Additional decorations to those specified in the GFF file. Expected is a string',
+ 'in the same format as described above for GFF files. This parameter is intended',
+ 'to be used as callback function, which inspects the currently processed transcript',
+ 'feature (first parameter to callback) and returns additional protein decorations',
+ 'that should be drawn.'],
+ decoration_height => [
+ 'integer',
+ undef,
+ 'Decoration height. Unless specified otherwise, the height of the decoration is the',
+ 'height of the underlying transcript glyph minus 2, such that the decoration is drawn',
+ 'within transcript boundaries.'],
+ decoration_position => [
+ ['inside'],
+ 'inside',
+ 'Currently, decorations can only be drawn inside CDS segments.'],
+ flip_minus => [
+ 'boolean',
+ 0,
+ 'If set to 1, features on the negative strand will be drawn flipped.',
+ 'This is not particularly useful in GBrowse, but becomes handy if multiple features',
+ 'should be drawn within the same panel, left-aligned, and on top of each other,',
+ 'for example to allow easy gene structure comparisons.'],
+ }
+}
+
+sub new {
+ my ( $class, @args ) = @_;
+ my %param = @args;
+
+ warn "new(): " . join( ",", @args ) . "\n" if (DEBUG == 2);
+
+ my $feature = $param{'-feature'};
+ my $factory = $param{'-factory'};
+
+ my $flip_minus = $factory->get_option('flip_minus');
+ if ( $flip_minus and $feature->strand < 1 ) {
+ for ( my $i = 0 ; $i < @args ; $i++ ) {
+ $args[ $i + 1 ] = 1 if ( $args[$i] eq '-flip' );
+ }
+ }
+
+ my $self = $class->Bio::Graphics::Glyph::processed_transcript::new(@args);
+
+ $self->{'parent'} = undef;
+ $self->{'additional_decorations'} = undef;
+ $self->{'active_decoration'} = undef;
+ $self->{'add_pad_bottom'} = undef;
+
+ # give sub-glyphs access to parent glyph's decorations
+ if ($self->decorations_visible)
+ {
+ foreach my $sub_glyph ( $self->parts ) {
+ $sub_glyph->{'parent'} = $self;
+ }
+ }
+
+ bless( $self, $class );
+
+ return $self;
+}
+
+sub finished {
+ my $self = shift;
+
+ warn "finished(): ".$self->feature->primary_tag." ".$self->feature."\n" if (DEBUG == 2);
+
+ foreach my $sub_glyph ( $self->parts ) {
+ $sub_glyph->{'parent'} = undef;
+ }
+
+ $self->Bio::Graphics::Glyph::processed_transcript::finished(@_);
+}
+
+
+sub parent {
+ my $self = shift;
+ return $self->{'parent'};
+}
+
+sub decorations {
+ my $self = shift;
+ my $feature = $self->feature;
+
+ return $self->{'parent'}->decorations(@_)
+ if ($self->{'parent'} and $feature->primary_tag ne "mRNA");
+
+ return $feature->get_tag_values(DECORATION_TAG_NAME);
+}
+
+# allows to retrieve additional decorations via callback
+sub additional_decorations {
+ my $self = shift;
+ my $feature = $self->feature;
+
+ return $self->{'parent'}->additional_decorations(@_)
+ if ($self->{'parent'} and $feature->primary_tag ne "mRNA");
+
+ return $self->{'additional_decorations'}
+ if (defined $self->{'additional_decorations'});
+
+ my @additional_decorations;
+ my $additional_decorations_str = $self->option('additional_decorations');
+ if ($additional_decorations_str)
+ {
+ push(@additional_decorations, split(",", $additional_decorations_str));
+ }
+
+ $self->{'additional_decorations'} = \@additional_decorations;
+
+ return \@additional_decorations;
+}
+
+sub all_decorations {
+ my $self = shift;
+
+ my @all_decorations;
+
+ # no decorations at gene level
+ return \@all_decorations
+ if ($self->feature->primary_tag eq "gene");
+
+ # forward request to mRNA parent glyph;
+ # allows CDS child glyphs to retrieve decoration information from mRNA
+ return $self->{'parent'}->all_decorations(@_)
+ if ($self->{'parent'} and $self->feature->primary_tag ne "mRNA");
+
+ # decoration data specified as feature tag
+ @all_decorations = $self->decorations;
+
+ # add additional decorations provided via callback
+ push(@all_decorations, @{$self->additional_decorations});
+
+ return \@all_decorations;
+}
+
+# returns stack offset of decoration (only used if decoration is drawn stacked)
+sub stack_offset_bottom {
+ my $self = shift;
+
+ return $self->{'parent'}->stack_offset_bottom(@_)
+ if ($self->{'parent'} and $self->feature->primary_tag ne "mRNA");
+
+ my $decoration = shift;
+ return $self->{'stack_offset_bottom'}{$decoration}
+}
+
+sub active_decoration {
+ my $self = shift;
+ return $self->{'active_decoration'};
+}
+
+# get all decorations, including mapped nucleotide coordinates
+sub mapped_decorations {
+ my $self = shift;
+ my $feature = $self->feature;
+
+ return $self->{'parent'}->mapped_decorations(@_)
+ if ($self->{'parent'} and $feature->primary_tag ne "mRNA");
+
+ $self->_map_decorations()
+ if (!defined $self->{'mapped_decorations'});
+
+ return $self->{'mapped_decorations'};
+}
+
+# get all mapped decorations, as sorted by user call-back (if provided)
+# by default, decorations are sorted by length, causing shorter decorations
+# to be drawn on top of longer decorations
+# TODO: document this new feature
+sub sorted_decorations {
+ my $self = shift;
+
+ # forward request to mRNA parent glyph;
+ # allows CDS child glyphs to retrieve decoration information from mRNA
+ return $self->{'parent'}->sorted_decorations(@_)
+ if ($self->{'parent'} and $self->feature->primary_tag ne "mRNA");
+
+ # cache for faster access
+ return $self->{'sorted_decorations'}
+ if (defined $self->{'sorted_decorations'});
+
+ # get sorted decorations from callback
+ my $sorted_decorations = $self->option('sorted_decorations');
+
+ # if no callback or bad return value, sort by length by default (causes longer
+ # decorations to be drawn first)
+ if (!$sorted_decorations or ref($sorted_decorations) ne 'ARRAY')
+ {
+ my @sorted = reverse sort { $a->length <=> $b->length } (@{$self->mapped_decorations});
+ $sorted_decorations = \@sorted;
+
+ if (DEBUG)
+ {
+ print STDERR "sorted decorations: ";
+ foreach my $sd (@$sorted_decorations) { print STDERR $sd->name."(".$sd->length.") "; }
+ print STDERR "\n";
+ }
+ }
+
+ $self->{'sorted_decorations'} = $sorted_decorations;
+
+ return $sorted_decorations;
+}
+
+sub _map_decorations {
+ my $self = shift;
+ my $feature = $self->feature;
+
+ $self->_map_coordinates();
+
+ my @mapped_decorations;
+ foreach my $h ( @{$self->all_decorations} ) {
+ my ( $type, $name, $p_start, $p_end, $score, $desc ) = split( ":", $h );
+
+ if (!defined $p_end)
+ {
+ warn "_map_decorations(): WARNING: invalid decoration data for feature $feature: '$h'\n";
+ next;
+ }
+
+ my $nt_start = $self->_map_codon_start($p_start);
+ if (!$nt_start)
+ {
+ warn "DECORATION=$h\n";
+ warn "_map_decorations(): WARNING: could not map decoration start coordinate on feature $feature(".$feature->primary_tag.")\n";
+ next;
+ }
+ my $nt_end = $self->_map_codon_end($p_end);
+ if (!$nt_end)
+ {
+ warn "DECORATION=$h\n";
+ warn "_map_decorations(): WARNING: could not map decoration end coordinate on feature $feature(".$feature->primary_tag.")\n";
+ next;
+ }
+
+ ( $nt_start, $nt_end ) = ( $nt_end, $nt_start )
+ if ( $nt_start > $nt_end );
+
+ my $f = Bio::Graphics::Feature->new
+ (
+ -type => $type,
+ -name => $name,
+ -start => $nt_start,
+ -end => $nt_end,
+ -score => $score,
+ -desc => $desc,
+ -seq_id => $feature->seq_id,
+ -strand => $feature->strand,
+ -attributes => { # remember protein coordinates for callbacks
+ 'p_start' => $p_start,
+ 'p_end' => $p_end
+ }
+ );
+
+# my $mapped_decoration = "$h:$nt_start:$nt_end";
+ push( @mapped_decorations, $f );
+
+ # init stack offset for stacked decorations
+ if ($self->decoration_position($f) eq 'stacked_bottom')
+ {
+ if (!defined $self->{'stack_offset_bottom'}{$f})
+ {
+ $self->{'cur_stack_offset_bottom'} = 2
+ if (!defined $self->{'cur_stack_offset_bottom'});
+
+ $self->{'stack_offset_bottom'}{$f} = $self->{'cur_stack_offset_bottom'};
+ $self->{'cur_stack_offset_bottom'} += $self->decoration_height($f);
+
+ warn "$self: stack offset ".$f->name."($f): ".$self->{'stack_offset_bottom'}{$f}."\n"
+ if (DEBUG);
+ }
+ }
+
+ warn "DECORATION=$h --> $nt_start:$nt_end\n" if (DEBUG);
+ }
+
+ $self->{'mapped_decorations'} = \@mapped_decorations;
+}
+
+sub _map_codon_start {
+ my $self = shift;
+ my $protein_coordinate = shift;
+
+ $self->throw('protein coordinate not specified: ')
+ if (!$protein_coordinate and DEBUG);
+
+ return $self->{'p2n'}->{$protein_coordinate}->{'codon_start'};
+}
+
+sub _map_codon_end {
+ my $self = shift;
+ my $protein_coordinate = shift;
+
+ $self->throw('protein coordinate not specified')
+ if (!$protein_coordinate and DEBUG);
+
+ return $self->{'p2n'}->{$protein_coordinate}->{'codon_end'};
+}
+
+# map protein to nucleotide coordinate
+sub _map_coordinates {
+ my $self = shift;
+
+ # sort all CDS features by coordinates
+ # NOTE: filtering for CDS features by passing feature type to get_SeqFeatures()
+ # does not work for some reason, probably when no feature store attached
+ my @cds =
+ grep { $_->primary_tag eq 'CDS' } $self->feature->get_SeqFeatures();
+ if ( $self->feature->strand > 0 ) {
+ my ( $ppos, $residue ) = ( 1, 0 );
+ my @sorted_cds = sort { $a->start <=> $b->start } (@cds);
+ foreach my $c (@sorted_cds) {
+ $self->{'p2n'}{ $ppos - 1 }{'codon_end'} = $c->start + $residue - 1
+ if ($residue);
+ for (
+ my $ntpos = $c->start + $residue ;
+ $ntpos <= $c->end ;
+ $ntpos += 3
+ )
+ {
+ $self->{'p2n'}{$ppos}{'codon_start'} = $ntpos;
+ $self->{'p2n'}{$ppos}{'codon_end'} = $ntpos + 2;
+ $ppos++;
+ $residue = $ntpos + 2 - $c->end;
+ }
+ }
+ }
+ else {
+ my ( $ppos, $residue ) = ( 1, 0 );
+ my @sorted_cds = reverse sort { $a->start <=> $b->start } (@cds);
+ foreach my $c (@sorted_cds) {
+ $self->{'p2n'}{ $ppos - 1 }{'codon_end'} = $c->end - $residue + 1
+ if ($residue);
+ for (
+ my $ntpos = $c->end - $residue ;
+ $ntpos >= $c->start ;
+ $ntpos -= 3
+ )
+ {
+ $self->{'p2n'}{$ppos}{'codon_start'} = $ntpos;
+ $self->{'p2n'}{$ppos}{'codon_end'} = $ntpos - 2;
+ $ppos++;
+ $residue = $c->start - ( $ntpos - 2 );
+ }
+ }
+ }
+}
+
+sub decoration_top {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return $self->top;
+ }
+
+ my $decoration_height = $self->decoration_height($decoration);
+ my $decoration_position = $self->decoration_position($decoration);
+
+ if ($decoration_position eq 'stacked_bottom')
+ {
+ $self->throw("$self: stack offset unknown for decoration ".$decoration->name."($decoration)")
+ if (!defined $self->stack_offset_bottom($decoration) and DEBUG);
+
+ return $self->bottom + $self->stack_offset_bottom($decoration);
+ }
+ else
+ {
+ $self->throw("invalid decoration_position: $decoration_position")
+ if (($decoration_position ne 'inside') and DEBUG);
+
+ return int(($self->bottom-$self->pad_bottom+$self->top+$self->pad_top)/2 - $decoration_height/2 + 0.5);
+ }
+}
+
+sub decoration_bottom {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return $self->bottom;
+ }
+
+ return $self->decoration_top($decoration) + $self->decoration_height($decoration) - 1;
+}
+
+sub _calc_add_padding
+{
+ my $self = shift;
+
+ my $height = $self->height;
+ my ($add_pad_bottom, $add_pad_top) = (0, 0);
+
+ foreach my $decoration (@{$self->mapped_decorations})
+ {
+ my $h_height = $self->decoration_height($decoration);
+
+ my ($label_pad_top, $label_pad_bottom) = (0, 0);
+ if ($self->decoration_label($decoration))
+ {
+ $label_pad_top = $self->labelfont->height
+ if ($self->decoration_label_position($decoration) eq "above");
+ $label_pad_bottom = $self->labelfont->height
+ if ($self->decoration_label_position($decoration) eq "below");
+ }
+
+ if (($h_height - $height)/2 + $label_pad_top > $add_pad_top)
+ {
+ $add_pad_top = ($h_height - $height)/2 + $label_pad_top;
+ }
+ if (($h_height - $height)/2 + $label_pad_bottom > $add_pad_bottom)
+ {
+ $add_pad_bottom = ($h_height - $height)/2 + $label_pad_bottom;
+ }
+ if ($self->{'stack_offset_bottom'}{$decoration} and $self->{'stack_offset_bottom'}{$decoration}+$h_height > $add_pad_bottom)
+ {
+ $add_pad_bottom = $self->{'stack_offset_bottom'}{$decoration}+$h_height;
+ }
+ }
+
+ $self->{'add_pad_bottom'} = $add_pad_bottom;
+ $self->{'add_pad_top'} = $add_pad_top;
+}
+
+# add extra padding if decoration exceeds transcript boundaries and if labeled outside
+sub pad_bottom {
+ my $self = shift;
+
+ my $bottom = $self->option('pad_bottom');
+ return $bottom if defined $bottom;
+
+ $self->_calc_add_padding()
+ if (!defined $self->{'add_pad_bottom'});
+
+ my $pad = $self->Bio::Graphics::Glyph::processed_transcript::pad_bottom;
+
+ return $pad if ($self->{'add_pad_bottom'} < 0);
+ return $pad + $self->{'add_pad_bottom'};
+}
+
+sub pad_top {
+ my $self = shift;
+
+ my $top = $self->option('pad_top');
+ return $top if defined $top;
+
+ $self->_calc_add_padding()
+ if (!defined $self->{'add_pad_top'});
+
+ my $pad = $self->Bio::Graphics::Glyph::processed_transcript::pad_top;
+
+ return $pad if ($self->{'add_pad_top'} < 0);
+ return $pad + $self->{'add_pad_top'};
+}
+
+sub decoration_height {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return $self->height;
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_height = $self->option('decoration_height');
+
+ $decoration_height = $self->height-2
+ if ( !$decoration_height );
+
+ return $decoration_height;
+}
+
+sub decoration_position {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "inside";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_position = $self->option('decoration_position');
+
+ $decoration_position = 'inside'
+ if ( !$decoration_position );
+
+ if ($decoration_position ne 'inside' and $decoration_position ne 'stacked_bottom')
+ {
+ $self->throw('invalid decoration_position: '.$decoration_position) if (DEBUG);
+ $decoration_position = 'inside';
+ }
+
+ return $decoration_position;
+}
+
+sub _hash {
+ my $hash = 0;
+ foreach ( split //, shift ) {
+ $hash = $hash * 33 + ord($_);
+ }
+ return $hash;
+}
+
+sub decoration_label_color {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "black";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_label_color = $self->option('decoration_label_color');
+
+ return $decoration_label_color
+ if ( defined $decoration_label_color
+ and $decoration_label_color ne 'auto'
+ and $decoration_label_color ne '' );
+
+ my $decoration_color = $self->decoration_color($decoration);
+
+ return $self->fgcolor
+ if ((!$decoration_label_color or $decoration_label_color eq 'auto')
+ and $decoration_color eq "transparent");
+
+ # assign color complementary to decoration color
+ my ( $red, $green, $blue ) =
+ Bio::Graphics::Panel->color_name_to_rgb($decoration_color);
+
+ $decoration_label_color =
+ sprintf( "#%02X%02X%02X", 255 - $red, 255 - $green, 255 - $blue ); # background complement
+
+ return $decoration_label_color;
+}
+
+sub decoration_label {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_label = $self->option('decoration_label');
+
+ return undef
+ if ( defined $decoration_label and $decoration_label eq "0" );
+
+ return $decoration_label
+ if ( $decoration_label and $decoration_label ne "1");
+
+ # assign decoration name as default label
+ return $decoration->name;
+}
+
+sub decoration_label_position {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_label_position = $self->option('decoration_label_position');
+
+ return "inside"
+ if (!$decoration_label_position);
+
+ return $decoration_label_position;
+}
+
+sub decoration_border {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ return $self->option('decoration_border');
+}
+
+sub decoration_color {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "white";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_color = $self->option('decoration_color');
+
+ return $decoration_color
+ if ( defined $decoration_color
+ and $decoration_color ne 'auto'
+ and $decoration_color ne '' );
+
+ # automatically assign color by hashing feature name to color index
+ my $col_idx = _hash($decoration->type.":".$decoration->name) % scalar(@color_names);
+
+ # decoration background should be different from CDS background
+ while ( $self->factory->translate_color($color_names[$col_idx]) eq $self->bgcolor )
+ {
+ $col_idx = ($col_idx + 1) % scalar(@color_names);
+ }
+
+ return $color_names[$col_idx];
+}
+
+sub decoration_border_color {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return "black";
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_border_color = $self->option('decoration_border_color');
+
+ return "black" if (!$decoration_border_color);
+
+ return $decoration_border_color;
+}
+
+sub decorations_visible {
+ my $self = shift;
+
+ return $self->code_option('decoration_visible');
+}
+
+sub decoration_visible {
+ my $self = shift;
+ my $decoration = shift;
+
+ if (!$decoration)
+ {
+ $self->throw("decoration not specified") if (DEBUG);
+ return 1;
+ }
+
+ $self->{'active_decoration'} = $decoration; # set active decoration for callback
+ my $decoration_visible = $self->option('decoration_visible');
+
+ return $decoration_visible
+ if ( defined $decoration_visible and $decoration_visible ne "" );
+
+ return 1;
+}
+
+#sub draw {
+# my $self = shift;
+#
+# warn "draw(): level " . $self->level . " " . $self->feature . "\n"
+# if (DEBUG);
+#
+# $self->Bio::Graphics::Glyph::processed_transcript::draw(@_);
+#
+#}
+
+sub draw_component {
+ my $self = shift;
+
+ warn "draw_component(): " . ref($self) . " " . $self->feature . "\n" if (DEBUG == 2);
+
+ # draw regular glyph first
+ if ( $self->feature->source eq 'legend' ) {
+ # hack, but processed_transcript cannot be drawn without arrow...
+ $self->Bio::Graphics::Glyph::segments::draw_component(@_);
+ }
+ else {
+ $self->Bio::Graphics::Glyph::processed_transcript::draw_component(@_);
+ }
+
+ # draw decorations if parent information available
+ if ( $self->{'parent'} and $self->feature->primary_tag eq "CDS") {
+ return $self->draw_decorations(@_);
+ }
+}
+
+sub draw_decorations {
+ my $self = shift;
+ my ( $gd, $dx, $dy ) = @_;
+
+ warn "draw_decorations(): " . $self->feature . "\n" if (DEBUG == 2);
+
+ my ( $left, $top, $right, $bottom ) = $self->bounds( $dx, $dy );
+
+ warn " bounds: left:$left,top:$top,right:$right,bottom:$bottom\n"
+ if (DEBUG == 2);
+
+ foreach my $mh (@{$self->sorted_decorations}) {
+
+ # skip invisible decorations
+ next if ( !$self->decoration_visible($mh) );
+
+ # determine overlapping segments between protein decorations and feature components
+ my $overlap_start_nt = max( $self->feature->start, $mh->start );
+ my $overlap_end_nt = min( $self->feature->end, $mh->end );
+ if ( $overlap_start_nt <= $overlap_end_nt ) {
+
+ # manual override; forces flip to be drawn flipped
+ $self->factory->panel->flip( $self->flip )
+ if ( $self->option('flip_minus') );
+
+ my ( $h_left, $h_right ) =
+ $self->map_no_trunc( $overlap_start_nt, $overlap_end_nt + 1 );
+ ( $h_left, $h_right ) = ( $h_right, $h_left )
+ if ( $h_left > $h_right );
+# my ($h_top, $h_bottom) = ($dy + $self->top + $self->pad_top, $dy + $self->bottom - $self->pad_bottom);
+ my $h_top = $dy + $self->decoration_top($mh);
+ my $h_bottom = $dy + $self->decoration_bottom($mh);
+
+ my $color = $self->decoration_color($mh);
+
+ # don't draw over borders; not supported by SVG
+ $gd->clip( $left + 1, $h_top, $right - 1, $h_bottom )
+ if ( !$gd->isa("GD::SVG::Image") );
+
+ if ($color ne 'transparent')
+ {
+ warn "filledRectangle: left=$h_left,top=$h_top,right=$h_right,bottom=$h_bottom\n"
+ if (DEBUG == 2);
+ $gd->filledRectangle( $h_left, $h_top, $h_right, $h_bottom,
+ $self->factory->translate_color($color) );
+ }
+
+ if ($self->decoration_border($mh))
+ {
+ my ($b_left, $b_top, $b_right, $b_bottom) = ($h_left, $h_top, $h_right, $h_bottom);
+ my $border_color = $self->factory->translate_color($self->decoration_border_color($mh));
+
+ warn "border rectangle: left=$b_left,top=$b_top,right=$b_right,bottom=$b_bottom\n"
+ if (DEBUG == 2);
+
+ if ($self->decoration_border($mh) eq "dashed")
+ {
+ my $image_class = $self->panel->image_class;
+ my $gdTransparent = $image_class->gdTransparent;
+ my $gdStyled = $image_class->gdStyled;
+ $gd->setStyle($border_color,$border_color,$border_color,$gdTransparent,$gdTransparent);
+ $gd->rectangle( $b_left, $b_top, $b_right, $b_bottom, $gdStyled );
+ }
+ else
+ {
+ $gd->rectangle( $b_left, $b_top, $b_right, $b_bottom, $border_color );
+ }
+
+ }
+
+ $gd->clip( 0, 0, $gd->width, $gd->height )
+ if ( !$gd->isa("GD::SVG::Image") );
+
+ # draw label on first overlapping component
+ my $h_label = $self->decoration_label($mh);
+ if ( $h_label
+ and (
+ ( $self->feature->strand > 0
+ and $mh->start >= $self->feature->start )
+ or ( $self->feature->strand <= 0
+ and $mh->end <= $self->feature->end )
+ )
+ )
+ {
+ $self->draw_decoration_label( $gd, $dx, $dy, $mh, $h_top,
+ $h_left, $h_bottom, $h_right, $h_label );
+ }
+ }
+ }
+}
+
+sub draw_decoration_label {
+ my $self = shift;
+ my ( $gd, $dx, $dy, $mh, $h_top, $h_left, $h_bottom, $h_right, $label ) = @_;
+
+ warn "draw_decoration_label(): " . $self->feature . "\n" if (DEBUG == 2);
+
+ my $font = $self->labelfont;
+ my $label_top = $h_top + ($self->decoration_height($mh)-$font->height)/2;
+ my $label_pos = $self->decoration_label_position($mh);
+ if ( $label_pos and $label_pos eq "above" ) {
+ $label_top = $h_top - $font->height - 1;
+ }
+ elsif ( $label_pos and $label_pos eq "below" ) {
+ $label_top = $h_top + $self->decoration_height($mh);
+ }
+
+ my $label_color = $self->decoration_label_color($mh);
+
+ $gd->clip( $h_left + 1, $label_top, $h_right - 1, $label_top + $font->height )
+ if ( !$gd->isa("GD::SVG::Image") );
+ $gd->string( $font, $h_left + 2,
+ $label_top, $label, $self->factory->translate_color($label_color) );
+ $gd->clip( 0, 0, $gd->width, $gd->height )
+ if ( !$gd->isa("GD::SVG::Image") );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bio::Graphics::Glyph::decorated_transcript - draws processed transcript with protein decorations
+
+=head1 SYNOPSIS
+
+ See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
+
+=head1 DESCRIPTION
+
+This glyph extends the functionality of the L<Bio::Graphics::Glyph::processed_transcript> glyph
+and allows to draw protein decorations (e.g., signal peptides, transmembrane domains, protein domains)
+on top of gene models. Currently, the glyph can draw decorations in form of colored or outlined boxes
+inside or around CDS segments. Protein decorations are specified at the 'mRNA' transcript level
+in protein coordinates. Protein coordinates are automatically mapped to nucleotide coordinates by the glyph.
+Decorations are allowed to span exon-exon junctions, in which case decorations are split between exons.
+By default, the glyph automatically assigns different colors to different types of protein decorations, whereas
+decorations of the same type are always assigned the same color.
+
+Protein decorations are provided either with mRNA features inside GFF files (see example below) or
+dynamically via callback function using the B<additional_decorations> option (see glyph options).
+The following line is an example of an mRNA feature in a GFF file that contains two protein decorations,
+one signal peptide predicted by SignalP and one transmembrane domain predicted by TMHMM:
+
+C<chr1 my_source mRNA 74796 75599 . + . ID=rna_gene-1;protein_decorations=SignalP40:SP:1:23:0:my_comment,TMHMM:TM:187:209:0>
+
+Each protein decoration consists of six fields separated by a colon:
+
+
+=over
+
+=item 1. type
+
+Decoration type. For example used to specify decoration source (e.g. 'SignalP40')
+
+=item 2. name
+
+Decoration name. Used as decoration label by default (e.g. 'SP' for signal peptide)
+
+=item 3. start
+
+Start coordinate at the protein-level (1-based coordinate)
+
+=item 4. end
+
+End coordinate at the protein-level
+
+=item 5. score
+
+Optional. Score associated with a decoration (e.g. Pfam E-value). This score can be used
+to dynamically filter or color decorations via callbacks (see glyph options).
+
+=item 6. description
+
+Optional. User-defined description of decoration. The glyph ignores this description,
+but it will be made available to callback functions for inspection. Special characters
+like ':' or ',' that might interfere with the GFF tag parser should be avoided.
+
+=back
+
+If callback functions are used as glyph parameters (see below), the callback is called for each
+decoration separately. That is, the callback can be called multiple times for a given CDS feature,
+but each time with a different decoration that overlaps with this CDS. The currently drawn (active)
+decoration is made available to the callback via the glyph method 'active_decoration'. The active
+decoration is returned in form of a Bio::Graphics::Feature object, with decoration data fields
+mapped to corresponding feature attributes in the following way:
+
+=over
+
+=item * type --> $glyph->active_decoration->type
+
+=item * name --> $glyph->active_decoration->name
+
+=item * nucleotide start coordinate --> $glyph->active_decoration->start
+
+=item * nucleotide end coordinate --> $glyph->active_decoration->end
+
+=item * protein start coordinate --> $glyph->active_decoration->get_tag_values('p_start')
+
+=item * protein end coordinate --> $glyph->active_decoration->get_tag_values('p_end')
+
+=item * score --> $glyph->active_decoration->score
+
+=item * description --> $glyph->active_decoration->description
+
+=back
+
+In addition, the glyph passed to the callback allows access to the parent glyph and
+parent feature if required (use $glyph->parent or $glyph->parent->feature).
+
+=head2 OPTIONS
+
+This glyph inherits all options from the L<Bio::Graphics::Glyph::processed_transcript> glyph.
+In addition, it recognizes the following glyph-specific options:
+
+ Option Description Default
+ ------ ----------- -------
+
+ -decoration_visible
+
+ Specifies whether decorations should be visible false
+ or not. For selective display of individual
+ decorations, specify a callback function and
+ return 1 or 0 after inspecting the active decoration
+ of the glyph.
+
+ -decoration_color
+
+ Decoration background color. If no color is <auto>
+ specified, colors are assigned automatically by
+ decoration type and name, whereas decorations of
+ identical type and name are assigned the same color.
+ A special color 'transparent' can be used here in
+ combination with the option 'decoration_border' to
+ draw decorations as outlines.
+
+ -decoration_border
+
+ Decoration border style. By default, decorations are 0 (none)
+ drawn without border ('none' or 0). Other valid
+ options here include 'solid' or 'dashed'.
+
+ -decoration_border_color
+
+ Color of decoration border. black
+
+ -decoration_label
+
+ Decoration label. If not specified, the second data true
+ field of the decoration is used as label. Set this (decoration name)
+ option to 0 to get unlabeled decorations. If the label
+ text extends beyond the size of the decorated segment,
+ the label will be clipped. Clipping does not occur
+ for SVG output.
+
+ -decoration_label_position
+
+ Position of decoration label. Labels can be drawn inside
+ 'inside' decorations (default) or 'above' and 'below'
+ decorations.
+
+ -decoration_label_color
+
+ Decoration label color. If not specified, this color
+ is complementary to decoration_color (e.g., yellow text
+ on blue background, white on black, etc.). If the
+ decoration background color is transparent and no
+ decoration label color is specified, the foreground color
+ of the underlying transcript glyph is used as default.
+
+ -additional_decorations
+
+ Additional decorations to those specified in the GFF undefined
+ file. Expected is a string in the same format as
+ described above for GFF files.
+ This parameter is intended to be used as callback
+ function, which inspects the currently processed
+ transcript feature (first parameter to callback)
+ and returns additional protein decorations that
+ should be drawn.
+
+ -decoration_height
+
+ Decoration height. Unless specified otherwise, CDS height-2
+ the height of the decoration is the height of the
+ underlying transcript glyph minus 2, such that
+ the decoration is drawn within transcript boundaries.
+
+ -decoration_position
+
+ Currently decorations can only be drawn inside inside
+ CDS segments.
+
+ -flip_minus
+
+ If set to 1, features on the negative strand will be false
+ drawn flipped. This is not particularly useful in
+ GBrowse, but becomes handy if multiple features should
+ be drawn within the same panel, left-aligned, and on
+ top of each other, for example to allow for easy gene
+ structure comparisons.
+
+=head1 BUGS
+
+Strandedness arrows are decorated incorrectly. Currently, the glyph plots a rectangular box
+over the arrow instead of properly coloring the arrow.
+
+Overlapping decorations are drawn on top of each other without particular order. The only
+solution to this problem at this point is to reduce decorations to a non-overlapping
+set.
+
+For SVG output or if drawn not inside decorations, decoration labels are not clipped.
+Similar as for overlapping decorations, this can result in labels being drawn on top
+of each other.
+
+Please report all errors.
+
+=head1 SEE ALSO
+
+
+L<Bio::Graphics::Panel>,
+L<Bio::Graphics::Glyph>,
+L<Bio::Graphics::Glyph::decorated_gene>,
+L<Bio::Graphics::Glyph::processed_transcript>
+
+=head1 AUTHOR
+
+Christian Frech E<lt>cfa24 at sfu.caE<gt>
+
+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
diff --git a/lib/Bio/Graphics/Glyph/dna.pm b/lib/Bio/Graphics/Glyph/dna.pm
index c2465f2..6b4d508 100755
--- a/lib/Bio/Graphics/Glyph/dna.pm
+++ b/lib/Bio/Graphics/Glyph/dna.pm
@@ -59,7 +59,7 @@ sub description { 0 }
sub pad_top {
my $self = shift;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $pt = $self->SUPER::pad_top;
return $self->dna_fits
? $pt + $font->height+5
@@ -68,7 +68,7 @@ sub pad_top {
sub height {
my $self = shift;
- my $font = $self->font;
+ my $font = $self->mono_font;
return $self->dna_fits ? 2*$font->height
: $self->do_gc ? $self->SUPER::height
: 0;
@@ -113,7 +113,7 @@ sub draw_dna {
my @bases = split '',$strand >= 0 ? $dna : $self->reversec($dna);
my $color = $self->fgcolor;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $lineheight = $font->height;
$y1 -= $lineheight/2 - 3;
my $strands = $self->option('strand') || 'auto';
@@ -147,6 +147,7 @@ sub draw_gc_content {
my ($x1,$y1,$x2,$y2) = @_;
$dna = $self->reversec($dna) if $self->{flip};
+ my $font = $self->mono_font;
# get the options that tell us how to draw the GC content
@@ -234,7 +235,7 @@ sub draw_gc_content {
my $axiscolor = $self->color('axis_color') || $fgcolor;
# Draw the axes
- my $fontwidth = $self->font->width;
+ my $fontwidth = $font->width;
$gd->line($x1, $y1, $x1, $y2, $axiscolor);
$gd->line($x2-2,$y1, $x2-2,$y2, $axiscolor);
$gd->line($x1, $y1, $x1+3,$y1, $axiscolor);
@@ -246,15 +247,16 @@ sub draw_gc_content {
$gd->line($x1+5,$y2, $x2-5,$y2, $bgcolor);
$gd->line($x1+5,($y2+$y1)/2,$x2-5,($y2+$y1)/2,$bgcolor);
$gd->line($x1+5,$y1, $x2-5,$y1, $bgcolor);
- $gd->string($self->font,$x1-length('% gc')*$fontwidth,$y1,'% gc',$axiscolor) if $bin_height > $self->font->height*2;
+ $gd->string($self->font,$x1-$self->string_width('% gc',$self->font),$y1,'% gc',$axiscolor)
+ if $bin_height > $self->font_height($font)*2;
# If we are using a sliding window, the GC graph will be scaled to use the full
# height of the glyph, so label the right vertical axis to show the scaling that# is in effect
$gd->string($self->font,$x2+3,$y1,"${maxgc}%",$axiscolor)
- if $bin_height > $self->font->height*2.5;
- $gd->string($self->font,$x2+3,$y2-$self->font->height,"${mingc}%",$axiscolor)
- if $bin_height > $self->font->height*2.5;
+ if $bin_height > $self->font_height*2.5;
+ $gd->string($self->font,$x2+3,$y2-$self->font_height,"${mingc}%",$axiscolor)
+ if $bin_height > $self->font_height*2.5;
# Draw the GC content graph itself
diff --git a/lib/Bio/Graphics/Glyph/dumbbell.pm b/lib/Bio/Graphics/Glyph/dumbbell.pm
index 2ec4c27..04ca758 100755
--- a/lib/Bio/Graphics/Glyph/dumbbell.pm
+++ b/lib/Bio/Graphics/Glyph/dumbbell.pm
@@ -215,14 +215,14 @@ sub draw_end_bubble
my $bubble_text = defined $self->option('bubble_text') ? $self->option('bubble_text') : "Text";
my $font = $self->option('labelfont') || $self->font;
- my $bubble_text_length = $font->width * length($bubble_text);
- my $bubble_text_x = $midX - $bubble_text_length / 2;
- my $bubble_text_y = $midY - $font->height / 2;
+ my $bubble_text_length = $self->string_width($bubble_text,$font);
+ my $bubble_text_x = $midX - $bubble_text_length/2;
+ my $bubble_text_y = $midY - $self->font_height($font)/2;
$gd->string($font, $bubble_text_x, $bubble_text_y, $bubble_text, $self->fontcolor);
my $oval_width = $bubble_text_length * 1.414;
- my $oval_height = $font->height * 1.414;
+ my $oval_height = $self->font_height($font) * 1.414;
$self->oval($gd, $midX-$oval_width/2, $midY-$oval_height/2, $midX+$oval_width/2, $midY+$oval_height/2);
@@ -325,8 +325,8 @@ sub draw_component {
{
my $font = $self->option('labelfont') || $self->font;
my $midX = ($x2-$x1-2*$shape_size)/2+$x1+$shape_size;
- my $startCaption = $midX - $font->width * length($caption) / 2;
- $gd->string($font, $startCaption, $midY-$font->height, $caption, $self->fontcolor);
+ my $startCaption = $midX - $self->string_width($caption,$font)/2;
+ $gd->string($font, $startCaption, $midY-$self->font_height($font), $caption, $self->fontcolor);
}
}
diff --git a/lib/Bio/Graphics/Glyph/gene.pm b/lib/Bio/Graphics/Glyph/gene.pm
index 8198f57..e9ef7ce 100755
--- a/lib/Bio/Graphics/Glyph/gene.pm
+++ b/lib/Bio/Graphics/Glyph/gene.pm
@@ -59,6 +59,9 @@ sub my_options {
sub extra_arrow_length {
my $self = shift;
+ return 0 if $self->feature->primary_tag =~ /exon|utr/i;
+ return $self->SUPER::extra_arrow_length
+ unless $self->feature->primary_tag =~ /gene/;
return 0 unless $self->{level} == 1;
local $self->{level} = 0; # fake out superclass
return $self->SUPER::extra_arrow_length;
@@ -67,19 +70,14 @@ sub extra_arrow_length {
sub pad_left {
my $self = shift;
my $type = $self->feature->primary_tag;
- return 0 unless $type =~ /gene|mRNA/;
+ return 0 unless $type =~ /gene|mRNA|transcript/;
$self->SUPER::pad_left;
}
sub pad_right {
my $self = shift;
return 0 unless $self->{level} < 2; # don't invoke this expensive call on exons
- my $strand = $self->feature->strand;
- $strand *= -1 if $self->{flip};
- my $pad = $self->SUPER::pad_right;
- return $pad unless defined($strand) && $strand > 0;
- my $al = $self->arrow_length;
- return $al > $pad ? $al : $pad;
+ return $self->SUPER::pad_right;
}
sub pad_bottom {
@@ -110,8 +108,8 @@ sub bump {
sub label {
my $self = shift;
return unless $self->{level} < 2;
- if ($self->label_transcripts && $self->{feature}->primary_tag =~ /RNA|pseudogene/i) {
- return $self->_label;
+ if ($self->{feature}->primary_tag =~ /rna|transcript|pseudogene/i && $self->label_transcripts) {
+ return $self->_label;
} else {
return $self->SUPER::label;
}
diff --git a/lib/Bio/Graphics/Glyph/generic.pm b/lib/Bio/Graphics/Glyph/generic.pm
index 5c9d111..3a39d6e 100755
--- a/lib/Bio/Graphics/Glyph/generic.pm
+++ b/lib/Bio/Graphics/Glyph/generic.pm
@@ -3,6 +3,9 @@ package Bio::Graphics::Glyph::generic;
use strict;
use Bio::Graphics::Util qw(frame_and_offset);
use base qw(Bio::Graphics::Glyph);
+use Memoize 'memoize';
+#memoize('pad_left');
+#memoize('pad_right');
my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',
G=>'C',A=>'T',T=>'A',C=>'G');
@@ -137,6 +140,10 @@ sub connector_color {
my $self = shift;
$self->color('connector_color') || $self->fgcolor;
}
+sub mono_font {
+ return GD->gdSmallFont;
+}
+
sub font {
my $self = shift;
return $self->getfont('font','gdSmallFont');
@@ -170,7 +177,7 @@ sub height {
$self->option('draw_translation') && $self->protein_fits
or
$self->option('draw_dna') && $self->dna_fits;
- my $fh = $self->font->height + 2;
+ my $fh = $self->font_height + 2;
return $h > $fh ? $h : $fh;
}
@@ -187,8 +194,8 @@ sub pad_bottom {
my $bottom = $self->option('pad_bottom');
return $bottom if defined $bottom;
my $pad = $self->SUPER::pad_bottom;
- $pad += $self->labelheight if $self->description;
- $pad += $self->labelheight if $self->part_labels && $self->label_position eq 'top';
+ $pad += $self->labelheight+6 if $self->description;
+ $pad += $self->labelheight+6 if $self->part_labels && $self->label_position eq 'top';
$pad;
}
sub pad_right {
@@ -205,7 +212,7 @@ sub pad_left {
my $self = shift;
my $pad = $self->SUPER::pad_left;
return $pad unless $self->label_position eq 'left' && $self->label;
- $pad += $self->labelwidth;
+ $pad += $self->labelwidth + 3;
$pad;
}
sub labelfont {
@@ -218,15 +225,15 @@ sub descfont {
}
sub labelwidth {
my $self = shift;
- return $self->{labelwidth} ||= length($self->label||'') * $self->font->width;
+ return $self->{labelwidth} ||= $self->string_width($self->label||'',$self->labelfont);
}
sub descriptionwidth {
my $self = shift;
- return $self->{descriptionwidth} ||= length($self->description||'') * $self->font->width;
+ return $self->{descriptionwidth} ||= $self->string_width($self->description||'',$self->descfont);
}
sub labelheight {
my $self = shift;
- return $self->{labelheight} ||= $self->font->height;
+ return $self->{labelheight} ||= $self->string_height($self->labelfont);
}
sub label_position {
my $self = shift;
@@ -359,7 +366,7 @@ sub draw_translation {
my $feature = $self->feature;
my $strand = $feature->strand;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $pixels_per_residue = $self->scale * 3;
my $y = $y1 + ($self->height - $font->height)/2;
@@ -410,7 +417,7 @@ sub draw_sequence {
my $feature = $self->feature;
my $strand = $feature->strand;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $pixels_per_base = $self->scale;
my $y = $y1 + ($self->height - $font->height)/2 - 1;
@@ -471,7 +478,7 @@ sub draw_label {
$self->top + $top - 1,
$label);
} elsif ($self->label_position eq 'left') {
- my $y = $self->{top} + ($self->height - $font->height)/2 + $top;
+ my $y = $self->{top} + ($self->height - $self->string_height($font))/2 + $top;
$y = $self->{top} + $top if $y < $self->{top} + $top;
$self->render_label($gd,
$font,
@@ -514,7 +521,7 @@ sub draw_description {
$gd->string($self->descfont,
$left,
- $bottom,
+ $bottom-3,
$label,
$self->descriptioncolor);
}
@@ -592,17 +599,15 @@ sub dna_fits {
my $self = shift;
my $pixels_per_base = $self->scale;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $font_width = $font->width;
-
+
return $pixels_per_base >= $font_width;
}
sub protein_fits {
my $self = shift;
- my $font = $self->font;
-
- # return unless $font->height <= $self->height;
+ my $font = $self->mono_font;
my $font_width = $font->width;
my $pixels_per_residue = $self->scale * 3;
diff --git a/lib/Bio/Graphics/Glyph/group.pm b/lib/Bio/Graphics/Glyph/group.pm
index 0fabc6c..9405333 100755
--- a/lib/Bio/Graphics/Glyph/group.pm
+++ b/lib/Bio/Graphics/Glyph/group.pm
@@ -50,7 +50,7 @@ sub labelfont {
sub pad_left {
my $self = shift;
return 0 unless $self->option('group_label');
- return length($self->label||'') * $self->labelfont->width+3;
+ return $self->string_width($self->label,$self->labelfont) +3;
}
sub draw {
@@ -76,7 +76,7 @@ sub draw_label {
$x = $panel->left + 1 if $x <= $panel->left;
$y = $self->top + $top - 1;
} elsif ($self->label_position eq 'left') {
- $y = $self->{top} + ($self->height - $font->height)/2 + $top;
+ $y = $self->{top} + ($self->height - $self->font_height($font))/2 + $top;
$y = $self->{top} + $top if $y < $self->{top} + $top;
}
$panel->add_key_box($self,$label,$x,$y);
diff --git a/lib/Bio/Graphics/Glyph/heat_map.pm b/lib/Bio/Graphics/Glyph/heat_map.pm
index 052e7dc..516a5ad 100755
--- a/lib/Bio/Graphics/Glyph/heat_map.pm
+++ b/lib/Bio/Graphics/Glyph/heat_map.pm
@@ -1,14 +1,12 @@
package Bio::Graphics::Glyph::heat_map;
use strict;
+use base qw(Bio::Graphics::Glyph::generic);
use Bio::Graphics::Glyph::minmax;
# A glyph to draw a heat map for scored features along a continuous color
# gradient calculated in HSV color space
-use vars '@ISA';
- at ISA = qw/Bio::Graphics::Glyph::minmax/;
-
sub my_description {
return <<END;
This glyph draws "scored" features using a continuous
diff --git a/lib/Bio/Graphics/Glyph/phylo_align.pm b/lib/Bio/Graphics/Glyph/phylo_align.pm
index c12f1d4..84214bb 100755
--- a/lib/Bio/Graphics/Glyph/phylo_align.pm
+++ b/lib/Bio/Graphics/Glyph/phylo_align.pm
@@ -21,7 +21,7 @@ sub description { 0 }
sub height {
my $self = shift;
- my $font = $self->font;
+ my $font = $self->mono_font;
#adjust the space to take if conservation scores are drawn instead
if (! $self->dna_fits) {
@@ -124,13 +124,11 @@ sub unknown_species {
$refspecies = $_[1];
@current_species = @{$_[2]};
@known_species = @{$_[3]};
- @unknown_species;
} else {
%alignments = $self->extract_features;
$refspecies = $self->option('reference_species');
@current_species = keys %alignments; #all species in viewing window
@known_species = $self->known_species; #all species from cladogram info
- @unknown_species; #species in GFF but not in clado
} #would have combined the two cases into one line using || but Perl will treat the arrays as num of elem
#do set subtraction to see which species in viewing range but not in tree
@@ -217,8 +215,9 @@ sub draw_clado {
my @nodes = $root->get_all_Descendents;
#draw bg for cladogram
+ my $font = $self->mono_font;
my $clado_bg = $self->color('clado_bg') || $self->bgcolor;
- my @coords = (0, $y1, $start_x+$xoffset+$self->font->width-1, $y2+1);
+ my @coords = (0, $y1, $start_x+$xoffset+$font->width-1, $y2+1);
my @coords2 = ($x1, $y1, $start_x+$xoffset/2, $y2);
if ($draw_clado_left) {
$gd->filledRectangle(@coords, $clado_bg);
@@ -381,7 +380,8 @@ sub get_legend_and_scale {
#main method that draws everything
sub draw {
my $self = shift;
- my $height = $self->font->height;
+ my $font = $self->mono_font;
+ my $height = $font->height;
my $scale = $self->scale;
my $gd = shift;
@@ -396,12 +396,12 @@ sub draw {
#spacing of either DNA alignments or score histograms in units of font height
my $species_spacing = $self->option('species_spacing') || 1;
- my $xscale = $self->font->width;
+ my $xscale = $font->width;
my $yscale = $height * $species_spacing;
my $xoffset = $x1;
- my $yoffset = $y1 + 0.5*$self->font->height;
+ my $yoffset = $y1 + 0.5*$font->height;
#method that reads the tree file to create the tree objects
my $tree = $self->set_tree;
@@ -468,14 +468,14 @@ sub draw {
$dna = $dna->seq if ref($dna) and $dna->can('seq'); # to catch Bio::PrimarySeqI objects
my $bg_color = $self->color('ref_color') || $self->bgcolor;
- $fy2 = $fy1 + $self->font->height || $y2;
+ $fy2 = $fy1 + $font->height || $y2;
$self->_draw_dna($gd,$dna,$fx1,$fy1,$fx2,$fy2, $self->fgcolor, $bg_color);
} else {
}
- my $x_label_start = $start_x + $xoffset + $self->font->width;
+ my $x_label_start = $start_x + $xoffset + $font->width;
$self->species_label($gd, $draw_clado_left, $x_label_start, $y, $species) unless ($self->option('hide_label'));
$y += $yscale;
@@ -485,7 +485,7 @@ sub draw {
#skip if the there is no alignments for this species in this window
unless ($alignments{$species}) {
- my $x_label_start = $start_x + $xoffset + $self->font->width;
+ my $x_label_start = $start_x + $xoffset + $font->width;
$self->species_label($gd, $draw_clado_left, $x_label_start, $y, $species) unless ($self->option('hide_label'));
$y += $yscale;
@@ -578,7 +578,7 @@ sub draw {
#label the species in the cladogram
- my $x_label_start = $start_x + $xoffset + $self->font->width;
+ my $x_label_start = $start_x + $xoffset + $font->width;
$self->species_label($gd, $draw_clado_left, $x_label_start, $y, $species) unless ($self->option('hide_label'));
$y += $yscale;
@@ -599,24 +599,26 @@ sub species_label {
my $y_start = shift;
my $species = shift;
+ my $font = $self->mono_font;
+
$x_start += 2;
- my $text_width = $self->font->width * length($species);
+ my $text_width = $font->width * length($species);
my $bgcolor = $self->color('bg_color');
#make label
if ($draw_clado_left) {
- $gd->filledRectangle($x_start-2, $y_start, $x_start + $text_width, $y_start+$self->font->height, $bgcolor);
- $gd->rectangle($x_start-2, $y_start, $x_start + $text_width, $y_start+$self->font->height, $self->fgcolor);
- $gd->string($self->font, $x_start, $y_start, $species, $self->fgcolor);
+ $gd->filledRectangle($x_start-2, $y_start, $x_start + $text_width, $y_start+$font->height, $bgcolor);
+ $gd->rectangle($x_start-2, $y_start, $x_start + $text_width, $y_start+$font->height, $self->fgcolor);
+ $gd->string($font, $x_start, $y_start, $species, $self->fgcolor);
} else {
my ($x_max, $y_max) = $gd->getBounds;
my $write_pos = $x_max - $x_start - $text_width;
- $gd->filledRectangle($write_pos, $y_start, $write_pos + $text_width+2, $y_start+$self->font->height, $bgcolor);
- $gd->rectangle($write_pos, $y_start, $write_pos + $text_width+2, $y_start+$self->font->height, $self->fgcolor);
- $gd->string($self->font, $write_pos+2, $y_start, $species, $self->fgcolor);
+ $gd->filledRectangle($write_pos, $y_start, $write_pos + $text_width+2, $y_start+$font->height, $bgcolor);
+ $gd->rectangle($write_pos, $y_start, $write_pos + $text_width+2, $y_start+$font->height, $self->fgcolor);
+ $gd->string($font, $write_pos+2, $y_start, $species, $self->fgcolor);
}
}
@@ -627,7 +629,7 @@ sub draw_pairwisegraph_axis {
my $self = shift;
my ($gd, $graph_legend, $x1, $x2, $y_track_top, $y_track_bottom, $draw_clado_left, @bounds) = @_;
-
+ my $font = $self->mono_font;
my $axis_color = $self->color('axis_color') || $self->fgcolor;
my $mid_axis_color = $self->color('mid_axis_color') || $axis_color;
@@ -647,15 +649,15 @@ sub draw_pairwisegraph_axis {
$coords[0] = $bounds[0] - $coords[0];
$coords[2] = $bounds[0] - $coords[2];
- my $x_text_offset = length($label) * $self->font->width;
+ my $x_text_offset = length($label) * $font->width;
- $gd->string($self->font, $coords[0]-$x_text_offset, $coords[1], $label, $self->fgcolor);
+ $gd->string($font, $coords[0]-$x_text_offset, $coords[1], $label, $self->fgcolor);
$gd->line(@coords, $self->fgcolor);
$gd->line($x2,$y_track_top,$x2,$y_track_bottom,$self->fgcolor);
} else {
#draw the legned on the left
- $gd->string($self->font, @coords[0..1], $label, $self->fgcolor);
+ $gd->string($font, @coords[0..1], $label, $self->fgcolor);
$gd->line(@coords, $self->fgcolor);
$gd->line($x1,$y_track_top,$x1,$y_track_bottom,$self->fgcolor);
@@ -942,7 +944,7 @@ sub draw_log10_rectangle {
my $graph_scale = shift;
my $zero_y = shift;
my $y1 = shift;
- my $zero_y = shift;
+ $zero_y = shift; # oy vey - this will be overwritten
my $x_left = shift;
my $x_right = shift;
my $gd = shift;
@@ -969,8 +971,9 @@ sub draw_dna {
my $fgcolor = $self->fgcolor;
my $bg_color = $self->color('targ_color') || $self->bgcolor;
my $errcolor = $self->color('errcolor') || $fgcolor;
+ my $font = $self->mono_font;
- $y2 = $y1 + $self->font->height || $y2;
+ $y2 = $y1 + $font->height || $y2;
@@ -1025,10 +1028,6 @@ sub _draw_dna {
$gd->filledRectangle($x1+1, $y1, $x2, $y2, $bg_color);
}
-
- my $feature = $self->feature;
-
-
my $strand = $feature->strand || 1;
$strand *= -1 if $self->{flip};
@@ -1039,7 +1038,7 @@ sub _draw_dna {
$color = $self->fgcolor unless $color;
$bg_color = 0 unless $bg_color;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $lineheight = $font->height;
# $y1 -= $lineheight/2 - 3; ##################NOT SURE WHY THIS WAS HERE BEFORE
my $strands = $self->option('strand') || 'auto';
diff --git a/lib/Bio/Graphics/Glyph/protein.pm b/lib/Bio/Graphics/Glyph/protein.pm
index bd3a732..1bac395 100755
--- a/lib/Bio/Graphics/Glyph/protein.pm
+++ b/lib/Bio/Graphics/Glyph/protein.pm
@@ -12,7 +12,7 @@ sub description { 0 }
sub height {
my $self = shift;
- my $font = $self->font;
+ my $font = $self->mono_font;
return $self->dna_fits ? 2 * $font->height
: $self->do_kd ? $self->SUPER::height
: 0;
@@ -53,7 +53,7 @@ sub draw_protein {
my @bases = split '', $protein;
my $color = $self->fgcolor;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $lineheight = $font->height;
$y1 -= $lineheight/2 - 3;
@@ -152,14 +152,14 @@ sub draw_kd_plot {
$gd->line($x1+5,($y2+$y1)/2,$x2-5,($y2+$y1)/2,$bgcolor);
$gd->line($x1+5,$y1, $x2-5,$y1, $bgcolor);
my $label = 'Kyte-Doolittle hydropathy plot';
- $gd->string($self->font,$x1+5,$y1,$label,$axiscolor)
- if $bin_height > $self->font->height*2 &&
- $self->width > $self->font->width*length($label);
-
- $gd->string($self->font,$x2-20,$y1,$maxkd,$axiscolor)
- if $bin_height > $self->font->height*2.5;
- $gd->string($self->font,$x2-20,$y2-$self->font->height,$minkd,$axiscolor)
- if $bin_height > $self->font->height*2.5;
+ $gd->string($self->mono_font,$x1+5,$y1,$label,$axiscolor)
+ if $bin_height > $self->mono_font->height*2 &&
+ $self->width > $self->mono_font->width*length($label);
+
+ $gd->string($self->mono_font,$x2-20,$y1,$maxkd,$axiscolor)
+ if $bin_height > $self->mono_font->height*2.5;
+ $gd->string($self->mono_font,$x2-20,$y2-$self->mono_font->height,$minkd,$axiscolor)
+ if $bin_height > $self->mono_font->height*2.5;
my $graphwidth = $x2 - $x1;
$scale = $graphwidth / (@datapoints + $kd_window - 1);
diff --git a/lib/Bio/Graphics/Glyph/ruler_arrow.pm b/lib/Bio/Graphics/Glyph/ruler_arrow.pm
index 45479f4..52b6bab 100755
--- a/lib/Bio/Graphics/Glyph/ruler_arrow.pm
+++ b/lib/Bio/Graphics/Glyph/ruler_arrow.pm
@@ -19,7 +19,7 @@ my %UNITS = (K => 1000,
sub pad_bottom {
my $self = shift;
my $val = $self->SUPER::pad_bottom(@_);
- $val += $self->font->height if $self->option('tick');
+ $val += $self->font_height if $self->option('tick');
$val;
}
@@ -89,55 +89,54 @@ sub draw_parallel {
# turn on ticks
if ($self->option('tick')) {
local $^W = 0; # dumb uninitialized variable warning
- my $font = $self->font;
- my $width = $font->width;
- my $font_color = $self->fontcolor;
- my $height = $self->height;
-
- my $relative = $self->option('relative_coords');
- my $start = $relative ? 1 : $self->feature->start;
- my $stop = $start + $self->feature->length - 1;
-
- my $offset = $relative ? $self->feature->start-1 : 0;
- my $reversed = $self->feature->strand < 0;
-
- my $units = $self->option('units') || '';
- my $divisor = $UNITS{$units} || 1 if $units;
-
- my ($major_ticks,$minor_ticks) = $self->panel->ticks($start,$stop,$font,$divisor);
-
- ## Does the user want to override the internal scale?
- my $scale = $self->option('scale');
-
- my $left = $sw ? $x1+$height : $x1;
- my $right = $ne ? $x2-$height : $x2;
-
- my $format = ($major_ticks->[1]-$major_ticks->[0])/($divisor||1) < 1 ? "%.1f$units" : "%d$units";
-
- for my $i (@$major_ticks) {
- my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
- : $self->map_pt($i + $offset));
- next if $tickpos < $left or $tickpos > $right;
- $gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
- my $label = $scale ? $i / $scale : $i;
- if ($units) {
- my $scaled = $label/$divisor;
- $label = sprintf($format,$scaled);
+ my $font = $self->font;
+ my $font_color = $self->fontcolor;
+ my $height = $self->height;
+
+ my $relative = $self->option('relative_coords');
+ my $start = $relative ? 1 : $self->feature->start;
+ my $stop = $start + $self->feature->length - 1;
+
+ my $offset = $relative ? $self->feature->start-1 : 0;
+ my $reversed = $self->feature->strand < 0;
+
+ my $units = $self->option('units') || '';
+ my $divisor = $UNITS{$units} || 1 if $units;
+
+ my ($major_ticks,$minor_ticks) = $self->panel->ticks($start,$stop,$font,$divisor);
+
+ ## Does the user want to override the internal scale?
+ my $scale = $self->option('scale');
+
+ my $left = $sw ? $x1+$height : $x1;
+ my $right = $ne ? $x2-$height : $x2;
+
+ my $format = ($major_ticks->[1]-$major_ticks->[0])/($divisor||1) < 1 ? "%.1f$units" : "%d$units";
+
+ for my $i (@$major_ticks) {
+ my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
+ : $self->map_pt($i + $offset));
+ next if $tickpos < $left or $tickpos > $right;
+ $gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
+ my $label = $scale ? $i / $scale : $i;
+ if ($units) {
+ my $scaled = $label/$divisor;
+ $label = sprintf($format,$scaled);
+ }
+ my $middle = $tickpos - $self->string_width($label)/2;
+ $gd->string($font,$middle,$center+$a2-1,$label,$font_color)
+ unless ($self->option('no_tick_label'));
}
- my $middle = $tickpos - (length($label) * $width)/2;
- $gd->string($font,$middle,$center+$a2-1,$label,$font_color)
- unless ($self->option('no_tick_label'));
- }
-
- if ($self->option('tick') >= 2) {
- my $a4 = $self->height/4;
- for my $i (@$minor_ticks) {
- my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
- : $self->map_pt($i + $offset));
- next if $tickpos < $left or $tickpos > $right;
- $gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
+
+ if ($self->option('tick') >= 2) {
+ my $a4 = $self->height/4;
+ for my $i (@$minor_ticks) {
+ my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
+ : $self->map_pt($i + $offset));
+ next if $tickpos < $left or $tickpos > $right;
+ $gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
+ }
}
- }
}
# add a label if requested
@@ -196,7 +195,7 @@ sub draw_label {
$self->top + $top,
$top_left_label,
$self->fontcolor);
- my $x1 = $left + $self->panel->right - $font->width*length($label3);
+ my $x1 = $left + $self->panel->right - $self->string_width($label3);
$gd->string($font,
$x1,
$self->top + $top,
@@ -208,7 +207,7 @@ sub draw_label {
$self->bottom - $self->pad_bottom + $top,
$label3,
$self->fontcolor);
- my $x1 = $left + $self->panel->right - $font->width*length($label5);
+ my $x1 = $left + $self->panel->right - $self->string_width($label5);
$gd->string($font,
$x1,
$self->bottom - $self->pad_bottom + $top,
diff --git a/lib/Bio/Graphics/Glyph/segments.pm b/lib/Bio/Graphics/Glyph/segments.pm
index e6eb8fa..7626fbb 100755
--- a/lib/Bio/Graphics/Glyph/segments.pm
+++ b/lib/Bio/Graphics/Glyph/segments.pm
@@ -174,7 +174,7 @@ sub pad_right {
sub labelwidth {
my $self = shift;
return $self->SUPER::labelwidth unless $self->draw_target && $self->dna_fits && $self->label_position eq 'left';
- return $self->{labelwidth} ||= (length($self->label||'')+1) * $self->font->width;
+ return $self->{labelwidth} ||= (length($self->label||'')+1) * $self->mono_font->width;
}
sub draw_target {
my $self = shift;
@@ -199,7 +199,7 @@ sub height {
if ($self->draw_protein_target) {
return $height unless $self->protein_fits;
}
- my $fontheight = $self->font->height;
+ my $fontheight = $self->mono_font->height;
return $fontheight if $fontheight > $height;
}
@@ -705,7 +705,7 @@ sub draw_multiple_alignment {
my ($red,$green,$blue) = $self->panel->rgb($bgcolor);
my $avg = ($red+$green+$blue)/3;
my $color = $self->translate_color($avg > 128 ? 'black' : 'white');
- my $font = $self->font;
+ my $font = $self->mono_font;
my $lineheight = $font->height;
my $fontwidth = $font->width;
@@ -927,10 +927,18 @@ sub _get_cigar {
return unless $cigar;
my @arry;
- while ($cigar =~ /(\d*)([A-Z])/g) {
- my ($count,$op) = ($1,$2);
- $count ||= 1;
- push @arry,[$op,$count];
+ my $regexp = $cigar =~ /^\d+/ ? '(\d+)([A-Z])'
+ : '([A-Z])(\d+)';
+ if ($cigar =~ /^\d+/) {
+ while ($cigar =~ /(\d+)([A-Z])/g) {
+ my ($count,$op) = ($1,$2);
+ push @arry,[$op,$count];
+ }
+ } else {
+ while ($cigar =~ /([A-Z])(\d+)/g) {
+ my ($op,$count) = ($1,$2);
+ push @arry,[$op,$count];
+ }
}
return \@arry;
}
diff --git a/lib/Bio/Graphics/Glyph/text_in_box.pm b/lib/Bio/Graphics/Glyph/text_in_box.pm
index 272967f..1e7b5b9 100755
--- a/lib/Bio/Graphics/Glyph/text_in_box.pm
+++ b/lib/Bio/Graphics/Glyph/text_in_box.pm
@@ -25,8 +25,8 @@ sub draw_component {
my $text = defined $self->option('text') ? $self->option('text') : $self->default_text();
my $text_pad = defined $self->option('text_pad') ? $self->option('text_pad') : $self->default_text_pad();
- my $width = $font->width * length $text;
- my $height = $font->height;
+ my $width = $self->string_width($text);
+ my $height = $self->font_height;
my $midY = ($y2+$y1) / 2;
diff --git a/lib/Bio/Graphics/Glyph/trace.pm b/lib/Bio/Graphics/Glyph/trace.pm
index e2b96ff..6d77269 100755
--- a/lib/Bio/Graphics/Glyph/trace.pm
+++ b/lib/Bio/Graphics/Glyph/trace.pm
@@ -388,7 +388,7 @@ sub draw_component {
}
# Get Text Info
- my $font = $self->font;
+ my $font = $self->mono_font;
my $text_buffer = 2;
my $text_height = $font->height + ( $text_buffer * 2 );
diff --git a/lib/Bio/Graphics/Glyph/track.pm b/lib/Bio/Graphics/Glyph/track.pm
index 508df42..fd61642 100755
--- a/lib/Bio/Graphics/Glyph/track.pm
+++ b/lib/Bio/Graphics/Glyph/track.pm
@@ -51,7 +51,7 @@ sub draw {
local $Bio::Graphics::Panel::GlyphScratch; # set $GlyphScratch to undef
for (my $i=0; $i<@parts; $i++) {
$parts[$i]->draw_highlight($gd,$left,$top);
- $parts[$i]->draw($gd,$left,$top,0,1);
+ $parts[$i]->draw_it($gd,$left,$top,0,1);
}
$gd->clip(@clip) if @clip;
diff --git a/lib/Bio/Graphics/Glyph/transcript2.pm b/lib/Bio/Graphics/Glyph/transcript2.pm
index 9151f14..16898e7 100755
--- a/lib/Bio/Graphics/Glyph/transcript2.pm
+++ b/lib/Bio/Graphics/Glyph/transcript2.pm
@@ -16,8 +16,9 @@ sub extra_arrow_length {
my $self = shift;
my $strand = $self->feature->strand || 0;
$strand *= -1 if $self->{flip};
- return 0 unless $strand < 0;
- my $first = ($self->parts)[0] || $self;
+ my $first = $strand < 0 ? ($self->parts)[0]
+ : ($self->parts)[-1];
+ $first ||= $self;
my @rect = $first->bounds();
my $width = abs($rect[2] - $rect[0]);
return 0 if $width >= MIN_WIDTH_FOR_ARROW;
@@ -27,6 +28,7 @@ sub extra_arrow_length {
sub pad_left {
my $self = shift;
my $pad = $self->Bio::Graphics::Glyph::generic::pad_left;
+ return $pad if $self->feature->strand > 0;
my $extra_arrow_length = $self->extra_arrow_length;
if ($self->label_position eq 'left' && $self->label) {
return $extra_arrow_length+$pad;
@@ -38,12 +40,9 @@ sub pad_left {
sub pad_right {
my $self = shift;
my $pad = $self->Bio::Graphics::Glyph::generic::pad_right;
- return $pad if $self->{level} > 0;
- my $last = ($self->parts)[-1] || $self;
- my @rect = $last->bounds();
- my $width = abs($rect[2] - $rect[0]);
- return $self->SUPER::pad_right if $width < MIN_WIDTH_FOR_ARROW;
- return $pad
+ return $pad if $self->feature->strand < 0;
+ my $extra_arrow_length = $self->extra_arrow_length;
+ return $extra_arrow_length > $pad ? $extra_arrow_length : $pad;
}
sub draw_connectors {
diff --git a/lib/Bio/Graphics/Glyph/translation.pm b/lib/Bio/Graphics/Glyph/translation.pm
index 357038b..fa1e42f 100755
--- a/lib/Bio/Graphics/Glyph/translation.pm
+++ b/lib/Bio/Graphics/Glyph/translation.pm
@@ -26,7 +26,7 @@ sub default_color {
sub height {
my $self = shift;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $lines = $self->translation_type eq '3frame' ? 3
: $self->translation_type eq '6frame' ? 6
: 1;
@@ -69,7 +69,7 @@ sub longprotein_fits {
return unless $self->show_sequence;
my $pixels_per_residue = $self->pixels_per_residue;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $font_width = $font->width * 4; # not 3; leave room for whitespace
return $pixels_per_residue >= $font_width;
@@ -175,7 +175,7 @@ sub draw_frame {
my $awo = 0;
if ($self->protein_fits) {
$self->draw_protein(\$protein,$strand,$color,$gd,$x1,$y1,$x2,$y2);
- $awo += $self->font->height/2;
+ $awo += $self->mono_font->height/2;
} else {
$self->draw_orfs(\$protein,$strand,$color,$gd,$x1,$y1,$x2,$y2);
}
@@ -189,7 +189,7 @@ sub draw_protein {
my $self = shift;
my ($protein,$strand,$color,$gd,$x1,$y1,$x2,$y2) = @_;
my $pixels_per_base = $self->pixels_per_base;
- my $font = $self->font;
+ my $font = $self->mono_font;
my $flip = $self->{flip};
my $left = $self->panel->left;
my $right = $self->panel->right;
diff --git a/lib/Bio/Graphics/Glyph/wiggle_data.pm b/lib/Bio/Graphics/Glyph/wiggle_data.pm
index 7ee2103..f9707ee 100755
--- a/lib/Bio/Graphics/Glyph/wiggle_data.pm
+++ b/lib/Bio/Graphics/Glyph/wiggle_data.pm
@@ -155,6 +155,7 @@ sub wig {
sub datatype {
my $self = shift;
my $feature = $self->feature;
+ warn $feature->display_name;
my ($tag,$value);
for my $t ('wigfile','wigdata','densefile','coverage') {
if (my ($v) = eval{$feature->get_tag_values($t)}) {
@@ -166,6 +167,7 @@ sub datatype {
unless ($value) {
$tag = 'statistical_summary';
$value = eval{$feature->statistical_summary};
+ $value or warn "track data object '",ref($feature),"' does not support statistical_summary() method; please add wigfile,wigdata,densefile or coverage attribute to data file";
}
$tag ||= 'generic';
return wantarray ? ($tag,$value) : $tag;
diff --git a/lib/Bio/Graphics/Glyph/wiggle_xyplot.pm b/lib/Bio/Graphics/Glyph/wiggle_xyplot.pm
index 37c2d42..9ed0e29 100755
--- a/lib/Bio/Graphics/Glyph/wiggle_xyplot.pm
+++ b/lib/Bio/Graphics/Glyph/wiggle_xyplot.pm
@@ -298,11 +298,11 @@ sub draw_plot {
my $side = $self->_determine_side();
my $fcolor=$self->panel->translate_color('grey:0.50');
my $font = $self->font('gdTinyFont');
- my $x1 = $left - length('+2sd') * $font->width - ($side=~/left|three/ ? 15 : 0);
- my $x2 = $left - length('mn') * $font->width - ($side=~/left|three/ ? 15 : 0);
- $gd->string($font,$x1,$yy1-$font->height/2,'+2sd',$fcolor) unless $clip_top;
- $gd->string($font,$x1,$yy2-$font->height/2,'-2sd',$fcolor) unless $clip_bottom;
- $gd->string($font,$x2,$y -$font->height/2,'mn', $fcolor);
+ my $x1 = $left - $self->string_width('+2sd',$font) - ($side=~/left|three/ ? 15 : 0);
+ my $x2 = $left - $self->string_width('mn',$font) - ($side=~/left|three/ ? 15 : 0);
+ $gd->string($font,$x1,$yy1-$self->string_height('+2sd',$font),'+2sd',$fcolor) unless $clip_top;
+ $gd->string($font,$x1,$yy2-$self->string_height('-2sd')/2,'-2sd',$fcolor) unless $clip_bottom;
+ $gd->string($font,$x2,$y - $self->string_height('mn',$font),'mn', $fcolor);
}
$self->panel->endGroup($gd);
diff --git a/lib/Bio/Graphics/Glyph/xyplot.pm b/lib/Bio/Graphics/Glyph/xyplot.pm
index 212dca4..754461b 100755
--- a/lib/Bio/Graphics/Glyph/xyplot.pm
+++ b/lib/Bio/Graphics/Glyph/xyplot.pm
@@ -107,8 +107,8 @@ sub point_radius {
sub pad_top {
my $self = shift;
my $pad = $self->Bio::Graphics::Glyph::generic::pad_top(@_);
- if ($pad < ($self->font('gdTinyFont')->height+8)) {
- $pad = $self->font('gdTinyFont')->height+8; # extra room for the scale
+ if ($pad < $self->font_height($self->getfont('gdTinyFont'))+8) {
+ $pad = $self->font_height($self->getfont('gdTinyFont'))+8; # extra room for the scale
}
$pad;
}
@@ -116,8 +116,8 @@ sub pad_top {
sub pad_bottom {
my $self = shift;
my $pad = $self->Bio::Graphics::Glyph::generic::pad_bottom(@_);
- if ($pad < ($self->font('gdTinyFont')->height)/4) {
- $pad = ($self->font('gdTinyFont')->height)/4; # extra room for the scale
+ if ($pad < $self->font_height($self->getfont('gdTinyFont'))/4) {
+ $pad = $self->font_height($self->getfont('gdTinyFont'))/4; # extra room for the scale
}
$pad;
}
@@ -441,15 +441,6 @@ sub _draw_scale {
my $gc = $self->translate_color($p->gridcolor);
my $mgc= $self->translate_color($p->gridmajorcolor);
- # if ($side ne 'none') {
- # for (my $y = $y2-$y_scale; $y > $y1; $y -= $y_scale) {
- # my $yr = int($y+0.5);
- # $gd->line($x1-1,$yr,$x2,$yr,$gc);
- # }
- # $gd->line($x1,$y1,$x2,$y1,$gc);
- # $gd->line($x1,$y2,$x2,$y2,$gc);
- # }
-
$gd->line($x1,$y1,$x1,$y2,$fg) if $side eq 'left' || $side eq 'both' || $side eq 'three';
$gd->line($x2,$y1,$x2,$y2,$fg) if $side eq 'right' || $side eq 'both' || $side eq 'three';
$gd->line($middle,$y1,$middle,$y2,$fg) if $side eq 'three';
@@ -466,13 +457,13 @@ sub _draw_scale {
$gd->line($x2,$_->[0],$x2+3,$_->[0],$fg) if $side eq 'right' || $side eq 'both' || $side eq 'three';
$gd->line($middle,$_->[0],$middle+3,$_->[0],$fg) if $side eq 'three';
- my $font_pos = $_->[0]-($font->height/2);
+ my $font_pos = $_->[0]-($self->font_height($font)/2);
$font_pos-=2 if $_->[1] < 0; # jog a little bit for neg sign
- next unless $font_pos > $last_font_pos + $font->height/2; # prevent labels from clashing
+ next unless $font_pos > $last_font_pos + $self->font_height($font)/2; # prevent labels from clashing
if ($side eq 'left' or $side eq 'both' or $side eq 'three') {
$gd->string($font,
- $x1 - $font->width * length($_->[1]) - 3,$font_pos,
+ $x1 - $self->string_width($_->[1],$font) - 3,$font_pos,
$_->[1],
$fg);
}
@@ -482,7 +473,6 @@ sub _draw_scale {
$_->[1],
$fg);
}
-# if ($side eq 'three' && $_->[1] != 0) {
if ($side eq 'three') {
$gd->string($font,
$middle + 5,$font_pos,
@@ -649,9 +639,10 @@ sub draw_label {
$x += ($self->panel->glyph_scratch||0);
my $font = $self->labelfont;
- my $width = $font->width*(length($label)+4);
+ my $width = $self->string_width($label,$font)+4;
+ my $height= $self->string_height('',$font);
unless ($self->record_label_positions) {
- $gd->filledRectangle($x,$top,$x+$width+6,$top+$font->height,$self->bgcolor);
+ $gd->filledRectangle($x,$top,$x+$width+6,$top+$height,$self->bgcolor);
local $self->{default_opacity} = 1;
$gd->string($font,$x+3,$top,$label,$self->contrasting_label_color($gd,$self->bgcolor));
}
@@ -660,7 +651,7 @@ sub draw_label {
} elsif ($self->label_position eq 'left') {
my $font = $self->labelfont;
- my $x = $self->left + $left - $font->width*length($label) - $self->extra_label_pad;
+ my $x = $self->left + $left - $self->string_width($label,$font) - $self->extra_label_pad;
my $y = $self->{top} + $top;
$self->render_label($gd,
@@ -694,7 +685,7 @@ sub draw_legend {
my $label = "<a id=\"legend_$name\" target=\"_blank\" href=\"#\"> <font color=\'$color\';\">" . $name . "</font></a>" or return;
my $font = $self->labelfont;
- my $x = $self->left + $left - $font->width*length($label) - $self->extra_label_pad;
+ my $x = $self->left + $left - $self->string_width($label,$font) - $self->extra_label_pad;
my $y = $self->{top} + $top;
my $is_legend = 1;
$self->render_label($gd,
diff --git a/lib/Bio/Graphics/Panel.pm b/lib/Bio/Graphics/Panel.pm
index 895cc9c..bab836f 100755
--- a/lib/Bio/Graphics/Panel.pm
+++ b/lib/Bio/Graphics/Panel.pm
@@ -3,6 +3,7 @@ package Bio::Graphics::Panel;
use strict;
use Bio::Graphics::Glyph::Factory;
use Bio::Graphics::Feature;
+use Bio::Graphics::GDWrapper;
# KEYLABELFONT must be treated as string until image_class is established
use constant KEYLABELFONT => 'gdMediumBoldFont';
@@ -53,6 +54,7 @@ sub new {
my $empty_track_style = $options{-empty_tracks} || 'key';
my $autopad = defined $options{-auto_pad} ? $options{-auto_pad} : 1;
my $truecolor = $options{-truecolor} || 0;
+ my $truetype = $options{-truetype} || 0;
my $image_class = ($options{-image_class} && $options{-image_class} =~ /SVG/)
? 'GD::SVG'
: $options{-image_class} || 'GD'; # Allow users to specify GD::SVG using SVG
@@ -104,6 +106,7 @@ sub new {
autopad => $autopad,
all_callbacks => $allcallbacks,
truecolor => $truecolor,
+ truetype => $truetype,
flip => $flip,
linkrule => $linkrule,
titlerule => $titlerule,
@@ -160,6 +163,12 @@ sub flip {
$self->{flip} = shift if @_;
$g;
}
+sub truetype {
+ my $self = shift;
+ my $g = $self->{truetype};
+ $self->{truetype} = shift if @_;
+ $g;
+}
# values of empty_track_style are:
# "suppress" -- suppress empty tracks entirely (default)
@@ -511,6 +520,8 @@ sub gd {
my $gd = $existing_gd || $pkg->new($width,$height,
($self->{truecolor} && $pkg->can('isTrueColor') ? 1 : ())
);
+ $gd->{debug} = 0 if $gd->isa('GD::SVG::Image'); # hack
+ $self->{gd} = $gd;
if ($self->{truecolor}
&& $pkg->can('saveAlpha')) {
@@ -525,7 +536,9 @@ sub gd {
}
$self->{translations} = \%translation_table;
- $self->{gd} = $gd;
+ $self->{gd} = $gd->isa('GD::SVG::Image') ? $gd
+ : $self->truetype ? Bio::Graphics::GDWrapper->new($gd,$self->truetype)
+ : $gd;
eval {$gd->alphaBlending(0)};
if ($self->bgcolor) {
@@ -607,6 +620,50 @@ sub gd {
return $self->{gd} = $self->rotate ? $gd->copyRotate90 : $gd;
}
+sub gdfont {
+ my $self = shift;
+ my $font = shift;
+ my $img_class = $self->image_class;
+
+ if (!UNIVERSAL::isa($font,$img_class . '::Font') && $font =~ /^(gd|sanserif)/) {
+ my $ref = $self->{gdfonts} ||= {
+ gdTinyFont => $img_class->gdTinyFont(),
+ gdSmallFont => $img_class->gdSmallFont(),
+ gdMediumBoldFont => $img_class->gdMediumBoldFont(),
+ gdLargeFont => $img_class->gdLargeFont(),
+ gdGiantFont => $img_class->gdGiantFont(),
+ sanserif => $img_class->gdSmallFont(),
+ };
+ return $ref->{$font} || $ref->{gdSmallFont};
+ } else {
+ return $font;
+ }
+}
+
+sub string_width {
+ my $self = shift;
+ my ($font,$string) = @_;
+
+ my $class = $self->image_class;
+
+ return $font->width*CORE::length($string)
+ unless $self->truetype && $class ne 'GD::SVG';
+ return Bio::Graphics::GDWrapper->string_width($font,$string);
+}
+
+sub string_height {
+ my $self = shift;
+ my ($font,$string) = @_;
+
+ my $class = $self->image_class;
+
+ return $font->height
+ unless $self->truetype
+ && eval{$class eq 'GD' || $class->isa('GD::Image')};
+
+ return Bio::Graphics::GDWrapper->string_height($font,$string);
+}
+
sub startGroup {
my $self = shift;
my $gd = shift;
@@ -1701,6 +1758,9 @@ a set of tag/value pairs as follows:
Useful when working with the
"image" glyph.
+ -truetype Render text using scaleable vector false
+ fonts rather than bitmap fonts.
+
-image_class To create output in scalable vector
graphics (SVG), optionally pass the image
class parameter 'GD::SVG'. Defaults to
@@ -1763,6 +1823,15 @@ indicate a "gap" in the sequence:
$gd->filledRectangle($gap_start,$top,$gap_end,$bottom,$gray);
}
+The B<-truetype> argument will activate rendering of labels using
+antialiased vector fonts. If it is a value of "1", then labels will be
+rendered using the default font (Verdana). Pass a font name to use
+this font as the default:
+
+ -truetype => 'Times New Roman',
+
+Note that you can change the font on a track-by-track basis simply by
+using a truetype font name as add_track()'s -font argument.
=back
@@ -1793,7 +1862,6 @@ arguments is irrelevant, allowing either of these idioms:
$panel->add_track(arrow => \@features);
$panel->add_track(\@features => 'arrow');
-
The glyph name indicates how each feature is to be rendered. A
variety of glyphs are available, and the number is growing. You may
omit the glyph name entirely by providing a B<-glyph> argument among
@@ -2275,6 +2343,19 @@ ignored.
B<Track color:> The -tkcolor option used to specify the background of
the entire track.
+B<Font:> The -font option controls which font will be used. If the
+Panel was created without passing a true value to -truecolor, then
+only GD bitmapped fonts are available to you. These include
+'gdTinyFont', 'gdSmallFont', 'gdLargeFont', 'gdMediumBoldFont', and
+'gdGiantFont'. If the Panel was creaed using a truevalue for
+-truecolor, then you can pass the name of any truetype font installed
+on the server system. Any of these formats will work:
+
+ -font => 'Times New Roman', # Times font, let the system pick size
+ -font => 'Times New Roman-12' # Times font, 12 points
+ -font => 'Times New Roman-12:Italic' # Times font, 12 points italic
+ -font => 'Times New Roman-12:Bold' # Times font, 12 points bold
+
B<Font color:> The -fontcolor option controls the color of primary
text, such as labels
diff --git a/t/data/decorated_transcript_t1.gff b/t/data/decorated_transcript_t1.gff
new file mode 100644
index 0000000..72d2968
--- /dev/null
+++ b/t/data/decorated_transcript_t1.gff
@@ -0,0 +1,22 @@
+##gff-version 3
+##feature-ontology so.obo
+##attribute-ontology gff3_attributes.obo
+##sequence-region MAL1 1 643292
+MAL1 PlasmoDB_70 supercontig 1 643292 . + . ID=MAL1;Name=MAL1;size=643292;molecule_type=dsDNA;organism_name=Plasmodium falciparum
+
+MAL1 PlasmoDB_70 gene 549319 550102 . - . ID=PFA0680c;Name=PFA0680c;Note=Pfmc-2TM+Maurer%27s+cleft+two+transmembrane+protein
+MAL1 PlasmoDB_70 mRNA 549319 550102 . - . ID=rna_PFA0680c-1;Name=isoform1;protein_decorations=TMHMM:TM:157:179:5,TMHMM:TM:184:203:10,SignalP4:SP:1:25:0.444,exportpred:VTS:42:48:7.50725;Parent=PFA0680c
+MAL1 PlasmoDB_70 CDS 550034 550102 . - 0 ID=cds_PFA0680c-1-1;Name=cds_PFA0680c-1-1;Parent=rna_PFA0680c-1
+MAL1 PlasmoDB_70 CDS 549319 549939 . - 0 ID=cds_PFA0680c-1-2;Name=cds_PFA0680c-2-2;Parent=rna_PFA0680c-1
+MAL1 PlasmoDB_70 mRNA 549500 550102 . - . ID=rna_PFA0680c-2;Name=isoform2;protein_decorations=SignalP4:SP:1:25:0.444,exportpred:VTS:42:48:7.50725;Parent=PFA0680c
+MAL1 PlasmoDB_70 CDS 550034 550102 . - 0 ID=cds_PFA0680c-2-1;Name=cds_PFA0680c-2-1;Parent=rna_PFA0680c-2
+MAL1 PlasmoDB_70 CDS 549500 549939 . - 0 ID=cds_PFA0680c-2-2;Name=cds_PFA0680c-2-2;Parent=rna_PFA0680c-2
+
+MAL1 PlasmoDB_70 gene 549319 549619 . + . ID=test1;Name=test1;Note=My+test+transcript
+MAL1 PlasmoDB_70 mRNA 549319 549619 . + . ID=rna_test1-1;Name=rna_test1-1;protein_decorations=SignalP:SP:1:10:1.0,method1:very interesting region:30:80:0.88;Parent=test1
+MAL1 PlasmoDB_70 CDS 549319 549619 . + 0 ID=cds_test1-1;Parent=rna_test1-1
+
+MAL1 PlasmoDB_70 gene 549319 549619 . - . ID=PVX_000640;Name=PVX_000640;Note=Highlight starts with CDS and skips UTR
+MAL1 PlasmoDB_70 mRNA 549319 549619 . - . ID=rna_PVX_000640-1;Name=PVX_000640-1;Parent=PVX_000640;protein_decorations=PfamA25:Ribosomal_S12:1:20:5.2e-43
+MAL1 PlasmoDB_70 UTR 549589 549619 . - 0 ID=utr_PVX_000640-1;Name=utr_PVX_000640-1;Parent=rna_PVX_000640-1
+MAL1 PlasmoDB_70 CDS 549319 549588 . - 0 ID=cds_PVX_000640-1;Name=cds_PVX_000640-1;Parent=rna_PVX_000640-1
diff --git a/t/data/decorated_transcript_t1.png b/t/data/decorated_transcript_t1.png
new file mode 100644
index 0000000..86d3598
Binary files /dev/null and b/t/data/decorated_transcript_t1.png differ
diff --git a/t/data/t1.gif b/t/data/t1.gif
new file mode 100644
index 0000000..691f946
Binary files /dev/null and b/t/data/t1.gif differ
diff --git a/t/data/t1.png b/t/data/t1.png
new file mode 100644
index 0000000..696e7fc
Binary files /dev/null and b/t/data/t1.png differ
diff --git a/t/data/t1/version13.gif b/t/data/t1/version14.gif
similarity index 100%
copy from t/data/t1/version13.gif
copy to t/data/t1/version14.gif
diff --git a/t/data/t1/version13.png b/t/data/t1/version14.png
similarity index 100%
copy from t/data/t1/version13.png
copy to t/data/t1/version14.png
diff --git a/t/data/t2.gif b/t/data/t2.gif
new file mode 100644
index 0000000..a025dd4
Binary files /dev/null and b/t/data/t2.gif differ
diff --git a/t/data/t2.png b/t/data/t2.png
new file mode 100644
index 0000000..7d6c1ff
Binary files /dev/null and b/t/data/t2.png differ
diff --git a/t/data/t2/version19.gif b/t/data/t2/version20.gif
similarity index 58%
copy from t/data/t2/version19.gif
copy to t/data/t2/version20.gif
index f58d118..596bf8f 100644
Binary files a/t/data/t2/version19.gif and b/t/data/t2/version20.gif differ
diff --git a/t/data/t2/version19.png b/t/data/t2/version20.png
similarity index 59%
copy from t/data/t2/version19.png
copy to t/data/t2/version20.png
index cc7a5f1..69541cf 100644
Binary files a/t/data/t2/version19.png and b/t/data/t2/version20.png differ
diff --git a/t/data/t3.gif b/t/data/t3.gif
new file mode 100644
index 0000000..2a2db4b
Binary files /dev/null and b/t/data/t3.gif differ
diff --git a/t/data/t3.png b/t/data/t3.png
new file mode 100644
index 0000000..540f250
Binary files /dev/null and b/t/data/t3.png differ
diff --git a/t/data/t3/version14.gif b/t/data/t3/version15.gif
similarity index 55%
copy from t/data/t3/version14.gif
copy to t/data/t3/version15.gif
index 9644e6c..fd4de8a 100644
Binary files a/t/data/t3/version14.gif and b/t/data/t3/version15.gif differ
diff --git a/t/data/t3/version15.png b/t/data/t3/version15.png
new file mode 100644
index 0000000..26a19d6
Binary files /dev/null and b/t/data/t3/version15.png differ
diff --git a/t/decorated_transcript_t1.pl b/t/decorated_transcript_t1.pl
new file mode 100644
index 0000000..4783b3e
--- /dev/null
+++ b/t/decorated_transcript_t1.pl
@@ -0,0 +1,144 @@
+#!/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";
--
Generate GD images of Bio::Seq objects.
More information about the debian-med-commit
mailing list