package Bio::Graphics::Glyph::image;
use strict;
use GD;
use base 'Bio::Graphics::Glyph::generic';
our @ISA;
#
# |--------------------| true position ('height' high)
# . .
# . . diagonal (vertical spacing high)
# . .
# +--------------------------+
# | |
# | |
# | | image
# | |
# | |
# | |
# +--------------------------+
use constant VERTICAL_SPACING => 20;
sub my_description {
return <<END;
This glyph inserts an image into the track at the indicated feature
coordinates. The image can be in PNG, JPEG, GIF or GD format, and can
be either 8-bit or 24-bit ("truecolor"). The image can be located on
the local filesystem or located at a remote URL (provided that you
have the LWP module installed).
When working with photographic images, you may wish to have
Bio::Graphics::Panel create 24-bit (truecolor) images in order to
avoid running out of colors. The symptom of this is that images appear
posterized. To turn on truecolor images, pass the -truecolor option to
Bio::Graphics::Panel.
END
}
sub my_options {
{
image => [
'string',
undef,
'Specify the image path or URL to use for the feature.',
'If no image option is specified, then the glyph will look',
'inside the feature itself for an image path or URL in a tag named "image"',
],
image_prefix => [
'string',
undef,
'A string to prepend to each image path.',
'You may use this to prepend a directory path or a partial URL.'],
vertical_spacing => [
'integer',
20,
'Vertical distance from the box that shows the physical span of the',
'feature to the top of the picture, in pixels.'],
glyph_delegate => [
'string',
'generic',
'The glyph to use for the part of the glyph that shows the physical',
'span of features.']
}
}
sub demo_feature {
my $self = shift;
my $ex_image =
'http://www.catch-fly.com/sites/awhittington/_files/Image/Drosophila-melanogaster.jpg';
return Bio::Graphics::Feature->new(-start=>1,
-end=>500,
-name=>$ex_image,
-attributes => {
image=>$ex_image,
},
);
}
sub new {
my $self = shift->SUPER::new(@_);
$self->{image} = $self->get_image();
return $self;
}
sub get_image {
my $self = shift;
my ($format,$image) = eval { $self->image_data };
unless ($image) {
warn $@ if $@;
return;
}
my $gd = $format eq 'image/png' ? GD::Image->newFromPngData($image,1)
: $format eq 'image/jpeg' ? GD::Image->newFromJpegData($image,1)
: $format eq 'image/gif' ? GD::Image->newFromGifData($image)
: $format eq 'image/gd' ? GD::Image->newFromGdData($image)
: $format eq 'image/gd2' ? GD::Image->newFromGd2Data($image)
: $self->throw("This module cannot handle images of type $format");
return $gd;
}
sub _guess_format {
my $self = shift;
my $path = shift;
return 'image/png' if $path =~ /\.png$/i;
return 'image/jpeg' if $path =~ /\.jpe?g$/i;
return 'image/gif' if $path =~ /\.gif(87)?$/i;
return 'image/gd' if $path =~ /\.gd$/i;
return 'image/gd2' if $path =~ /\.gd2$/i;
my ($extension) = $path =~ /\.(\w+)$/; #cop-out
return $extension;
}
sub image_path {
my $self = shift;
my $feature = $self->feature or $self->throw("no feature!");
my $dirname = $self->image_dir;
my $basename = $self->option('image');
# can't get it from callback, so try looking for an 'image' attribute
if (!$basename && $feature->can('has_tag') && $feature->has_tag('image')) {
($basename) = $feature->get_tag_values('image');
}
return unless $basename;
return $basename if $basename =~ m!^\w+:/!; # looks like a URL
return $basename if $basename =~ m!^/!; # looks like an abs path
return "$dirname/$basename";
}
sub image_data {
my $self = shift;
my $path = $self->image_path or return;
if ($path =~ m!^\w+:/!) { # looks like a URL
require LWP::UserAgent;
my $ua = LWP::UserAgent->new(env_proxy => 1);
my $response = $ua->get($path);
if ($response->is_success) {
return ($response->content_type,$response->content);
} else {
$self->throw($response->status_line);
}
} else {
my $content_type = $self->_guess_format($path);
open F,$path or $self->throw("Can't open $path: $!");
binmode F;
my $data;
$data .= $_ while read(F,$_,1024);
close F;
return ($content_type,$data);
}
}
sub pad_left {
my $self = shift;
my $pad = $self->SUPER::pad_left;
my $image = $self->{image} or return $pad;
my $width_needed = ($image->width - $self->width)/2;
return $pad > $width_needed ? $pad : $width_needed;
}
sub pad_right {
my $self = shift;
my $pad = $self->SUPER::pad_right;
my $image = $self->{image} or return $pad;
my $width_needed = ($image->width - $self->width)/2;
return $pad > $width_needed ? $pad : $width_needed;
}
sub pad_bottom {
my $self = shift;
my $pb = $self->SUPER::pad_bottom;
my $image = $self->{image} or return $pb;
$pb += $self->vertical_spacing;
$pb += $image->height;
return $pb;
}
sub vertical_spacing {
my $self = shift;
my $vs = $self->option('vertical_spacing');
return $vs if defined $vs;
return VERTICAL_SPACING;
}
sub draw_description {
my $self = shift;
my ($gd,$left,$top,$partno,$total_parts) = @_;
$self->SUPER::draw_description($gd,$left,$top,$partno,$total_parts);
}
sub image_dir {
my $self = shift;
return $self->option('image_prefix');
}
sub draw_component {
my $self = shift;
my $gd = shift;
my($x1,$y1,$x2,$y2) = $self->bounds(@_);
my $delegate = $self->option('glyph_delegate') || 'generic';
if ($delegate eq 'generic') {
$self->SUPER::draw_component($gd,@_);
} else {
eval "require Bio::Graphics::Glyph::$delegate";
local @ISA = ("Bio::Graphics::Glyph::$delegate");
my $method = "Bio::Graphics::Glyph::${delegate}::draw_component";
$self->$method($gd,@_);
}
my $image = $self->{image} or return;
my $fgcolor = $self->fgcolor;
my $bgcolor = $self->bgcolor;
my $height = $self->option('height');
my $half = 4;
my $vs = $self->vertical_spacing;
my $delta = (($x2-$x1) - $image->width)/2;
my($x,$y) = ($x1+$delta,$y1+$vs+$self->height);
if ($gd->can('copy') && !$gd->isa('GD::SVG::Image')) {
$gd->copy($image,$x,$y,0,0,$image->width,$image->height) ;
}
elsif ($gd->isa('GD::SVG::Image')
&& $self->image_path =~ m!^(ftp|http)+:/!) { # a URL
my ($img,$id) = $gd->_prep($x,$y);
$img->image('x' => $x,
'y' => $y,
width => $image->width,
height => $image->height,
id => $id,
'xlink:href' => $self->image_path);
}
else {
my $gray = $self->panel->translate_color('gray');
$gd->filledRectangle($x,$y,$x+$image->width,$y+$image->height,$gray);
}
if ($vs > 0) {
$gd->line($x1,$y2+2,$x1,$y2+$half,$fgcolor);
$gd->line($x2,$y2+2,$x2,$y2+$half,$fgcolor);
$gd->line($x1,$y2+$half,$x,$y-$half,$fgcolor);
$gd->line($x2,$y2+$half,$x+$image->width-1,$y-$half,$fgcolor);
$gd->line($x,$y-$half,$x,$y-2,$fgcolor);
$gd->line($x+$image->width-1,$y-$half,$x+$image->width-1,$y-2,$fgcolor);
}
}
1;
__END__
=head1 NAME
Bio::Graphics::Glyph::image - A glyph that draws photographs & other images
=head1 SYNOPSIS
use Bio::Graphics;
use Bio::Seq;
use Bio::SeqFeature::Generic;
my $bsg = 'Bio::SeqFeature::Generic';
my $seq = Bio::Seq->new(-length=>1000);
my $whole = $bsg->new(-display_name => 'Clone82',
-start => 1,
-end => $seq->length);
my $image1 = $bsg->new(-start => 100,
-end => 300,
-display_name => 'Excretory System',
-tag=>{
image=>"http://www.flybase.org/anatomy/image-browser_files/excretory-system.gif"
}
);
my $image2 = $bsg->new(-start => 500,
-end => 800,
-display_name => 'Expression Pattern',
-tag=>{
image=>"http://www.flybase.org/anatomy/image-browser_files/embryonic-expression-pattern.gif"
}
);
my $panel = Bio::Graphics::Panel->new(-length => $seq->length,
-width => 800,
-truecolor => 1,
-key_style => 'between',
-pad_left => 10,
-pad_right => 10,
);
$panel->add_track($whole,
-glyph => 'arrow',
-double => 1,
-tick => 2,
-label => 1,
);
$panel->add_track([$image1,$image2],
-glyph => 'image',
-label => 1,
-key => 'Example images');
binmode STDOUT;
print $panel->png;
=head1 DESCRIPTION
This glyph inserts an image into the track at the indicated feature
coordinates. The image can be in PNG, JPEG, GIF or GD format, and can
be either 8-bit or 24-bit ("truecolor"). The image can be located on
the local filesystem or located at a remote URL (provided that you
have the LWP module installed).
When working with photographic images, you may wish to have
Bio::Graphics::Panel create 24-bit (truecolor) images in order to
avoid running out of colors. The symptom of this is that images appear
posterized. To turn on truecolor images, pass the -truecolor option to
Bio::Graphics::Panel as shown in the synopsis.
=head2 OPTIONS
The following options are standard among all Glyphs. See
L<Bio::Graphics::Glyph> for a full explanation.
Option Description Default
------ ----------- -------
-fgcolor Foreground color black
-outlinecolor Synonym for -fgcolor
-bgcolor Background color turquoise
-fillcolor Synonym for -bgcolor
-linewidth Line width 1
-height Height of glyph 10
-font Glyph font gdSmallFont
-connector Connector type 0 (false)
-connector_color
Connector color black
-label Whether to draw a label 0 (false)
-description Whether to draw a description 0 (false)
-hilite Highlight color undef (no color)
The following additional options are available to the "image" glyph:
Option Description Default
------ ----------- -------
-image Specify the image path or URL none
to use for this feature.
-image_prefix String to prepend to none
each image path. You may prepend
a directory or a partial URL.
-vertical_spacing Vertical distance from the box 20
that shows the physical span of
of the feature to the top of
the picture (in pixels).
-glyph_delegate Glyph to use for the part of 'generic'
the glyph that shows the physical
span of the feature.
Set B<-vertical_spacing> to 0 to completely suppress the diagonal
lines that connect the physical span of the feature to the image.
=head2 Specifying the Image
The path to the image can be specified in two ways. First, you can
place it in the feature itself using a tag named "image". Second, you
can specify it as a track option using a callback:
$panel->add_track(\@features,
-glyph=>'image',
-image => sub { my $feature = shift;
my $image_path = do_something();
return $image }
);
You can of course give -image a constant string, in which case each
feature will show the same image.
The image can be a file on the local operating system or a
URL. However, URL fetching will only work if the LWP module is
installed on your system. Otherwise the glyph will fail with an error
message.
If the image is a relative path (it does not begin with a slash or a
URL protocol), then the contents of -image_prefix will be prepended to
it. This allows you to specify images that are relative to a
particular directory or a partial URL. Example:
$panel->add_track(\@features,
-glyph => 'image',
-image_prefix => 'http://www.flybase.org/anatomy/image-browser_files',
);
This specifies that each feature's "image" tag is to be appended to
the partial FlyBase URL, thereby saving space.
=head2 Glyph Delegation
The image glyph consists of two parts: an upper part that shows the
extent of the feature in base pair coordinates, and a lower part that
shows the image. No scaling of the image is done; its height and width
are fixed.
By default the upper part uses the "generic" glyph, which is a simple
rectangle filled with the bgcolor and outlined with the fgcolor. To
use a different glyph in the upper part, specify the -glyph_delegate
option, giving the name of the glyph you wish to use. For instance, to
use the "span" glyph:
$panel->add_track(\@features,
-glyph => 'image',
-glyph_delegate => 'span'
);
This feature does not work with all glyphs, and in particular requires
a recent CVS checkout of Bio::Perl to work properly with the "arrow",
"span" and "primers" glyphs (support for the feature did not make it
into version 1.5).
=head1 BUGS AND LIMITATIONS
This glyph does not work with GD::SVG. If you try to render it onto a
GD::SVG panel, the image will be shown as a gray box. This will be
fixed in a future version of GD::SVG.
=head1 SEE ALSO
L<Bio::Graphics::Panel>,
L<Bio::Graphics::Glyph>,
L<Bio::Graphics::Glyph::arrow>,
L<Bio::Graphics::Glyph::cds>,
L<Bio::Graphics::Glyph::crossbox>,
L<Bio::Graphics::Glyph::diamond>,
L<Bio::Graphics::Glyph::dna>,
L<Bio::Graphics::Glyph::dot>,
L<Bio::Graphics::Glyph::ellipse>,
L<Bio::Graphics::Glyph::extending_arrow>,
L<Bio::Graphics::Glyph::generic>,
L<Bio::Graphics::Glyph::graded_segments>,
L<Bio::Graphics::Glyph::heterogeneous_segments>,
L<Bio::Graphics::Glyph::line>,
L<Bio::Graphics::Glyph::pinsertion>,
L<Bio::Graphics::Glyph::primers>,
L<Bio::Graphics::Glyph::rndrect>,
L<Bio::Graphics::Glyph::segments>,
L<Bio::Graphics::Glyph::ruler_arrow>,
L<Bio::Graphics::Glyph::toomany>,
L<Bio::Graphics::Glyph::transcript>,
L<Bio::Graphics::Glyph::transcript2>,
L<Bio::Graphics::Glyph::translation>,
L<Bio::Graphics::Glyph::triangle>,
L<Bio::DB::GFF>,
L<Bio::SeqI>,
L<Bio::SeqFeatureI>,
L<Bio::Das>,
L<GD>
=head1 AUTHOR
Lincoln Stein E<lt>lstein@cshl.orgE<gt>, Todd Harris E<lt>harris@cshl.orgE<gt>
Copyright (c) 2001 Cold Spring Harbor Laboratory
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut