File Coverage

lib/Bio/Graphics/Panel.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

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';
use constant KEYSPACING   => 5; # extra space between key columns
use constant KEYPADTOP    => 5;  # extra padding before the key starts
use constant KEYCOLOR     => 'wheat';
use constant KEYSTYLE     => 'bottom';
use constant KEYALIGN     => 'left';
use constant GRIDCOLOR    => 'lightcyan';
use constant GRIDMAJORCOLOR    => 'lightgrey';
use constant MISSING_TRACK_COLOR =>'gray';
use constant EXTRA_RIGHT_PADDING => 30;

use base qw(Bio::Root::Root);
our $GlyphScratch;

my %COLORS;  # translation table for symbolic color names to RGB triple
my $IMAGEMAP = 'bgmap00001';
read_colors();

sub api_version { 1.8 }

# Create a new panel of a given width and height, and add lists of features
# one by one
sub new {
  my $class = shift;
  $class    = ref($class) || $class;
  my %options = @_;

  $class->read_colors() unless %COLORS;

  my $length = $options{-length} || 0;
  my $offset = $options{-offset}  || 0;
  my $spacing = $options{-spacing} || 5;
  my $bgcolor = $options{-bgcolor} || 'white';
  my $keyfont = $options{-key_font} || KEYLABELFONT;
  my $keycolor = $options{-key_color} || KEYCOLOR;
  my $keyspacing = $options{-key_spacing} || KEYSPACING;
  my $keystyle = $options{-key_style} || KEYSTYLE;
  my $keyalign = $options{-key_align} || KEYALIGN;
  my $suppress_key = $options{-suppress_key} || 0;
  my $allcallbacks = $options{-all_callbacks} || 0;
  my $gridcolor    = $options{-gridcolor} || GRIDCOLOR;
  my $gridmajorcolor    = $options{-gridmajorcolor} || GRIDMAJORCOLOR;
  my $grid         = $options{-grid}       || 0;
  my $extend_grid  = $options{-extend_grid}|| 0;
  my $flip         = $options{-flip}       || 0;
  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
  my $linkrule     = $options{-link};
  my $titlerule    = $options{-title};
  my $targetrule   = $options{-target};
  my $background   = $options{-background};
  my $postgrid     = $options{-postgrid};
  $options{-stop}||= $options{-end};  # damn damn damn
  my $add_categories= $options{-add_category_labels};

  if (my $seg = $options{-segment}) {
    $offset = eval {$seg->start-1} || 0;
    $length = $seg->length;
  }

  $offset   ||= $options{-start}-1 if defined $options{-start};
  $length   ||= $options{-stop}-$options{-start}+1
     if defined $options{-start} && defined $options{-stop};

  # bring in the image generator class, since we will need it soon anyway
  eval "require $image_class; 1" or $class->throw($@);

  return bless {
		tracks => [],
		width      => $options{-width} || 600,
		pad_top    => $options{-pad_top}||0,
		pad_bottom => $options{-pad_bottom}||0,
		pad_left   => $options{-pad_left}||0,
		pad_right  => $options{-pad_right}||0,
		global_alpha => $options{-alpha} || 0,
		length => $length,
		offset => $offset,
		gridcolor => $gridcolor,
		gridmajorcolor => $gridmajorcolor,
		grid    => $grid,
		extend_grid    => $extend_grid,
		bgcolor => $bgcolor,
		height => 0, # AUTO
		spacing => $spacing,
		key_font => $keyfont,
		key_color => $keycolor,
		key_spacing => $keyspacing,
		key_style => $keystyle,
		key_align => $keyalign,
		suppress_key => $suppress_key,
		background => $background,
		postgrid   => $postgrid,
		autopad   => $autopad,
		all_callbacks => $allcallbacks,
		truecolor     => $truecolor,
		truetype      => $truetype,
		flip          => $flip,
		linkrule      => $linkrule,
		titlerule     => $titlerule,
		targetrule    => $targetrule,
		empty_track_style  => $empty_track_style,
		image_class  => $image_class,
		image_package => $image_class . '::Image',     # Accessors
		polygon_package => $image_class . '::Polygon',
		add_category_labels => $add_categories,
		key_boxes  => [],
	       },$class;
}

sub rotate {
  my $self = shift;
  my $d    = $self->{rotate};
  $self->{rotate} = shift if @_;
  $d;
}

