#!/usr/bin/env perl
#
# heatmap - converts a matrix of numeric values of some given size
# into a heat map. The first line must be a width and a height, and
# the subsequent lines integer values for each row and column of the
# given width, e.g. the input of
#
# 4 1
# 1 2 3 4
#
# indicates four columns and one row, followed by one line with the
# column values. Negative values are marked with black on the resulting
# image, positive values with a range of hues from blue to red.
use 5.14.0;
use warnings;
use Getopt::Std 'getopts';
use Imager;
use constant { NO_HEAT => -1, };
my %options = (
# Use -F '' to turn off the numeric labels.
F => '/usr/local/share/fonts/unifont/unifont.ttf',
b => 32, # Box (or cell) size.
f => 'out.png', # Output file.
s => 1.0, # Saturation (for HSV).
#m => Use $min = 0 instead of that from the input.
#q => Be quiet about various things.
);
getopts( 'F:b:f:m', \%options )
or die "heatmap: unknown option supplied\n";
#use Data::Dumper; warn Dumper \%options;
my $font;
if ( length $options{F} ) {
$font = Imager::Font->new( file => $options{F} )
or die "heatmap: no such font '$options{F}'\n";
}
my ( $matrix_width, $matrix_height, @matrix );
my $header = readline;
if ( $header =~ m/^(?a)(\d+) (\d+)$/ ) {
( $matrix_width, $matrix_height ) = ( $1, $2 );
} else {
die "heatmap: need a width and a height\n";
}
my $min = ~0;
my $max = 0;
########################################################################
#
# PARSE INPUT
# Read from standard in or all files listed on the command line.
while (readline) {
chomp;
my @nums;
LOOP: {
# Allow for an optional leading whitespace if someone is doing
# printf("% 3d", ...) or such.
redo LOOP if /\G^\s+/cg;
# Each column must be followed by whitespace, or the end
# of the line.
if (/\G(?a)(-?\d+)(?:\s+|$)/cg) {
my $n = $1;
# Negative values are assumed to block the heat map (walls);
# that is, they have NO_HEAT.
if ( $n < 0 ) { ; }
elsif ( $n < $min ) { $min = $n }
elsif ( $n > $max ) { $max = $n }
push @nums, $n;
redo LOOP;
}
last LOOP if /\G$/cg;
# ... or it's invalid.
my $where = pos();
my $span = (' ') x $where;
die "heatmap: invalid line $ARGV:$. offset $where\n$_\n$span^\n";
}
my $ncol = @nums;
die
"heatmap: bad column count line $ARGV:$. got $ncol expect $matrix_width\n"
if $ncol != $matrix_width;
push @matrix, \@nums;
} continue {
close ARGV if eof;
}
my $nrows = @matrix;
die "heatmap: bad row count: got $nrows expect $matrix_height\n"
if $nrows != $matrix_height;
$min = 0 if exists $options{m};
warn "notice: range - $min .. $max\n" unless exists $options{q};
#use Data::Dumper; warn Dumper \@matrix;
########################################################################
#
# OUTPUT IMAGE
# Need +1 for the grid lines.
my ( $image_width, $image_height ) = (
$options{b} * $matrix_width + 1,
$options{b} * $matrix_height + 1
);
my $image = Imager->new(
xsize => $image_width,
ysize => $image_height,
) or die "heatmap: " . Imager->errstr;
# Hue - blue 240, red 360. TODO probably want flags for this, or an
# option for greyscale?
my $convert = slopeinator( $min, 240, $max, 360 );
# TODO the label font size may need a flag
my $font_size = int( $options{b} / 2 );
if ( $font_size < 9 ) {
warn "notice: font size $font_size is too small for labels\n"
unless exists $options{q};
$font = '';
}
my @black_white = map { Imager::Color->new($_) } '#000000', '#FFFFFF';
my $grid_line_color = Imager::Color->new('#333333');
vgridline(0);
hgridline(0);
my $yy = 1;
for my $r ( 0 .. $matrix_height - 1 ) {
my $xx = 1;
for my $c ( 0 .. $matrix_width - 1 ) {
my $box_color = cell_color( $matrix[$r][$c] );
draw_box( $yy, $xx, $options{b}, $box_color );
numeric_label( $yy, $xx, $box_color, $matrix[$r][$c] )
if defined $font and $matrix[$r][$c] >= 0;
$xx += $options{b};
hgridline( $xx - 1 );
}
$yy += $options{b};
vgridline( $yy - 1 );
}
$image->write( file => $options{f} );
sub cell_color {
my ($amount) = @_;
my $color;
if ( $amount <= NO_HEAT ) {
$color = $black_white[0];
} else {
my $hh = $convert->($amount);
$color = Imager::Color->new(
hue => $hh,
value => 1,
saturation => $options{s}
);
}
return $color;
}
sub draw_box {
my ( $yy, $xx, $size, $color ) = @_;
$image->box(
color => $color,
filled => 1,
ymin => $yy,
xmin => $xx,
ymax => $yy + $size,
xmax => $xx + $size,
);
}
sub hgridline {
$image->line(
color => $grid_line_color,
endp => 0,
x1 => $_[0],
x2 => $_[0],
y1 => 0,
y2 => $image_height,
);
}
sub vgridline {
$image->line(
color => $grid_line_color,
endp => 0,
x1 => 0,
x2 => $image_width,
y1 => $_[0],
y2 => $_[0],
);
}
sub numeric_label {
my ( $yy, $xx, $color, $amount ) = @_;
$image->string(
aa => 1,
x => $xx + 1,
y => $yy + $options{b} - 3,
# Try to keep the label color visible regardless of what
# it's put on.
color => ( $color->hsv )[2] > 0.5 ? $black_white[0] : $black_white[1],
font => $font,
size => $font_size,
string => $amount,
);
}
# y=mx+b equation maker from the two given points.
sub slopeinator {
my ( $x1, $y1, $x2, $y2 ) = @_;
die "heatmap: not much of a range to show\n" if $x1 == $x2;
my $mm = ( $y2 - $y1 ) / ( $x2 - $x1 );
my $bb = $y2 - $mm * $x2;
sub { $mm * $_[0] + $bb };
}
gemini://thrig.me/blog/2024/03/11/heatmap.pl