[med-svn] [SCM] libbio-graphics-perl branch, master, updated. debian/2.33-1
Charles Plessy
plessy at debian.org
Sun May 5 14:26:49 UTC 2013
The following commit has been merged in the master branch:
commit befc3bc0643e43e426d9529b830a4bdf11a65544
Author: Charles Plessy <plessy at debian.org>
Date: Sun May 5 21:16:42 2013 +0900
Imported Upstream version 2.33
diff --git a/Changes b/Changes
index 2820f15..1c4b45e 100755
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
Revision history for Perl extension Bio::Graphics.
+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.
diff --git a/MANIFEST b/MANIFEST
index 98a2bb5..757f981 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
@@ -127,6 +128,8 @@ scripts/render_msa.pl
scripts/search_overview.pl
t/BioGraphics.t
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 +139,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 +152,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 +173,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 +183,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 +197,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
diff --git a/META.json b/META.json
index efc64b6..212de8c 100644
--- a/META.json
+++ b/META.json
@@ -4,7 +4,7 @@
"Lincoln Stein <lincoln.stein at oicr.on.ca>"
],
"dynamic_config" : 1,
- "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.110440",
+ "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.112150",
"license" : [
"perl_5"
],
@@ -35,7 +35,7 @@
"provides" : {
"Bio::Graphics" : {
"file" : "lib/Bio/Graphics.pm",
- "version" : "2.32"
+ "version" : "2.33"
},
"Bio::Graphics::ConfiguratorI" : {
"file" : "lib/Bio/Graphics/ConfiguratorI.pm",
@@ -69,6 +69,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
@@ -472,5 +476,5 @@
"http://dev.perl.org/licenses/"
]
},
- "version" : "2.32"
+ "version" : "2.33"
}
diff --git a/META.yml b/META.yml
index 8782fd7..eb14f35 100644
--- a/META.yml
+++ b/META.yml
@@ -6,7 +6,7 @@ build_requires: {}
configure_requires:
Module::Build: 0.38
dynamic_config: 1
-generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.110440'
+generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.112150'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -15,7 +15,7 @@ name: Bio-Graphics
provides:
Bio::Graphics:
file: lib/Bio/Graphics.pm
- version: 2.32
+ version: 2.33
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
@@ -347,4 +350,4 @@ requires:
Statistics::Descriptive: 2.6
resources:
license: http://dev.perl.org/licenses/
-version: 2.32
+version: 2.33
diff --git a/lib/Bio/Graphics.pm b/lib/Bio/Graphics.pm
index d1e4055..aa3c886 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.33';
1;
diff --git a/lib/Bio/Graphics/GDWrapper.pm b/lib/Bio/Graphics/GDWrapper.pm
new file mode 100644
index 0000000..4a09dbe
--- /dev/null
+++ b/lib/Bio/Graphics/GDWrapper.pm
@@ -0,0 +1,87 @@
+package Bio::Graphics::GDWrapper;
+
+use base 'GD::Image';
+use Memoize 'memoize';
+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');
+ $GdInit++ || GD::Image->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..16af62c 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];
- }
-
- return wantarray ? @result : \@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];
+ }
+
+ pop @FEATURE_STACK;
+ 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;
- foreach (@parts) {
- my $pr = $_->pad_right;
- $max = $pr if $max < $pr;
- }
- $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;
+ 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;
+ }
-# 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
@@ -764,7 +782,7 @@ sub getfont {
my $img_class = $self->image_class;
- unless (UNIVERSAL::isa($font,$img_class . '::Font')) {
+ if (!UNIVERSAL::isa($font,$img_class . '::Font') && $font =~ /^(gd|sanserif)/) {
my $ref = {
gdTinyFont => $img_class->gdTinyFont(),
gdSmallFont => $img_class->gdSmallFont(),
@@ -848,6 +866,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 +1047,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 +1063,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;
@@ -1083,9 +1107,6 @@ sub draw {
}
$self->panel->endGroup($gd);
-
- pop @FEATURE_STACK;
-
}
sub connector { return }
@@ -1110,6 +1131,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 +1489,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 +1867,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/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/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..3e293f9 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;
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_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..99829cb 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('gdTinyFont')+8) {
+ $pad = $self->font_height('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('gdTinyFont')/4) {
+ $pad = $self->font_height('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..48e5789 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,7 @@ sub gd {
my $gd = $existing_gd || $pkg->new($width,$height,
($self->{truecolor} && $pkg->can('isTrueColor') ? 1 : ())
);
+ $self->{gd} = $gd;
if ($self->{truecolor}
&& $pkg->can('saveAlpha')) {
@@ -525,7 +535,9 @@ sub gd {
}
$self->{translations} = \%translation_table;
- $self->{gd} = $gd;
+ $self->{gd} = $gd->isa('GD::SVG') ? $gd
+ : $self->truetype ? Bio::Graphics::GDWrapper->new($gd,$self->truetype)
+ : $gd;
eval {$gd->alphaBlending(0)};
if ($self->bgcolor) {
@@ -607,6 +619,30 @@ sub gd {
return $self->{gd} = $self->rotate ? $gd->copyRotate90 : $gd;
}
+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 +1737,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 +1802,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 +1841,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 +2322,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/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
--
Generate GD images of Bio::Seq objects.
More information about the debian-med-commit
mailing list