sub pad_left {
  my $self = shift;
  my $g = $self->{pad_left};
  $self->{pad_left} = shift if @_;
  $g;
}
sub pad_right {
  my $self = shift;
  my $g = $self->{pad_right};
  $self->{pad_right} = shift if @_;
  $g;
}
sub pad_top {
  my $self = shift;
  my $g = $self->{pad_top};
  $self->{pad_top} = shift if @_;
  $g;
}
sub pad_bottom {
  my $self = shift;
  my $g = $self->{pad_bottom};
  $self->{pad_bottom} = shift if @_;
  $g;
}
sub extend_grid {
  my $self = shift;
  my $g = $self->{extend_grid};
  $self->{extend_grid} = shift if @_;
  $g;
}
sub flip {
  my $self = shift;
  my $g = $self->{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)
#    "key"      -- show just the key in "between" mode
#    "line"     -- draw a thin grey line
#    "dashed"   -- draw a dashed line
sub empty_track_style {
  my $self = shift;
  my $g = $self->{empty_track_style};
  $self->{empty_track_style} = shift if @_;
  $g;
}

sub key_style {
  my $self = shift;
  my $g = $self->{key_style};
  $self->{key_style} = shift if @_;
  $g;
}

sub auto_pad {
  my $self = shift;
  my $g = $self->{autopad};
  $self->{autopad} = shift if @_;
  $g;
}

# public routine for mapping from a base pair
# location to pixel coordinates
sub location2pixel {
  my $self   = shift;
  my $end    = $self->end + 1;
  my @coords = $self->{flip} ? map { $end-$_ } @_ : @_;
  $self->map_pt(@coords);
}

# numerous direct calls into array used here for performance considerations
sub map_pt {
  my $self   = shift;
  my $offset = $self->{offset};
  my $scale  = $self->{scale} || $self->scale;
  my $pl     = $self->{pad_left};
  my $pr     = $self->{width};
  my $flip   = $self->{flip};
  my $length = $self->{length};
  my @result;
  foreach (@_) {
    my $val = $flip
      ? $pr - ($length - ($_- 1)) * $scale
	: ($_-$offset-1) * $scale;
    $val = int($val + 0.5 * ($val<=>0));
    $val = -1    if $val < 0;
    $val = $pr+1 if $val > $pr;
    push @result,$val;
  }
  @result;
}

sub map_no_trunc {
  my $self   = shift;
  my $offset = $self->{offset};
  my $scale  = $self->scale;
  my $pl     = $self->{pad_left};
  my $pr     = $pl + $self->{width}; # - $self->{pad_right};
  my $flip   = $self->{flip};
  my $length = $self->{length};
  my $end    = $offset+$length;
  my @result;
  foreach (@_) {
    my $val = $flip ? int (0.5 + $pl + ($end - ($_- 1)) * $scale) : int (0.5 + $pl + ($_-$offset-1) * $scale);
    push @result,$val;
  }
  @result;
}

sub scale {
  my $self = shift;
  $self->{scale} ||= $self->width/($self->length);
}

sub start { shift->{offset}+1}
sub end   { $_[0]->start + $_[0]->{length}-1}

sub offset { shift->{offset} }
sub width {
  my $self = shift;
  my $d = $self->{width};
  $self->{width} = shift if @_;
  $d;
}

sub left {
  my $self = shift;
  $self->pad_left;
}
sub right {
  my $self = shift;
  $self->pad_left + $self->width; # - $self->pad_right;
}
sub top {
  shift->pad_top;
}
sub bottom {
  my $self = shift;
  $self->height - $self->pad_bottom;
}

sub spacing {
  my $self = shift;
  my $d = $self->{spacing};
  $self->{spacing} = shift if @_;
  $d;
}

sub key_spacing {
  my $self = shift;
  my $d = $self->{key_spacing};
  $self->{key_spacing} = shift if @_;
  $d;
}

sub length {
  my $self = shift;
  my $d = $self->{length};
  if (@_) {
    my $l = shift;
    $l = $l->length if ref($l) && $l->can('length');
    $self->{length} = $l;
  }
  $d;
}

sub gridcolor {shift->{gridcolor}}

sub gridmajorcolor {shift->{gridmajorcolor}}

sub all_callbacks { shift->{all_callbacks} }

sub add_track {
  my $self = shift;
  $self->_do_add_track(scalar(@{$self->{tracks}}),@_);
}

sub unshift_track {
  my $self = shift;
  $self->_do_add_track(0,@_);
}

sub insert_track {
  my $self = shift;
  my $position = shift;
  $self->_do_add_track($position,@_);
}


# create a feature and factory pair
# see Factory.pm for the format of the options
# The thing returned is actually a generic Glyph
sub _do_add_track {
  my $self     = shift;
  my $position = shift;

  # due to indecision, we accept features
  # and/or glyph types in the first two arguments
  my ($features,$glyph_name) = ([],undef);
  while ( @_ && $_[0] !~ /^-/) {
    my $arg = shift;
    $features   = $arg and next if ref($arg);
    $glyph_name = $arg and next unless ref($arg);
  }

  my %args = @_;
  my ($map,$ss,%options);

  foreach (keys %args) {
    (my $canonical = lc $_) =~ s/^-//;
    if ($canonical eq 'glyph') {
      $map = $args{$_};
      delete $args{$_};
    } elsif ($canonical eq 'stylesheet') {
      $ss  = $args{$_};
      delete $args{$_};
    } else {
      $options{$canonical} = $args{$_};
    }
  }

  $glyph_name = $map if defined $map;
  $glyph_name ||= 'generic';

  local $^W = 0;  # uninitialized variable warnings under 5.00503

  my $panel_map =
    ref($map) eq 'CODE' ?  sub {
      my $feature = shift;
      return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'track' };
      return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'group' };
      return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'scale' };
      return $map->($feature,'glyph',$self);
    }
   : ref($map) eq 'HASH' ? sub {
     my $feature = shift;
     return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'track' };
     return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'group' };
     return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'scale' };
     return eval {$map->{$feature->primary_tag}} || 'generic';
   }
   : sub {
     my $feature = shift;
     return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'track' };
     return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'group' };
     return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag  eq 'scale' };
     return $glyph_name;
   };
  $self->_add_track($position,$features,-map=>$panel_map,-stylesheet=>$ss,-options=>\%options);
}

