File Coverage

blib/lib/Image/Timeline.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Image::Timeline;

use strict;
use GD;

# Not a required module, but try to load at compile time
BEGIN {eval "use Date::Format"}

use vars qw($VERSION);
$VERSION = 0.11;

sub new {
  my ($pkg, %args) = @_;
  my $self = {
	      width => 900,
	      font => gdTinyFont,
	      bar_stepsize => 50,  # The gridsize for the top reference bar
	      vspacing => 2,
	      hmargin => 3,
	      bg_color => [255,255,255],
	      bar_color => [255,0,0],
	      endcap_color => [0,155,0],
	      legend_color => [0,0,0],
	      text_color => [0,0,0],
	      date_format => '',
	      to_string => sub { $_[0] },
	      right_margin => 0,
	      %args
	     };

  # subtract right_margin to width to avoid cutting last legend
  $self->{width} -= $self->{right_margin};
  return bless $self, $pkg;
}

sub add {
  my ($self, $label, $start, $end) = @_;

  $self->{data}{$label}{start} = $start;
  $self->{data}{$label}{end}   = $end;
}

sub write {
  my ($self, $format, $filename, @args) = @_;

  my $image = $self->draw;

  local *OUT;
  open OUT, ">$filename" or die "Can't create '$filename': $!";
  binmode(OUT);
  print OUT $image->$format(@args);
  close OUT;
}

sub write_png { my $s = shift; $s->write('png', @_) }
sub write_gif { my $s = shift; $s->write('gif', @_) }

sub _create_image {
  my ($self, $w, $h) = @_;
  my $image = GD::Image->new($w + $self->{right_margin},$h);

  # Allocate some colors
  foreach (qw(bg bar endcap legend text)) {
    $self->{colors}{$_} = $image->colorAllocate(@{$self->{"${_}_color"}});
  }
  $image->fill(0,0,$self->{colors}{bg});

  return $image;
}

sub _create_channels {
  my ($self) =  @_;

  my $data = $self->{data};
  my $channels = $self->{channels} = [];

  # Populate the channels
 LOOP: foreach my $label (sort {$data->{$a}{'start'} <=> $data->{$b}{'start'}} keys %$data) {
    #warn "Inserting '$label'";
    # Check each channel to find an empty space:
    foreach my $channel (@$channels) {
      if ($self->_channel_is_free($channel, $data->{$label}{'start'})) {
	$self->_add_to_channel($channel, $label);
	#warn "Adding '$label' to existing channel $channel";
	next LOOP;
      }
    }

    # All channels are full for this start-time.  Make a new channel.
    push @$channels, my $new = {};
    $self->_add_to_channel($new, $label);
    #warn "Adding '$label' to new channel";
  }
}

sub _minmax {
  # Find min & max dates
  my ($self) = @_;
  return ($self->{min}, $self->{max}) if exists $self->{min};

  my ($min,$max) = map {$_->{start}, $_->{end}} (each %{$self->{channels}[0]})[1];
  foreach my $channel (@{$self->{channels}}) {
    foreach my $entry (values %$channel) {
      if ($entry->{start} < $min) {$min = $entry->{start}}
      if ($entry->{end}   > $max) {$max = $entry->{end}}
    }
  }
  return ($self->{min}, $self->{max}) = ($min, $max);
}

sub draw_legend {
  # Draw the top legend bar
  my ($self, $image) = @_;
  my ($min, $max) = $self->_minmax;
  my $color = $self->{colors}{legend};

  my $step = $self->{bar_stepsize}; # For convenience
  if ($step =~ /^(\d+)%$/) { # Convert from percentage
    $step = ($max - $min) * $1 / 100;
  }

  my $start_at = int($min/$step) * $step;
  for (my $i=$start_at; $i <= $max + $step; $i += $step) {
    $image->line($self->_convert($i), 2, $self->_convert($i), 8, $color);
    my $label = $self->{date_format} ? $self->_UTC_to_string($i) : $self->{to_string}->($i);
    $image->string($self->{font}, $self->_convert($i)+1, 4, $label, $color);
  }

  # Long top line
  $image->line($self->_convert($start_at), 2, $self->_convert((int($max/$step)+1) * $step) + $self->{right_margin}, 2, $color);
}

sub _convert {
  # A little baroque ... converts date to x-value
  my ($self, $time) = @_;
  return (   $time     - $self->{min}) * ($self->{width}-2*$self->{hmargin})
       / ($self->{max} - $self->{min})
       + $self->{hmargin};
}

sub draw_channels {
  my ($self, $image) = @_;
  my ($fheight, $fwidth) = ($self->{font}->height,$self->{font}->width);

  my $y;
  foreach my $channel ({}, @{$self->{channels}}) {  # leave an empty channel at the top
    $y += $self->{height}/(@{$self->{channels}} + 2);

    # Need to draw them in order to avoid collisions
    my @labels = sort {$channel->{$a}{start} <=> $channel->{$b}{start}} keys %$channel;
    my $above = 0;
    foreach my $i (0..$#labels) {
      my $label = $labels[$i];
      my $x_start = $self->_convert($channel->{$label}{start});
      my $x_end   = $self->_convert($channel->{$label}{end});

      # Draw the long line:
      $image->line($x_start, $y, $x_end, $y, $self->{colors}{bar});

      # Draw the endcaps:
      $image->line($x_start, $y-1, $x_start, $y+1, $self->{colors}{endcap});
      $image->line($x_end,   $y-1, $x_end,   $y+1, $self->{colors}{endcap});

      # Write the label (above the bar if it would collide)
      if ($above)                                                           { $above = 0 }
      elsif (!defined $labels[$i+1])                                        { $above = 0 }
      elsif (length($label) * $fwidth >
	     $self->_convert($channel->{$labels[$i+1]}{start}) - $x_start)  { $above = 1 }
      else                                                                  { $above = 0 }

      my $string_y = ($above ?
		      $y - $fheight - 1 :
		      $y + 1);
      $image->string($self->{font}, $x_start, $string_y, $label, $self->{colors}{text});
    }
  }
}

sub draw {
  my ($self) = @_;

  $self->_create_channels;

  # Add 2 to leave room for header
  my $fheight = $self->{font}->height;
  $self->{height} = (@{$self->{channels}} + 2) * (2*$fheight + $self->{vspacing});

  my $image = $self->_create_image($self->{width}, $self->{height});
  $self->draw_legend($image);
  $self->draw_channels($image);

  return $image;
}

sub _channel_is_free {
  my ($self, $channel, $time) = @_;

  # Step through the entries in this channel:
  foreach my $data (values %$channel) {
    return 0 if ($data->{start} <= $time
		  and
		 $data->{end}   >= $time);
  }

  return 1;
}

sub _add_to_channel {
  my ($self, $channel, $label) = @_;

  foreach (qw(start end)) {
    $channel->{$label}{$_} = $self->{data}{$label}{$_};
  }
}

sub _UTC_to_string {
  my ($self,$UTC) = @_;

  require Date::Format;
  return  Date::Format::time2str($self->{date_format}, $UTC);
}

1;
__END__