lib/Bio/Graphics/Ruler.pm

   1 package Bio::Graphics::Ruler;
   2 use strict;
   3 use warnings;
   4 use English;
   5 use Carp;
   6
   7 use POSIX qw/log10/;
   8 use GD;
   9
  10 =head1 NAME
  11
  12 Bio::Graphics::Ruler - functions for drawing a ruler on a L<GD::Image>
  13
  14 =head1 SYNOPSIS
  15
  16   ruler( $image,
  17          -scale    => 'log' or 'linear',
  18          -label    => 'length',
  19          -units    => 'bp',
  20          -range    => [0,1000],
  21
  22          -start    => [x,y],
  23          -dir      => 'horizontal',
  24          -length   => 100, #pixels
  25          -width    => 10, #pixels
  26
  27          -font     => 'sans:normal',
  28          -tt       => 1, #use truetype fonts
  29          -ticks    => 0,1,2
  30        );
  31
  32 =head1 DESCRIPTION
  33
  34 Function for drawing a ruler on a L<GD::Image>.
  35
  36 =head1 AUTHOR(S)
  37
  38 Robert Buels - rmb32 at cornell dot edu
  39
  40 =head1 FUNCTIONS
  41
  42 All functions below are EXPORT_OK.
  43
  44 =cut
  45
  46 use base qw/Exporter/;
  47
  48 BEGIN {
  49   our @EXPORT_OK = qw(
  50                       ruler
  51                      );
  52 }
  53 our @EXPORT_OK;
  54
  55 =head2 ruler
  56
  57   Usage: ruler($image, arg => value, ...)
  58   Desc : draw a ruler on a GD::Image
  59   Args : a GD::Image, then the args:
  60          -scale     => 'log' or 'linear',
  61          -log_base  => 10,
  62          -label     => 'length',
  63          -units     => 'bp',
  64          -range     => [0,1000],
  65          -ticks     => 0,1,2
  66
  67          -start     => [10,20],
  68          -dir       => 'up',
  69          -label_pos => 'above' 'below' 'left' 'right'
  70          -length    => 100, #pixels
  71          -width     => 10,
  72
  73          -font      => 'sans:normal', #or a gd font like gdSmallFont
  74          -tt        => 1, #use truetype fonts
  75
  76   Ret  : nothing
  77   Side Effects: draws a ruler on the given image
  78   Example:
  79
  80 =cut
  81
  82 sub ruler {
  83   my ($im,%args) = @_;
  84   UNIVERSAL::isa($im,'GD::Image')
  85       or croak "first argument must be a GD::Image or a subclass";
  86
  87   #process options and validate args
  88   my @valid_args = qw/-scale -log_base -label -units -range -ticks -tick_vals -start -dir -label_pos  -length -width -font -tt/;
  89   my %valid_args; $valid_args{$_} = 1 foreach @valid_args;
  90   while(my ($k,$v) = each %args) {
  91     $valid_args{$k} or croak "invalid argument '$k'";
  92     if($k eq '-scale') {
  93       $v eq 'log' or $v eq 'linear'
  94         or croak "invalid -scale '$v'";
  95     } elsif($k eq 'log_base') {
  96       $v eq 'e' || $v =~ /^\d+$/
  97         or croak "invalid -log_base '$v', must be a number or 'e'";
  98     } elsif($k eq '-range') {
  99       ref($v) && ref($v) eq 'ARRAY' && @$v ==2
 100         && $v->[0] < $v->[1]
 101         or croak "invalid -range '$v'";
 102     } elsif($k eq '-ticks') {
 103       $v == 0 or $v == 1 or $v == 2
 104         or croak "invalid -ticks '$v', must be 0, 1, or 2";
 105     } elsif($k eq '-tick_vals') {
 106       ref($v) eq 'ARRAY'
 107         or croak "invalid -tick_vals, must be an arrayref";
 108     } elsif($k eq '-dir') {
 109       grep {$v eq $_} qw/up down left right/
 110         or croak "-dir must be either up, down, left, or right";
 111     } elsif($k eq '-label_pos') {
 112       grep {$v eq $_} qw/above below left right/
 113         or croak "-label_pos must be either above, below, left, or right";
 114     } elsif($k eq '-length') {
 115       $v > 0 or croak "invalid length '$v'";
 116     } elsif($k eq '-width') {
 117       $v > 0 or croak "invalid width '$v'";
 118     } elsif($k eq '-start') {
 119       ref($v) && ref($v) eq 'ARRAY' && @$v ==2
 120         && $v->[0] >= 0 && $v->[1] >= 0
 121         or croak "invalid start '$v'";
 122     }
 123   }
 124   #set defaults
 125   $args{-scale}      ||= 'linear';
 126   $args{-log_base}   ||= 10;
 127   $args{-label}      ||= '';
 128   $args{-units}      ||= '';
 129   $args{-range}      ||= [0,1000];
 130   $args{-ticks}      ||= 2;
 131   $args{-start}      ||= [0,0];
 132   $args{-dir}        ||= 'horizontal';
 133   $args{-label_pos}  ||= $args{-dir} eq 'up' || $args{-dir} eq 'down'  ? 'left' : 'below';
 134   $args{-length}     ||= 100;
 135   $args{-width}      ||= 10;
 136   $args{-tt}         ||= 0;
 137   $args{-font}       ||= $args{-tt} ? 'sans:normal' : gdSmallFont;
 138
 139   #draw the base line and end caps
 140   my $black = $im->colorAllocate(0,0,0);
 141   $im->setThickness(1);
 142
 143   my $majwidth = $args{-width};
 144   my $minwidth = $majwidth*0.75;
 145   my $len = $args{-length};
 146   my $s = $args{-start};
 147   my $e =   $args{-dir} eq 'up'   ? [$s->[0],      $s->[1]-$len] :
 148             $args{-dir} eq 'down' ? [$s->[0],      $s->[1]+$len] :
 149             $args{-dir} eq 'left' ? [$s->[0]-$len, $s->[1]]      :
 150                                     [$s->[0]+$len, $s->[1]];
 151   my ($range_start,$range_end) = @{$args{-range}};
 152   my $range_length = abs($range_end-$range_start);
 153
 154   $im->line(@$s,@$e,$black);
 155
 156   #now draw some tick marks and label them
 157   my $num2px = do {
 158     if($args{-scale} eq 'linear') {
 159       my $px_per_num = $args{-length}/$range_length;
 160       sub {$_[0]*$px_per_num}
 161     } elsif($args{-scale} eq 'log') {
 162       my $logdiff = abs(_log($range_end/($range_start||1),$args{-log_base}));
 163       my $px_per_num = $args{-length}/$logdiff;
 164 #      warn "logdiff is $logdiff, ppn is $px_per_num\n";
 165       sub {_log($_[0]||1,$args{-log_base})*$px_per_num}
 166     }
 167   };
 168
 169   #now get the numerical values at which to draw ticks,
 170   #either calculate them or get them from our arguments
 171   my @ticks = do {
 172     if($args{-tick_vals}) {
 173       @{$args{-tick_vals}}
 174     } elsif($args{-scale} eq 'linear') {
 175       my $maj_tick_interval = _pick_linear_tick_interval($range_length,$args{-length},$args{-dir});
 176       my $maj_tick_step = $range_start > $range_end ? -$maj_tick_interval : $maj_tick_interval;
 177 #      warn "for $args{-range}->[0],$args{-range}->[1], picked maj tick interval of $maj_tick_interval\n";
 178       my @t;
 179       for(my $i = 0; $i*$maj_tick_interval<=$range_length; $i++) {
 180         push @t,$range_start + $i*$maj_tick_step;
 181       }
 182       @t
 183     } elsif($args{-scale} eq 'log') {
 184       my $log_range_length = abs _log($range_end/($range_start||1),$args{-log_base});
 185       my $log_range_start = _log($range_start||1,$args{-log_base});
 186       my $maj_tick_interval = 1;
 187       my $maj_tick_step = $range_start > $range_end ? -$maj_tick_interval : $maj_tick_interval;
 188 #      warn "for log range length $log_range_length, picked maj tick interval of $maj_tick_interval\n";
 189       my @t;
 190        for(my $i = 0; ($i*$maj_tick_interval)<=$log_range_length; $i++) {
 191         push @t,_exp($args{-log_base}, $log_range_start + $i*$maj_tick_step);
 192       }
 193 #      warn "made ticks ".join(',',@t)."\n";
 194       @t
 195     }
 196   };
 197
 198   #now draw the ticks
 199   foreach my $tickval (@ticks) {
 200 #    warn "$tickval => ".$num2px->($tickval)."\n";
 201     my @offset_coords = _offset(@$s,$num2px->($tickval) - $num2px->($range_start) ,$args{-dir});
 202     _tick($im,$black,,@offset_coords, $majwidth,$args{-dir});
 203     _label($im,$black, _commify_number($tickval), @offset_coords,$majwidth,$args{-label_pos});
 204   }
 205 }
 206
 207 sub _commify_number {
 208   local $_  = shift;
 209   return undef unless defined $_;
 210   1 while s/^(-?\d+)(\d{3})/$1,$2/;
 211   $_;
 212 }
 213
 214 sub _offset {
 215   my ($x,$y,$distance,$dir) = @_;
 216   if($dir eq 'up') {
 217     $y-=$distance;
 218   } elsif($dir eq 'down') {
 219     $y+=$distance;
 220   } elsif($dir eq 'left') {
 221     $x-=$distance;
 222   } elsif($dir eq 'right') {
 223     $x+=$distance;
 224   } else {
 225     confess "invalid dir '$dir'";
 226   }
 227   return ($x,$y);
 228 }
 229
 230 sub _exp {
 231   my ($base,$exp) = @_;
 232   if($base eq 'e') {
 233     return exp $exp;
 234   } else {
 235     $base =~ /^\d+$/ or croak "invalid log base '$base'";
 236     return $base**$exp;
 237   }
 238 }
 239 sub _log {
 240   my ($num,$base) = @_;
 241   if($base eq 'e') {
 242     return log $num
 243   } elsif($base == 10) {
 244     return log10($num)
 245   } else {
 246     $base =~ /^\d+$/ or croak "invalid log base '$base'";
 247     return log($num)/log($base)
 248   }
 249 }
 250
 251 #given a range, and the length of pixels we have to cover it,
 252 #pick a good tick interval for it
 253 sub _pick_linear_tick_interval {
 254   my ($range_length, $length_px, $dir)  = @_;
 255   $range_length = abs $range_length;
 256
 257   my $tick_spacing_px = $dir eq 'up' || $dir eq 'down' ? 15 : 25;
 258   my $ticks_we_have_room_for = int($length_px / $tick_spacing_px);
 259 #  warn "in $length_px, we have room for $ticks_we_have_room_for\n";
 260   my %possible;
 261   foreach my $modifier (25,20,5,3,2,1) {
 262     foreach my $basep (reverse -10..10) {
 263       my $interval = 10**$basep*$modifier;
 264       my $numticks = $range_length/$interval;
 265       # warn "for $range_length, $interval results in $numticks ticks, we have room for $ticks_we_have_room_for\n";
 266       if ($numticks <= $ticks_we_have_room_for) {
 267         $possible{$interval} = 1;
 268       }
 269     }
 270   }
 271
 272   die "could not pick a tick interval\n"
 273     unless %possible;
 274
 275   return (sort {$a <=> $b} keys %possible)[0];
 276 }
 277
 278 sub _tick {
 279   my ($im,$color,$x,$y,$width,$dir,$label,$label_pos) = @_;
 280
 281   if($dir eq 'up' || $dir eq 'down') {
 282     $im->line($x+$width/2,$y,
 283               $x-$width/2,$y,
 284               $color);
 285   } elsif($dir eq 'left' || $dir eq 'right' ) {
 286     $im->line($x,$y+$width/2,
 287               $x,$y-$width/2,
 288               $color);
 289   } else {
 290     confess "invalid direction '$dir'";
 291   }
 292 }
 293
 294 sub _label {
 295   my ($im,$color,$text,$x,$y,$width,$label_rel) = @_;
 296   my $offset = $width/2+2;
 297   $im->useFontConfig(1);
 298 #  sub dp(@) { print join(',',@_),"\n"; @_ }
 299   if($label_rel eq 'above') {
 300     _stringFT_origin('lc',$im,$color,'sans:normal',10, 0,
 301                      $x,$y-$offset,
 302                      $text);
 303   } elsif($label_rel eq 'left') {
 304     _stringFT_origin('cr',$im,$color,'sans:normal',10, 0,
 305                      $x-$offset,$y,
 306                      $text);
 307   } elsif($label_rel eq 'right' ) {
 308     _stringFT_origin('cl',$im,$color,'sans:normal',10, 0,
 309                      $x+$offset,$y,
 310                      $text);
 311   } elsif($label_rel eq 'below' ) {
 312     _stringFT_origin('uc',$im,$color,'sans:normal',10, 0,
 313                      $x,$y+$offset,
 314                      $text);
 315   } else {
 316     confess "invalid label direction '$label_rel'";
 317   }
 318 }
 319
 320 #just like stringFT, but using a different coordinate origin for the text
 321 #does not allow rotated text
 322 sub _stringFT_origin {
 323   my ($origin,$im,@stringargs) = @_;
 324
 325   #get a bounding box
 326   if($origin eq 'll') {
 327     #lower-left is the native origin for stringFT, so we don't have to do anything
 328     return $im->stringFT(@stringargs);
 329   } else {
 330     my ($yor,$xor) = split '',$origin;
 331     my @bounds = GD::Image->stringFT(@stringargs);
 332     my $width = $bounds[2]-$bounds[0];
 333     my $height = $bounds[3]-$bounds[5];
 334     $stringargs[5] +=
 335       $yor eq 'u' ? $height   :
 336       $yor eq 'c' ? $height/2 :
 337       $yor eq 'l' ? 0         :
 338         confess "invalid y origin '$yor'";
 339     $stringargs[4] -=
 340       $xor eq 'r' ? $width    :
 341       $xor eq 'c' ? $width/2  :
 342       $xor eq 'l' ? 0         :
 343         confess "invalid x origin '$xor'";
 344
 345     return $im->stringFT(@stringargs);
 346   }
 347 }
 348
 349 ###
 350 1;#do not remove
 351 ###