sub _add_track {
  my $self = shift;
  my ($position,$features,@options) = @_;

  # build the list of features into a Bio::Graphics::Feature object
  $features = [$features] unless ref $features eq 'ARRAY';

  # optional middle-level glyph is the group
  foreach my $f (grep {ref $_ eq 'ARRAY'} @$features) {
    next unless ref $f eq 'ARRAY';
    $f = Bio::Graphics::Feature->new(
				     -segments=>$f,
				     -type => 'group'
				    );
  }

  # top-level glyph is the track
  my $feature = Bio::Graphics::Feature->new(
					    -segments=>$features,
					    -start   => $self->offset+1,
					    -stop    => $self->offset+$self->length,
					    -type    => 'track'
					   );

  my $factory = Bio::Graphics::Glyph::Factory->new($self,@options);
  my $track   = $factory->make_glyph(-1,$feature);

  splice(@{$self->{tracks}},$position,0,$track);
  return $track;
}

sub _expand_padding {
  my $self   = shift;
  my $track  = shift;
  my $extra_padding = $self->extra_right_padding;

  my $keystyle          = $self->key_style;
  my $empty_track_style = $self->empty_track_style;

  return unless $keystyle eq 'left' or $keystyle eq 'right';
  return unless $self->auto_pad;

  $self->setup_fonts();
  my $width    = $self->{key_font}->width;

  my $key       = $self->track2key($track);
  return unless defined $key;

  my $has_parts = $track->parts;
  next if !$has_parts && $empty_track_style eq 'suppress';

  my $width_needed = $self->{key_font}->width * CORE::length($key)+3;
  if ($keystyle eq 'left') {
    my $width_i_have = $self->pad_left;
    $self->pad_left($width_needed)  if $width_needed > $width_i_have;
  } elsif ($keystyle eq 'right') {
    $width_needed += $extra_padding;
    my $width_i_have = $self->pad_right;
    $self->pad_right($width_needed) if $width_needed > $width_i_have;
  }
}

sub extra_right_padding { EXTRA_RIGHT_PADDING }

sub height {
  my $self = shift;
  $self->setup_fonts;

  for my $track (@{$self->{tracks}}) {
    $self->_expand_padding($track);
  }

  my $spacing           = $self->spacing;
  my $key_height        = $self->format_key;
  my $empty_track_style = $self->empty_track_style;
  my $key_style         = $self->key_style;
  my $bottom_key        = $key_style eq 'bottom';
  my $between_key       = $key_style eq 'between';
  my $side_key          = $key_style =~ /left|right/;
  my $draw_empty        = $empty_track_style =~ /^(line|dashed)$/;
  my $keyheight         = $self->{key_font}->height;
  my $height = 0;
  for my $track (@{$self->{tracks}}) {
    my $draw_between =  $between_key && $track->option('key');
    my $has_parts = $track->parts;
    next if !$has_parts && ($empty_track_style eq 'suppress'
		        or  $empty_track_style eq 'key' && $bottom_key);
    $height += $keyheight if $draw_between;
    $height += $self->spacing;
    my $layout_height = $track->layout_height;
    $height += ($side_key && $keyheight > $layout_height) ? $keyheight : $layout_height;
  }

  # get rid of spacing under last track
  $height -= $self->spacing unless $bottom_key;
  return $height + $key_height + $self->pad_top + $self->pad_bottom + 2;
}

sub setup_fonts {
  my $self = shift;
  return if ref $self->{key_font};

  my $image_class = $self->image_class;
  my $keyfont = $self->{key_font};
  my $font_obj = $image_class->$keyfont;
  $self->{key_font} = $font_obj;
}

