lib/Bio/Graphics/Gel.pm

   1 package Bio::Graphics::Gel;
   2 use strict;
   3 use warnings;
   4 use English;
   5 use Carp;
   6
   7 use GD;
   8 use POSIX qw/log10/;
   9
  10 use Bio::Graphics::Ruler qw/ruler/;
  11
  12 =head1 NAME
  13
  14 Bio::Graphics::GelImage - a L<GD> image that draws something that
  15 looks like a gel image, without getting ethidium bromide all over your
  16 hands.
  17
  18 =head1 SYNOPSIS
  19
  20   my $gel = Bio::Graphics::Gel->new( 'In vitro'  => [ 1100, 1900, 2000 ],
  21                                      'In silico' => [ 1230, 12440 ],
  22                                      -title     => 'Restriction Fragments',
  23                                      -lane_width => 20, #in pixels
  24                                    );
  25
  26   #write PNG data to STDOUT
  27   binmode STDOUT; #< required for dos-ish platforms
  28   print $gel->img->png;
  29
  30 =head1 DESCRIPTION
  31
  32 Class for making gel images in a variety of formats.
  33
  34 =head1 BASE CLASS(ES)
  35
  36 L<Bio::Root::Root>
  37 L<GD::Image>
  38
  39 =cut
  40
  41 use base qw/Bio::Root::Root/;
  42
  43 =head1 SUBCLASSES
  44
  45 none yet
  46
  47 =head1 AUTHOR(S)
  48
  49 Robert Buels - rmb32 at cornell dot edu
  50
  51 =head1 METHODS
  52
  53
  54 =head2 new
  55
  56   Usage: my $gel = Bio::Graphics::Gel->new( mylane => [100,200,300] );
  57   Args : list of 'lane title' => [ frag size, frag size, frag size ],
  58          plus optional configuration parameters:
  59          -title        add this title to the gel image
  60          -lane_width   set the width of each lane on the gel,
  61                        defaults to 40 pixels
  62          -lane_length  set the length of each lane on the gel,
  63                        defaults to 200 pixels
  64          -lane_spacing pixels between lanes, default 3
  65          -padding      css-like string like '10 20 10 20' or an
  66                        arrayref like [10,20,10,20], with the order
  67                        being top,right,bottom,left
  68          -bandcolor    color in RGB like '255 0 0' or [255,0,0] for red,
  69                        sets the color of the bands on the gel,
  70          -gelcolor     same, but for the gel color,
  71          -bgcolor      same, but for the background color,
  72          -textcolor      same, but for the text color,
  73          -font_size    in points.  default 10
  74          -font_file    full path to TrueType font file to use,
  75                        default /usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf
  76          -band_thickness  thickness in pixels of the bands.  default 1.
  77          -min_frag     set the 'end' of 'diffusion' on the gel to
  78                        correspond to fragments of this length.
  79                        defaults to the length of the smallest fragment
  80                        in any lane on the gel
  81          -max_frag     similar to -min_frag, except for the start of
  82                        diffusion
  83          -dilation     no default. if not set, this is calculated such
  84                        that the smallest-sized fragment is at the end of
  85                        the gel,
  86          -diff_limit   log10 of the largest length of fragment that can
  87                        diffuse in the gel, defaults to largest fragment
  88                        size (or -max_frag) times 1.3
  89
  90   Ret  : a new Gel image object
  91   Desc : make a new GelImage object with the given data
  92   Side Effects: none
  93
  94 =cut
  95
  96 sub new {
  97   my ($class,@args) = @_;
  98
  99   my $self = $class->SUPER::new(@args);
 100
 101   @args%2 and $self->throw('argument list must be even-length');
 102
 103   sub arraystr {
 104     my ($val) = @_;
 105     my $origvalstr = ref($val) eq 'ARRAY' ? join(',',@$val) : $val;
 106     $val = [ split /\s+/,$val ] unless ref $val eq 'ARRAY';
 107     return ($val,$origvalstr);
 108   }
 109
 110   #parse and validate arguments
 111   while(my ($key,$val) = splice @args,0,2) {
 112     #for config options
 113     if($key =~ s/^-//) {
 114       if($key eq 'title') {
 115         $self->{title} = $val;
 116       } elsif($key eq 'lane_width') {
 117         $val > 0 or $self->throw("invalid lane width '$val'");
 118         $self->{lane_width} = $val;
 119       } elsif($key eq 'lane_length') {
 120         $val > 0 or $self->throw("invalid lane length '$val'");
 121         $self->{lane_length} = $val;
 122       } elsif($key eq 'lane_spacing') {
 123         $val >0 or $self->throw("invalid lane_spacing '$val'");
 124         $self->{lane_spacing} = $val;
 125       } elsif($key eq 'padding') {
 126         my ($val,$origval) = arraystr($val);
 127 #       use Data::Dumper;
 128 #       print 'got padding ',Dumper($val);
 129         (@$val == 4) #and (not grep {! $_ >= 0 } @$val)
 130           or $self->throw("invalid padding '$origval'");
 131         $self->{padding} = $val;
 132       } elsif($key eq 'bandcolor') {
 133         my ($val,$origval) = arraystr($val);
 134         @$val == 3 #and not grep {! ($_ >= 0 && $_ <= 255)} @$val
 135           or $self->throw("invalid bandcolor '$origval'");
 136         $self->{bandcolor} = $val;
 137       } elsif($key eq 'gelcolor') {
 138         my ($val,$origval) = arraystr($val);
 139         @$val == 3 #and not grep {! ($_ >= 0 && $_ <= 255)} @$val
 140           or $self->throw("invalid gelcolor '$origval'");
 141         $self->{gelcolor} = $val;
 142       } elsif($key eq 'bgcolor') {
 143         my ($val,$origval) = arraystr($val);
 144         @$val == 3 and not grep {! ($_ >= 0 && $_ <= 255)} @$val
 145           or $self->throw("invalid bgcolor '$origval'");
 146         $self->{bgcolor} = $val;
 147       } elsif($key eq 'textcolor') {
 148         my ($val,$origval) = arraystr($val);
 149         @$val == 3 and not grep {! ($_ >= 0 && $_ <= 255)} @$val
 150           or $self->throw("invalid textcolor '$origval'");
 151         $self->{textcolor} = $val;
 152       } elsif($key eq 'font_size') {
 153         $val > 0 or $self->throw("invalid font_size '$val'");
 154         $self->{font_size} = $val;
 155       } elsif($key eq 'font_file') {
 156         -f $val or $self->throw("font file '$val' does not exist, please specify a different one");
 157         $self->{font_file} = $val;
 158       } elsif($key eq 'band_thickness') {
 159         $val > 0 or $self->throw("invalid band_thickness '$val'");
 160         $self->{band_thickness} = $val;
 161       } elsif($key eq 'min_frag') {
 162         $val > 0 or $self->throw("invalid min_frag '$val'");
 163         $self->{min_frag} = $val;
 164       } elsif($key eq 'dilation') {
 165         $val > 0 or $self->throw("invalid dilation '$val'");
 166         $self->{dilation} = $val;
 167       } elsif($key eq 'diff_limit') {
 168         $val > 0 or $self->throw("invalid diff_limit '$val'");
 169         $self->{diff_limit} = $val;
 170
 171
 172       } else {
 173         $self->throw("unknown configuration parameter '-$key'");
 174       }
 175     }
 176     #for lanes
 177     else {
 178       #must be a lane with a title
 179       $self->{lanes} ||= [];
 180       ref($val) eq 'ARRAY' or $self->throw("fragments lengths must be given as arrayrefs");
 181       push @{$self->{lanes}}, Bio::Graphics::Gel::Lane->new($key,$val);
 182     }
 183   }
 184
 185   $self->{lanes} && @{$self->{lanes}}
 186     or $self->throw('must specify at least one lane');
 187
 188   #set default values
 189   $self->{lane_width}     ||= 40;
 190   $self->{lane_length}    ||= 200;
 191   $self->{lane_spacing}   ||= 5;
 192   $self->{padding}        ||= [10,20,10,20];
 193   $self->{bandcolor}      ||= [255,255,255];
 194   $self->{gelcolor}       ||= [127,127,127];
 195   $self->{bgcolor}        ||= [255,255,255];
 196   $self->{textcolor}      ||= [0,0,0];
 197   $self->{font_size}      ||= 10;
 198   $self->{font_file}      ||= '/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf';
 199   $self->{band_thickness} ||= 1;
 200
 201   $self->_render; #< creates $self->{gd_img}
 202
 203   return $self;
 204 }
 205
 206 =head2 lanes
 207
 208   Usage: my @lanes = $gel->lanes;
 209   Args : none
 210   Ret  : list of Bio::Graphics::Gel::Lane objects representing the
 211          lanes in the gel
 212   Desc : get/set the list of lanes and their titles in the gel
 213
 214 =cut
 215
 216 sub lanes {
 217   my ($self) = @_;
 218   return @{$self->{lanes}};
 219 }
 220
 221
 222 =head2 img
 223
 224   Usage: print $gel->img->png; #prints this gel image as PNG to stdout
 225   Desc : get the GD image with the gel drawn on it
 226   Args : none
 227   Ret  : the L<GD::Image>, with this gel image drawn on it.
 228          see L<GD::Image> or L<GD> for how to use it
 229
 230 =cut
 231
 232 sub img {
 233   my ($self) = @_;
 234   return $self->{gd_img};
 235 }
 236
 237
 238 sub _min(@) { #unfortunately, List::Util::min() doesn't work on OS X 10.3, so I can't use it
 239   my $min;
 240   $min = (defined($min) and $min <= $_) ? $min : $_ foreach @_;
 241   return $min;
 242 }
 243 sub _max(@) {
 244   my $max;
 245   $max = (defined($max) and $max >= $_) ? $max : $_ foreach @_;
 246   return $max
 247 }
 248
 249 #no arguments, renders the
 250 sub _render {
 251   my ($self) = @_;
 252
 253   #set padding numbers for rendering vertically
 254   my ($tpad,$rpad,$bpad,$lpad) = @{$self->{padding}};
 255
 256   #figure out the height and width of our text labels
 257   my $labels_angle = 0;
 258   my $lane_labels_height;
 259   my $fragsize_labels_width;
 260   {
 261     my $throwaway = GD::Image->new(10,10,1);
 262     my $b = $throwaway->colorAllocate(0,0,0);
 263     $throwaway->useFontConfig(1);
 264     $lane_labels_height = _max map {
 265       my @b = GD::Image->stringFT($b,$self->{font_file},$self->{font_size},$labels_angle,100,100,$_->name);
 266       $b[1]-$b[5]
 267     } $self->lanes;
 268     $fragsize_labels_width = _max map {
 269       my @b = GD::Image->stringFT($b,$self->{font_file},$self->{font_size},$labels_angle,100,100,_commify_number($_));
 270       $b[4]-$b[0]
 271     } $self->_ladder_lane->fragments;
 272   }
 273
 274 #  warn "got height $lane_labels_height\n";
 275
 276   my ($width,$height) = (
 277                          (@{$self->{lanes}}+1)*($self->{lane_width}+$self->{lane_spacing})
 278                          + $lpad + $rpad + $self->{lane_spacing} + $fragsize_labels_width,
 279
 280                          $self->{lane_length} + 4 + $tpad + $lane_labels_height + $bpad ,
 281                         );
 282
 283   #initalize our canvas, true-color, with a white background
 284   my $im = $self->{gd_img} = GD::Image->new($width,$height,1);
 285   my $textcolor = $im->colorAllocate(@{$self->{textcolor}});
 286   my $bg = $im->colorAllocate(@{$self->{bgcolor}});
 287   my $gelcolor = $im->colorAllocate(@{$self->{gelcolor}});
 288   my $fg = $im->colorAllocate(@{$self->{bandcolor}});
 289   $im->fill(0,0,$bg);
 290
 291   #draw the gel
 292   my ($gelx,$gely) = ($lpad+$fragsize_labels_width,$tpad+$lane_labels_height);
 293   my ($gelwidth,$gelheight) = ($width-$rpad-$gelx,$height-$bpad-$gely);
 294   $im->filledRectangle($gelx,$gely,$gelx+$gelwidth,$gely+$gelheight,$gelcolor);
 295
 296   ### draw the lanes with bands and labels
 297   $im->useFontConfig(1);
 298   my $smallest_frag = $self->{min_frag} || _min map { $_->fragments } @{$self->{lanes}};
 299   my $biggest_frag  = $self->{max_frag} || _max map { $_->fragments } @{$self->{lanes}};
 300   $self->{diff_limit} ||= log10($biggest_frag*1.3);
 301   $self->{dilation}   ||= $self->{lane_length} / ($self->{diff_limit}-log10($smallest_frag));
 302 #  warn "using gel params $self->{dilation},$self->{diff_limit}\n";
 303   $im->setThickness($self->{band_thickness});
 304   my @lanes = ($self->_ladder_lane,@{$self->{lanes}});
 305   my @fraglabels;
 306   for(my $lanenum = 0; $lanenum < @lanes; $lanenum++) {
 307     my $lane = $lanes[$lanenum];
 308     my $x_offset = $gelx+$self->{lane_spacing}+($self->{lane_width}+$self->{lane_spacing})*$lanenum;
 309
 310     _stringFT_origin('lc',$im,$textcolor,$self->{font_file},$self->{font_size},$labels_angle,$x_offset+$self->{lane_width}/2,$gely - 5,$lane->name);
 311
 312     foreach my $frag ($lane->fragments) {
 313       my $diffusion_px = _min($self->{lane_length},sprintf('%d',$self->{dilation}*($self->{diff_limit}-log10($frag))));
 314       $diffusion_px = 0 unless $diffusion_px > 0;
 315       my $y_offset = $gely + $diffusion_px + 1;
 316 #      warn "drawing with $y_offset\n";
 317       $im->line($x_offset,$y_offset,$x_offset+$self->{lane_width},$y_offset,$fg);
 318       if($lanenum == 0) {
 319         push @fraglabels, [$y_offset,$frag];
 320 #       _stringFT_origin('cr',$im,$textcolor,$self->{font_file},10,0,$gelx-2,$y_offset,_commify_number($frag));
 321       }
 322     }
 323   }
 324
 325   #draw fragment labels from top to bottom, skipping ones that would overlap with the ones above
 326   my @bounds;
 327   foreach my $label (sort {$a->[0] <=> $b->[0]} @fraglabels) {
 328     my @stringargs = ($textcolor,$self->{font_file},$self->{font_size},0,$gelx-2,$label->[0],_commify_number($label->[1]));
 329     my @newbounds = GD::Image->stringFT(@stringargs);
 330     unless(@bounds && ($newbounds[7] < $bounds[1])) {
 331       _stringFT_origin('cr',$im,@stringargs);
 332       @bounds = @newbounds;
 333     }
 334   }
 335 }
 336
 337 #just like stringFT, but using a different coordinate origin for the text
 338 #does not allow rotated text
 339 sub _stringFT_origin {
 340   my ($origin,$im,@stringargs) = @_;
 341
 342   #get a bounding box
 343   if($origin eq 'll') {
 344     #lower-left is the native origin for stringFT, so we don't have to do anything
 345     return $im->stringFT(@stringargs);
 346   } else {
 347     my ($yor,$xor) = split '',$origin;
 348     my @bounds = GD::Image->stringFT(@stringargs);
 349     my $width = $bounds[2]-$bounds[0];
 350     my $height = $bounds[3]-$bounds[5];
 351     $stringargs[5] +=
 352       $yor eq 'u' ? $height   :
 353       $yor eq 'c' ? $height/2-2 :
 354       $yor eq 'l' ? 0         :
 355         confess "invalid y origin '$yor'";
 356     $stringargs[4] -=
 357       $xor eq 'r' ? $width    :
 358       $xor eq 'c' ? $width/2  :
 359       $xor eq 'l' ? 0         :
 360         confess "invalid x origin '$xor'";
 361
 362 #    $im->rectangle(@bounds[6,7,2,3],$stringargs[0]);
 363     return $im->stringFT(@stringargs);
 364   }
 365 }
 366
 367 sub _commify_number {
 368   local $_  = shift;
 369   return undef unless defined $_;
 370   1 while s/^(-?\d+)(\d{3})/$1,$2/;
 371   $_;
 372 }
 373
 374 #   #draw a ruler down the side
 375 #   ruler( $im,
 376 #        -start  => [$lpad+$ruler_width/2,$gely+$gelheight],
 377 #        -dir    => 'up',
 378 #        -length => $gelheight,
 379 # #      -widtha  => $ruler_width,
 380
 381 #        -units    => 'bp',
 382 #        -label    => 'length',
 383 #        -scale    => 'log',
 384 #        -log_base => 10,
 385 # #      -tick_vals =>
 386 #        -range  => [100,10000],
 387 #        );
 388
 389
 390 sub _ladder_lane {
 391   my ($self) = @_;
 392
 393   return $self->{ladder_lane} ||= do {
 394     my @ladder_fragments = (10,30,50,100,200, 300, 400, 500,1000,2000,5000,7000,10000,20000,50000,100000,250000,500000,1000000);
 395
 396     #look at the other lanes in the gel and figure out which ladder fragments to use
 397     my @allfrags = map {$_->fragments} $self->lanes;
 398     my $minfrag = $self->{min_frag} || _min(@allfrags);
 399     my $maxfrag = $self->{max_frag} || _max(@allfrags);
 400     my @use_ladder = grep { $_*1.2 >= $minfrag && $_*0.5 <= $maxfrag } @ladder_fragments;
 401 #    warn "min is $minfrag, max is $maxfrag, using ladder ".join(',',@use_ladder)."\n";
 402     Bio::Graphics::Gel::Lane->new( ladder => \@use_ladder );
 403   };
 404 }
 405
 406 package Bio::Graphics::Gel::Lane;
 407
 408 use Bio::Tools::Gel;
 409 our @ISA = qw/Bio::Root::Root/;
 410
 411 sub new {
 412   my ($class,$name,$frags) = @_;
 413   my $self = $class->SUPER::new;
 414   $self->name($name);
 415   $self->fragments(@$frags);
 416   return $self;
 417 }
 418
 419 sub name {
 420   my ($self,$name) = @_;
 421   if($name) {
 422     $self->{name} = $name;
 423   }
 424   return $self->{name};
 425 }
 426
 427 sub fragments {
 428   my ($self,@frags) = @_;
 429   if(@frags) {
 430     foreach (@frags) {
 431       unless($_+0 eq $_) {
 432         $self->throw("invalid fragment length $_");
 433       }
 434     }
 435     $self->{frags} = [ sort {$a <=> $b} @frags ];
 436   }
 437   return @{$self->{frags}};
 438 }
 439
 440
 441 ###
 442 1;#do not remove
 443 ###