sub gd {
  my $self        = shift;
  my $existing_gd = shift;

  local $^W = 0;  # can't track down the uninitialized variable warning

  return $self->{gd} if $self->{gd};

  $self->setup_fonts;

  unless ($existing_gd) {
    my $image_class = $self->image_class;
    eval "require $image_class; 1" or $self->throw($@);
  }

  my $height = $self->height;
  my $width  = $self->width + $self->pad_left + $self->pad_right;

  my $pkg = $self->image_package;

  $height = 12 if $height < 1; # so GD doesn't crash
  $width  = 1  if $width  < 1; # ditto

  my $gd  = $existing_gd || $pkg->new($width,$height,
				      ($self->{truecolor} && $pkg->can('isTrueColor') ? 1 : ())
				     );
  $gd->{debug} = 0 if $gd->isa('GD::SVG::Image'); # hack
  $self->{gd}  = $gd;

  if ($self->{truecolor}
      && $pkg->can('saveAlpha')) {
      $gd->saveAlpha(1);
  }

  my %translation_table;
  my $global_alpha = $self->{global_alpha} || 0;
  for my $name (keys %COLORS) {
    my $idx = $gd->colorAllocate(@{$COLORS{$name}});
    $translation_table{$name} = $idx;
  }

  $self->{translations} = \%translation_table;
  $self->{gd}           = $gd->isa('GD::SVG::Image') ? $gd
                        : $self->truetype            ? Bio::Graphics::GDWrapper->new($gd,$self->truetype)
			: $gd;

  eval {$gd->alphaBlending(0)};
  if ($self->bgcolor) {
    $gd->fill(0,0,$self->bgcolor);
  } elsif (eval {$gd->isTrueColor}) {
    $gd->fill(0,0,$translation_table{'white'});
  }
  eval {$gd->alphaBlending(1)};

  my $pl = $self->pad_left;
  my $pt = $self->pad_top;
  my $offset = $pt;
  my $keyheight   = $self->{key_font}->height;
  my $bottom_key  = $self->{key_style} eq 'bottom';
  my $between_key = $self->{key_style} eq 'between';
  my $left_key    = $self->{key_style} eq 'left';
  my $right_key   = $self->{key_style} eq 'right';
  my $empty_track_style = $self->empty_track_style;
  my $spacing = $self->spacing;

  # we draw in two steps, once for background of tracks, and once for
  # the contents.  This allows the grid to sit on top of the track background.
  for my $track (@{$self->{tracks}}) {
    my $draw_between = $between_key && $track->option('key');
    next if !$track->parts && ($empty_track_style eq 'suppress'
			   or  $empty_track_style eq 'key' && $bottom_key);
    $gd->filledRectangle($pl,
			 $offset,
			 $width-$self->pad_right,
			 $offset+$track->layout_height
			 + ($between_key ? $self->{key_font}->height : 0),
			 $track->tkcolor)
	if defined $track->tkcolor;
    $offset += $keyheight if $draw_between;
    $offset += $track->layout_height + $spacing;
  }

  $self->startGroup($gd);
  $self->draw_background($gd,$self->{background})  if $self->{background};
  $self->draw_grid($gd)                            if $self->{grid};
  $self->draw_background($gd,$self->{postgrid})    if $self->{postgrid};
  $self->endGroup($gd);

  $offset = $pt;
  for my $track (@{$self->{tracks}}) {
      $self->startGroup($gd);
      my $draw_between = $between_key && $track->option('key');
      my $has_parts = $track->parts;
      my $side_key_height = 0;

      next if !$has_parts && ($empty_track_style eq 'suppress'
			      or  $empty_track_style eq 'key' && $bottom_key);

      if ($draw_between) {
	  $offset += $self->draw_between_key($gd,$track,$offset);
      }

      $self->draw_empty($gd,$offset,$empty_track_style)
	  if !$has_parts && $empty_track_style=~/^(line|dashed)$/;

      $track->draw($gd,$pl,$offset,0,1);

      if ($self->{key_style} =~ /^(left|right)$/) {
	  $side_key_height = $self->draw_side_key($gd,$track,$offset,$self->{key_style});
      }

      $self->track_position($track,$offset);
      my $layout_height = $track->layout_height;
      $offset += ($side_key_height > $layout_height ? $side_key_height : $layout_height)+$spacing;

      $self->endGroup($gd);
  }


  $self->startGroup($gd);
  $self->draw_bottom_key($gd,$pl,$offset) if $self->{key_style} eq 'bottom';
  $self->endGroup($gd);

  return $self->{gd} = $self->rotate ? $gd->copyRotate90 : $gd;
}

sub gdfont {
    my $self = shift;
    my $font = shift;
    my $img_class = $self->image_class;

    if (!UNIVERSAL::isa($font,$img_class . '::Font') && $font =~ /^(gd|sanserif)/) {
	my $ref    = $self->{gdfonts} ||= {
	    gdTinyFont       => $img_class->gdTinyFont(),
	    gdSmallFont      => $img_class->gdSmallFont(),
	    gdMediumBoldFont => $img_class->gdMediumBoldFont(),
	    gdLargeFont      => $img_class->gdLargeFont(),
	    gdGiantFont      => $img_class->gdGiantFont(),
	    sanserif         => $img_class->gdSmallFont(),
	};
	return $ref->{$font} || $ref->{gdSmallFont};
    } else {
	return $font;
    }
}

sub string_width {
    my $self = shift;
    my ($font,$string) = @_;

    my $class = $self->image_class;

    return $font->width*CORE::length($string)
	unless $self->truetype && $class ne 'GD::SVG';
    return Bio::Graphics::GDWrapper->string_width($font,$string);
}

sub string_height {
    my $self = shift;
    my ($font,$string) = @_;

    my $class = $self->image_class;

    return $font->height
	unless $self->truetype
	&& eval{$class eq 'GD' || $class->isa('GD::Image')};

    return Bio::Graphics::GDWrapper->string_height($font,$string);
}

sub startGroup {
    my $self = shift;
    my $gd   = shift;
    $gd->startGroup if $gd->can('startGroup');
}

sub endGroup {
    my $self = shift;
    my $gd   = shift;
    $gd->endGroup if $gd->can('endGroup');
}


# Package accessors
# GD (and GD::SVG)'s new() resides in GD::Image
sub image_class     { return shift->{image_class}; }
sub image_package   { return shift->{image_package}; }
sub polygon_package { return shift->{polygon_package}; }

sub boxes {
  my $self = shift;

  if (my $boxes = $self->{boxes}){ # cached result
    return wantarray ? @$boxes : $boxes;
  }

  my @boxes;
  my $offset = 0;

  $self->setup_fonts;

  my $pl = $self->pad_left;
  my $pt = $self->pad_top;

  my $between_key       = $self->{key_style} eq 'between';
  my $bottom_key        = $self->{key_style} eq 'bottom';
  my $empty_track_style = $self->empty_track_style;
  my $keyheight         = $self->{key_font}->height;
  my $spacing = $self->spacing;
  my $rotate  = $self->rotate;

  for my $track (@{$self->{tracks}}) {
    my $draw_between =  $between_key && $track->option('key');
    next if !$track->parts && ($empty_track_style eq 'suppress'
			    or  $empty_track_style eq 'key' && $bottom_key);
    $offset += $keyheight if $draw_between;
    my $height = $track->layout_height;
    my $boxes  = $track->boxes($pl,$offset+$pt);
    $self->track_position($track,$offset);
    push @boxes,@$boxes;
    $offset += $track->layout_height + $self->spacing;
  }

  if ($rotate) {
      my $x_offset = $self->height-1;
      @boxes = map {
	  @{$_}[1,2,3,4]    = @{$_}[4,1,2,3];
	  ($_->[1],$_->[3]) = map {$x_offset - $_} @{$_}[1,3];
	  $_;
      } @boxes;
  }
  $self->{boxes} = \@boxes;
  return wantarray ? @boxes : \@boxes;
}

sub track_position {
  my $self  = shift;
  my $track = shift;
  my $d = $self->{_track_position}{$track};
  $self->{_track_position}{$track} = shift if @_;
  $d;
}

# draw the keys -- between
sub draw_between_key {
  my $self   = shift;
  my ($gd,$track,$offset) = @_;
  my $key = $self->track2key($track) or return 0;
  my $x =   $self->{key_align} eq 'center' ? $self->width - (CORE::length($key) * $self->{key_font}->width)/2
          : $self->{key_align} eq 'right'  ? $self->width - CORE::length($key)
          : $self->pad_left;

  # Key color hard-coded. Should be configurable for the control freaks.
  my $color = $self->translate_color('black');
  $gd->string($self->{key_font},$x,$offset,$key,$color) unless $self->{suppress_key};
  $self->add_key_box($track,$key,$x,$offset);
  return $self->{key_font}->height;
}

# draw the keys -- left or right side
sub draw_side_key {
  my $self   = shift;
  my ($gd,$track,$offset,$side) = @_;
  my $key = $self->track2key($track) or return;
  my $pos = $side eq 'left' ? $self->pad_left - $self->{key_font}->width * CORE::length($key)-3
                            : $self->pad_left + $self->width + EXTRA_RIGHT_PADDING;
  my $color = $self->translate_color('black');
  unless ($self->{suppress_key}) {
      $gd->filledRectangle($pos,$offset,
			   $pos+$self->{key_font}->width*CORE::length($key),$offset,#-$self->{key_font}->height)/2,
			   $self->bgcolor);
      $gd->string($self->{key_font},$pos,$offset,$key,$color);
  }
  $self->add_key_box($track,$key,$pos,$offset);
  return $self->{key_font}->height;
}

# draw the keys -- bottom
sub draw_bottom_key {
  my $self = shift;
  my ($gd,$left,$top) = @_;
  my $key_glyphs = $self->{key_glyphs} or return;

  my $color = $self->translate_color($self->{key_color});
  $gd->filledRectangle($left,$top,$self->width - $self->pad_right,$self->height-$self->pad_bottom,$color);
  my $text_color = $self->translate_color('black');
  $gd->string($self->{key_font},$left,KEYPADTOP+$top,"KEY:",$text_color)  unless $self->{suppress_key};
  $top += $self->{key_font}->height + KEYPADTOP;
  $_->draw($gd,$left,$top) foreach @$key_glyphs;
}

# Format the key section, and return its height
sub format_key {
  my $self = shift;
  return 0 unless $self->key_style eq 'bottom';

  return $self->{key_height} if defined $self->{key_height};

  my $suppress = $self->{empty_track_style} eq 'suppress';
  my $between  = $self->{key_style}         eq 'between';

  if ($between) {
    my @key_tracks = $suppress
      ? grep {$_->option('key') && $_->parts} @{$self->{tracks}}
      : grep {$_->option('key')} @{$self->{tracks}};
    return $self->{key_height} = @key_tracks * $self->{key_font}->height;
  }

  elsif ($self->{key_style} eq 'bottom') {

    my ($height,$width) = (0,0);
    my %tracks;
    my @glyphs;
    local $self->{flip} = 0;  # don't want to worry about flipped keys!

    # determine how many glyphs become part of the key
    # and their max size
    for my $track (@{$self->{tracks}}) {

      next unless $track->option('key');
      next if $suppress && !$track->parts;

      my $glyph;
      if (my @parts = $track->parts) {
	$glyph = $parts[0]->keyglyph;
      } else {
	my $t = Bio::Graphics::Feature->new(-segments=>
					    [Bio::Graphics::Feature->new(-start => $self->offset,
									 -stop  => $self->offset+$self->length)]);
	my $g = $track->factory->make_glyph(0,$t);
	$glyph = $g->keyglyph;
      }
      next unless $glyph;


      $tracks{$track} = $glyph;
      my ($h,$w) = ($glyph->layout_height,
		    $glyph->layout_width);
      $height = $h if $h > $height;
      $width  = $w if $w > $width;
      push @glyphs,$glyph;

    }

    $width += $self->key_spacing;

    # no key glyphs, no key
    return $self->{key_height} = 0 unless @glyphs;

    # now height and width hold the largest glyph, and $glyph_count
    # contains the number of glyphs.  We will format them into a
    # box that is roughly 3 height/4 width (golden mean)
    my $rows = 0;
    my $cols = 0;
    my $maxwidth = $self->width - $self->pad_left - $self->pad_right;
    while (++$rows) {
      $cols = @glyphs / $rows;
      $cols = int ($cols+1) if $cols =~ /\./;  # round upward for fractions
      my $total_width  = $cols * $width;
      my $total_height = $rows * $width;
      last if $total_width < $maxwidth;
    }

    # move glyphs into row-major format
    my $spacing = $self->key_spacing;
    my $i = 0;
    for (my $c = 0; $c < $cols; $c++) {
      for (my $r = 0; $r < $rows; $r++) {
	my $x = $c * ($width  + $spacing);
	my $y = $r * ($height + $spacing);
	next unless defined $glyphs[$i];
	$glyphs[$i]->move($x,$y);
	$i++;
      }
    }

    $self->{key_glyphs} = \@glyphs;     # remember our key glyphs
    # remember our key height
    return $self->{key_height} =
      ($height+$spacing) * $rows + $self->{key_font}->height +KEYPADTOP;
  }

  else {  # no known key style, neither "between" nor "bottom"
    return $self->{key_height} = 0;
  }
}

sub add_key_box {
  my $self = shift;
  my ($track,$label,$x,$y, $is_legend) = @_;
  my $value = [$label,$x,$y,$x+$self->{key_font}->width*CORE::length($label),$y+$self->{key_font}->height,$track];
  push @{$self->{key_boxes}},$value;
}

sub key_boxes {
  my $ref  = shift->{key_boxes};
  return wantarray ? @$ref : $ref;
}

sub add_category_labels {
  my $self = shift;
  my $d    = $self->{add_category_labels};
  $self->{add_category_labels} = shift if @_;
  $d;
}

sub track2key {
  my $self = shift;
  my $track = shift;
  return $track->make_key_name();
}

sub draw_empty {
  my $self  = shift;
  my ($gd,$offset,$style) = @_;
  $offset  += $self->spacing/2;
  my $left  = $self->pad_left;
  my $right = $self->width-$self->pad_right;
  my $color = $self->translate_color(MISSING_TRACK_COLOR);
  my $ic    = $self->image_class;
  if ($style eq 'dashed') {
    $gd->setStyle($color,$color,$ic->gdTransparent(),$ic->gdTransparent());
    $gd->line($left,$offset,$right,$offset,$ic->gdStyled());
  } else {
    $gd->line($left,$offset,$right,$offset,$color);
  }
  $offset;
}

# draw a grid
sub draw_grid {
  my $self = shift;
  my $gd = shift;

  my $gridcolor      = $self->translate_color($self->{gridcolor});
  my $gridmajorcolor = $self->translate_color($self->{gridmajorcolor});
  my @positions;
  my ($major,$minor);
  if (ref $self->{grid} eq 'ARRAY') {
    @positions = @{$self->{grid}};
  } else {
    ($major,$minor) = $self->ticks;
    my $first_tick = $minor * int($self->start/$minor);
    for (my $i = $first_tick; $i <= $self->end+1; $i += $minor) {
      push @positions,$i;
    }
  }
  my $pl = $self->pad_left;
  my $pt = $self->extend_grid ? 0 : $self->pad_top;
  my $pr = $self->right;
  my $pb = $self->extend_grid ? $self->height : $self->height - $self->pad_bottom;
  my $offset = $self->{offset}+$self->{length}+1;
  for my $tick (@positions) {
    my ($pos) = $self->map_pt($self->{flip} ? $offset - $tick
                                            : $tick);
    my $color = (defined $major && $tick % $major == 0) ? $gridmajorcolor : $gridcolor;
    $gd->line($pl+$pos,$pt,$pl+$pos,$pb,$color);
  }
}

# draw an image (or invoke a drawing routine)
sub draw_background {
  my $self = shift;
  my ($gd,$image_or_routine) = @_;
  if (ref $image_or_routine eq 'CODE') {
    return $image_or_routine->($gd,$self);
  }
  if (-f $image_or_routine) { # a file to draw
    my $method = $image_or_routine =~ /\.png$/i   ? 'newFromPng'
               : $image_or_routine =~ /\.jpe?g$/i ? 'newFromJpeg'
               : $image_or_routine =~ /\.gd$/i    ? 'newFromGd'
               : $image_or_routine =~ /\.gif$/i   ? 'newFromGif'
               : $image_or_routine =~ /\.xbm$/i   ? 'newFromXbm'
	       : '';
    return unless $method;
    my $image = eval {$self->image_package->$method($image_or_routine)};
    unless ($image) {
      warn $@;
      return;
    }
    my ($src_width,$src_height) = $image->getBounds;
    my ($dst_width,$dst_height) = $gd->getBounds;
    # tile the thing on
    for (my $x = 0; $x < $dst_width; $x += $src_width) {
      for (my $y = 0; $y < $dst_height; $y += $src_height) {
	$gd->copy($image,$x,$y,0,0,$src_width,$src_height);
      }
    }
  }
}

# calculate major and minor ticks, given a start position
sub ticks {
  my $self = shift;
  my ($length,$minwidth) = @_;

  my $img = $self->image_class;
  $length   = $self->{length}             unless defined $length;
  $minwidth = $img->gdSmallFont->width*7  unless defined $minwidth;

  my ($major,$minor);

  # figure out tick mark scale
  # we want no more than 1 major tick mark every 40 pixels
  # and enough room for the labels
  my $scale = $self->scale;

  my $interval = 10;

  while (1) {
    my $pixels = $interval * $scale;
    last if $pixels >= $minwidth;
    $interval *= 10;
  }

  # to make sure a major tick shows up somewhere in the first half
  #
  # $interval *= .5 if ($interval > 0.5*$length);

  return ($interval,$interval/10);
}

# reverse of translate(); given index, return rgb triplet
sub rgb {
  my $self = shift;
  my $idx  = shift;
  my $gd = $self->{gd} or return;
  return $gd->rgb($idx);
}

sub transparent_color {
    my $self = shift;
    my ($opacity,@colors) = @_;
    return $self->_translate_color($opacity,@colors);
}

sub translate_color {
    my $self = shift;
    my @colors = @_;
    return $self->_translate_color(1.0,@colors);
}

sub _translate_color {
  my $self    = shift;
  my ($opacity,@colors)  = @_;
  $opacity    = '1.0' if $opacity == 1;
  my $default_alpha   = $self->adjust_alpha($opacity);
  $default_alpha    ||= 0;

  my $ckey = "@{colors}_${default_alpha}";
  return $self->{closestcache}{$ckey} if exists $self->{closestcache}{$ckey};

  my $index;
  my $gd    = $self->gd             or return 1;
  my $table = $self->{translations} or return 1;

  if (@colors == 3) {
      $index = $gd->colorAllocateAlpha(@colors,$default_alpha);
  }
  elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
    my ($r,$g,$b,$alpha) = (hex($1),hex($2),hex($3),hex($4));
    $index = $gd->colorAllocateAlpha($r,$g,$b,$alpha);
  }
  elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
    my ($r,$g,$b) = (hex($1),hex($2),hex($3));
    $index = $gd->colorAllocateAlpha($r,$g,$b,$default_alpha);
  }
  elsif ($colors[0] =~ /^(\d+),(\d+),(\d+),([\d.]+)$/i ||
	 $colors[0] =~ /^rgba\((\d+),(\d+),(\d+),([\d.]+)\)$/) {
      my $alpha = $self->adjust_alpha($4);
      my (@rgb) = map {/(\d+)%/ ? int(255 * $1 / 100) : $_} ($1,$2,$3);
      $index = $gd->colorAllocateAlpha(@rgb,$4);
  }
  elsif ($colors[0] =~ /^(\d+),(\d+),(\d+)$/i ||
	 $colors[0] =~ /^rgb\((\d+),(\d+),(\d+)\)$/i
      ) {
      my (@rgb) = map {/(\d+)%/ ? int(255 * $1 / 100) : $_} ($1,$2,$3);
      $index = $gd->colorAllocateAlpha(@rgb,$default_alpha);
  }
  elsif ($colors[0] eq 'transparent') {
      $index = $gd->colorAllocateAlpha(255,255,255,127);
  }
  elsif ($colors[0] =~ /^(\w+):([\d.]+)/) {  # color:alpha
      my @rgb   = $self->color_name_to_rgb($1);
      @rgb      = (0,0,0) unless @rgb;
      my $alpha = $self->adjust_alpha($2);
      $index = $gd->colorAllocateAlpha(@rgb,$alpha);
  }
  elsif ($default_alpha < 127) {
      my @rgb   = $self->color_name_to_rgb($colors[0]);
      @rgb      = (0,0,0) unless @rgb;
      $index    = $gd->colorAllocateAlpha(@rgb,$default_alpha);
  }
  else {
      $index = defined $table->{$colors[0]} ? $table->{$colors[0]} : 1;
  }
  return $self->{closestcache}{$ckey} = $index;
}

# change CSS opacity values (0-1.0) into GD opacity values (127-0)
sub adjust_alpha {
    my $self  = shift;
    my $value = shift;
    my $alpha = $value =~ /\./ # floating point
	          ? int(127-($value*127)+0.5)
		  : $value;
    $alpha    = 0   if $alpha < 0;
    $alpha    = 127 if $alpha > 127;
    return $alpha;
}

# workaround for bad GD
sub colorClosest {
  my ($self,$gd,@c) = @_;
  return $gd->colorResolve(@c) if $GD::VERSION < 2.04;

  my $index = $gd->colorResolve(@c);
  return $index if $index >= 0;

  my $value;
  for (keys %COLORS) {
    my ($r,$g,$b) = @{$COLORS{$_}};
    my $dist = ($r-$c[0])**2 + ($g-$c[1])**2 + ($b-$c[2])**2;
    ($value,$index) = ($dist,$_) if !defined($value) || $dist < $value;
  }
  return $self->{translations}{$index};
}

sub bgcolor {
   my $self = shift;
   return unless $self->{bgcolor};
   return $self->translate_color($self->{bgcolor});
}

sub set_pen {
  my $self = shift;
  my ($linewidth,$color) = @_;
  return $self->{pens}{$linewidth,$color} if $self->{pens}{$linewidth,$color};
  my $gd = $self->{gd};
  my $pkg = $self->image_package;
  my $pen = $self->{pens}{$linewidth} = $pkg->new($linewidth,$linewidth);
  my @rgb = $self->rgb($color);
  my $bg = $pen->colorAllocate(255,255,255);
  my $fg = $pen->colorAllocate(@rgb);
  $pen->fill(0,0,$fg);
  $gd->setBrush($pen);
  return $self->image_class->gdBrushed();
}

sub png {
  my $gd = shift->gd;
  $gd->png;
}

sub svg {
  my $gd = shift->gd;
  $gd->svg;
}


# WARNING: THIS STUFF IS COPIED FROM Bio::Graphics::Browser.pm AND
# Bio::Graphics::FeatureFile AND MUST BE REFACTORED
# write a png image to disk and generate an image map in a convenient
# CGIish way.
sub image_and_map {
  my $self        = shift;
  my %args        = @_;
  my $link_rule   = $args{-link}    || $self->{linkrule};
  my $title_rule  = $args{-title}   || $self->{titlerule};
  my $target_rule = $args{-target}  || $self->{targetrule};
  my $tmpurl      = $args{-url}     || '/tmp';
  my $docroot     = $args{-root}    || $ENV{DOCUMENT_ROOT} || '';
  my $mapname     = $args{-mapname} || $IMAGEMAP++;
  $docroot       .= '/' if $docroot && $docroot !~ m!/$!;

  # get rid of any netstat part please
  (my $tmpurlbase = $tmpurl) =~ s!^\w+://[^/]+!!;

  my $tmpdir    = "${docroot}${tmpurlbase}";

  my $url       = $self->create_web_image($tmpurl,$tmpdir);
  my $map       = $self->create_web_map($mapname,$link_rule,$title_rule,$target_rule);
  return ($url,$map,$mapname);
}

sub create_web_image {
  my $self             = shift;
  my ($tmpurl,$tmpdir) = @_;

  # create directory if it isn't there already
  # we need to untaint tmpdir before calling mkpath()
  return unless $tmpdir =~ /^(.+)$/;
  my $path = $1;
  unless (-d $path) {
    require File::Path unless defined &File::Path::mkpath;
    File::Path::mkpath($path,0,0777) or $self->throw("Couldn't create temporary image directory $path: $!");
  }

  unless (defined &Digest::MD5::md5_hex) {
    eval "require Digest::MD5; 1"
      or $self->throw("Sorry, but the image_and_map() method requires the Digest::MD5 module.");
  }
  my $data      = $self->png;
  my $signature = Digest::MD5::md5_hex($data);
  my $extension = 'png';

  # untaint signature for use in open
  $signature =~ /^([0-9A-Fa-f]+)$/g or return;
  $signature = $1;

  my $url         = sprintf("%s/%s.%s",$tmpurl,$signature,$extension);
  my $imagefile   = sprintf("%s/%s.%s",$tmpdir,$signature,$extension);

  open (my $F,">", $imagefile) || $self->throw("Can't open image file $imagefile for writing: $!\n");
  binmode($F);
  print $F $data;

  return $url;
}

sub create_web_map {
  my $self     = shift;
  my ($name,$linkrule,$titlerule,$targetrule) = @_;
  $name ||= 'map';
  my $boxes    = $self->boxes;
  my (%track2link,%track2title,%track2target);

  eval "require CGI" unless CGI->can('escapeHTML');

  my $map = qq(\n);
  foreach (@$boxes){
    my ($feature,$left,$top,$right,$bottom,$track) = @$_;
    next unless $feature->can('primary_tag');

    my $lr  = $track2link{$track} ||= (defined $track->option('link') ? $track->option('link') : $linkrule);
    next unless   $lr;

    my $tr   = exists $track2title{$track}
      ? $track2title{$track}
      : $track2title{$track} ||= (defined $track->option('title')  ? $track->option('title')  : $titlerule);
    my $tgr  = exists $track2target{$track}
      ? $track2target{$track}
      : $track2target{$track} ||= (defined $track->option('target')? $track->option('target')  : $targetrule);

    my $href   = $self->make_link($lr,$feature);
    my $title  = CGI::escapeHTML($self->make_link($tr,$feature,1));
    my $target = CGI::escapeHTML($self->make_link($tgr,$feature,1));


    my $a      = $title  ? qq(title="$title") : '';
    my $t      = $target ? qq(target="$target")        : '';
    $map .= qq(\n) if $href;
  }
  $map .= "\n";
  $map;
}

sub make_link {
  my $self = shift;
  my ($linkrule,$feature,$escapeHTML) = @_;
  eval "require Bio::Graphics::FeatureFile;1"
    unless Bio::Graphics::FeatureFile->can('link_pattern');
  return Bio::Graphics::FeatureFile->link_pattern($linkrule,$feature,$self,$escapeHTML);
}

sub make_title {
  my $self = shift;
  my $feature = shift;
  eval "require Bio::Graphics::FeatureFile;1"
    unless Bio::Graphics::FeatureFile->can('make_title');
  return Bio::Graphics::FeatureFile->make_title($feature);
}

sub read_colors {
  my $class = shift;
  local ($/) = "\n";
  local $_;
  while () {
    chomp;
    last if /^__END__/;
    my ($name,$r,$g,$b) = split /\s+/;
    @{$COLORS{$name}} = (hex $r,hex $g, hex $b);
  }
}

sub color_name_to_rgb {
  my $class = shift;
  my $color_name  = shift;
  $class->read_colors() unless %COLORS;
  return unless $COLORS{$color_name};
  return wantarray ? @{$COLORS{$color_name}}
                   : $COLORS{$color_name};
}

sub color_names {
    my $class = shift;
    $class->read_colors unless %COLORS;
    return wantarray ? keys %COLORS : [keys %COLORS];
}

sub glyph_scratch {
    my $self = shift;
    my $d = $GlyphScratch;
    $GlyphScratch = shift if @_;
    $d;
}

sub finished {
    my $self = shift;
    for my $track (@{$self->{tracks} || []}) {
	$track->finished();
    }
    delete $self->{tracks};
}

1;

__DATA__