Graphics-HotMap
view release on metacpan or search on metacpan
lib/Graphics/HotMap.pm view on Meta::CPAN
#!/usr/bin/perl -w
# Copyright (c) 2011 Mathieu Alorent
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
package Graphics::HotMap;
use strict;
=head1 NAME
Graphics::HotMap -- generate thermographic images.
=head1 SYNOPSIS
=for example
use Graphics::HotMap;
# Create a new HotMap
my $hotMap = Graphics::HotMap->new(
minValue => 1,
maxValue => 50,
);
# Define scale
$hotMap->scale(20);
# Show legend
$hotMap->legend(1);
# Show CrossMarks and values
$hotMap->crossMark(1,1);
# Define a new size
$hotMap->mapSize({ sizeX => 15, sizeY => 15 });
# Add time
$hotMap->addHorodatage(time, 15, 30);
# Add layer
$hotMap->addLayer({ layerName => '10_back', visibility => 1, sliceColor => 1 });
# Add a zone
$hotMap->addZone({
zoneName => 'AllMap',
layerName => '10_back',
coordonates => [0,0,14,14],
border => 1,
});
# And add some points
$hotMap->addPoint({ layerName => '10_back', x => 2, y => 2, value => 15 });
$hotMap->addPoint({ layerName => '10_back', x => 1, y => 6, value => 5 });
$hotMap->addPoint({ layerName => '10_back', x => 9, y => 13, value => 25 });
$hotMap->addLayer({ layerName => '20_inner' });
# Add a zone
$hotMap->addZone({
zoneName => 'innerZone',
layerName => '20_inner',
coordonates => [4,0,9,6],
border => 1,
text => 'Inner Zone',
});
# And some points
$hotMap->addPoint({ layerName => '20_inner', x => 5, y => 1, value => 1 });
$hotMap->addPoint({ layerName => '20_inner', x => 6, y => 5, value => 9 });
# You can also prepare conf as a Hash, ...
my %other = (
layers => {
'30_anotherLayer' => {
visibility => 0,
sliceColors => 1,
},
'40_anotherLayer' => {
visibility => 0,
sliceColors => 0,
},
},
zones => {
anotherZone => {
layerName => '30_anotherLayer',
coordonates => [7,4,10,9],
border => 1,
text => 'other layer',
textSize => 8,
textColor => 'magenta',
},
lib/Graphics/HotMap.pm view on Meta::CPAN
[0,10,1],
[1,10,2],
[2,10,3],
[3,10,4],
],
},
);
# ..., and import/add it
$hotMap->addConfs(\%other);
# Run the interpolation and generate and image
$hotMap->genImage;
# Save the image a a PNG file
$hotMap->genImagePng('MyTest.png');
# print the text representation of the map
print $hotMap->toString('floor') if $hotMap->scale < 3;
=head1 DESCRIPTION
Generate thermographic images from a few know points. Others values are interpolated. Graphics::HotMap use PDL to work on matrix.
PDL can compute very very large matrix in a few seconds.
See L<http://kumy.org/HotMap/HotMap.png>
=head2 FUNCTIONS
=over 4
=cut
use Data::Dumper;
use Image::Magick;
use Math::Gradient qw(multi_array_gradient);
use PDL;
use PDL::NiceSlice;
use PDL::IO::Pic;
use POSIX qw(strftime);
use File::Temp qw/ :POSIX /;
use File::Temp qw/ tempfile tempdir /;
use constant {
PALETTE_SLICE => 35,
};
our $VERSION = '0.0001';
=item new(<HASH>)
=for ref
Construct and return a new HotMap Object;
=for usage
Graphics::HotMap->new(
outfileGif => <File path>, # file to write GIF
outfilePng => <File path>, # file to write PNG
legend => [0|1], # activate lengend
legendNbGrad => <number>, # Number a graduation
cross => <bool>, # activate crossing of known values
crossValues => <bool>, # activate values printing whith cross
minValue => <number>, # minimum value
maxValue => <number>, # maximum value
font => <path to font file>,
fontSize => <number>, # font size
scale => <number>, # scale values and coordonates
sizeX => <number>, # X size
sizeY => <number>, # Y size
);
=for exemple
my $hotMap = Graphics::HotMap->new(
sizeX => 10,
sizeY => 10,
minValue => 1,
maxvalue => 50,
);
=cut
sub new {
my ($class, %params) = (@_);
my $self={};
$self->{_outfileGif} = $params{outfileGif} || undef;
$self->{_outfilePng} = $params{outfilePng} || undef;
$self->{_legend} = $params{legend} || 0;
$self->{_legendNbGrad} = $params{legendNbGrad} || 7;
$self->{_crossMark} = $params{cross} || 0;
$self->{_crossMarkTemp}= $params{crossTemp} || 0;
#$self->{_minValue} = $params{minValue} || 0;
#$self->{_maxValue} = $params{maxValue} || 70;
$self->{_font} = $params{font} || '/usr/share/fonts/truetype/freefont/FreeSans.ttf';
$self->{_fontSize} = $params{fontSize} || 15;
$self->{_text} = ();
$self->{_horodatage} = $params{horodatage} || [0, 0, 0];
$self->{_scale} = $params{echelle} || 1;
$self->{_verbose} = $params{verbose} || 0;
$self->{_mapSize}{x} = $params{sizeX} || 30;
$self->{_mapSize}{y} = $params{sizeY} || 20;
$self->{_knownPoints} = {};
$self->{_mapPoints} = PDL->zeroes(1);
bless $self, $class;
#$self->gradient(20, ([0,0,255],[0,255,255],[0,255,0],[255,255,0],[255,0,0]));
return $self;
}
=item initKnownPoints()
=for ref
Reset all know points.
=cut
sub initKnownPoints {
my $self = shift;
$self->{_knownPoints} = {};
}
=item mapSize(<HASH>)
=for ref
Set or Return mapSize
=for exemple
$hotMap->mapSize({sizeX => 15, sizeY => 15}); # Set map size
@size = $hotMap->mapSize; # Return the actual map size
=cut
sub mapSize {
my $self = shift;
my ($dimentions) = @_;
if (defined $dimentions) {
die ("mapSize: You must set sizeX and sizeY.",$/)
unless (defined $dimentions->{sizeX} && defined $dimentions->{sizeY});
$self->{_mapSize}{x} = ($dimentions->{sizeX} ) * $self->{_scale};
$self->{_mapSize}{y} = ($dimentions->{sizeY} ) * $self->{_scale};
$self->{_mapPoints} = PDL->zeroes($self->{_mapSize}{x}, $self->{_mapSize}{y});
$self->initKnownPoints;
} else {
lib/Graphics/HotMap.pm view on Meta::CPAN
$hotMap->setLayer('AllMap', $piddleVal);
=cut
sub setLayer {
my $self = shift;
my ($dest, $values) = @_;
die ("setLayer: layers must be defined. => '$dest'",$/)
unless (defined $self->{_knownPoints}{$dest});
$self->{_knownPoints}{$dest} += $values;
}
=item toString()
=for ref
Convert the interpolated table to text.
The parameter 'floor' can be added to return rounded values.
=for exemple
print $hotMap->toString('floor');
[
[ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1]
[ 1 14 14 14 14 13 13 13 13 13 14 14 14 15 1]
[ 1 14 15 14 13 13 13 13 13 13 14 14 15 15 1]
[ 1 13 14 13 13 12 12 13 13 14 14 15 15 15 1]
[ 1 9 10 11 11 12 12 13 13 14 15 15 16 16 1]
[ 1 6 7 8 10 11 12 13 14 15 15 16 16 17 1]
[ 1 5 5 7 9 11 12 13 14 15 16 17 17 17 1]
[ 1 5 6 7 9 11 13 14 16 17 17 18 18 18 1]
[ 1 6 7 8 10 12 14 16 17 18 19 19 19 19 1]
[ 1 8 8 10 11 14 16 18 19 20 21 21 20 20 1]
[ 1 9 10 11 13 16 18 20 21 22 22 22 21 21 1]
[ 1 11 12 13 15 17 20 22 23 23 23 23 22 22 1]
[ 1 12 13 15 17 19 21 23 24 24 24 24 23 22 1]
[ 1 13 15 16 18 20 22 23 24 25 24 24 23 22 1]
[ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1]
]
=cut
sub toString {
my $self = shift;
my $function = shift;
my $tmpPiddle = $self->{_mapPoints};
#$tmpPiddle->where($tmpPiddle > PALETTE_SLICE) -= PALETTE_SLICE;
if (defined $function) {
return scalar (floor($tmpPiddle)) if ($function eq 'floor');
die "toString: Unknown Function. => '$function'",$/;
}
return scalar ($tmpPiddle);
}
=item legend()
=for ref
Set or Return legend status. When enabled, the legend gradient will be drawn on the image.
=cut
sub legend {
my $self = shift;
my ($value) = @_;
if (defined $value) {
$self->{_legend} = 1;
} else {
return $self->{_legend};
}
}
=item crossMark()
=for ref
Set or Return cross marks status. When enabled, a cross will be drawn on the image where points have been defined.
=cut
sub crossMark {
my $self = shift;
my ($mark, $value) = @_;
if (defined $mark) {
$self->{_crossMark} = 1;
$self->{_crossMarkTemp} = 1 if defined $value;
} else {
return $self->{_crossMark};
}
}
=for exemple
Internal function for base colors table
=cut
sub _genLut {
my $self = shift;
my ($lut) = @_;
$lut = [
[255, 255, 255], # 0 white
[ 0, 0, 0], # 1 black
[ 0, 0, 255], # 2 blue
[ 0, 255, 0], # 3 green
[ 0, 255, 255], # 4 cyan
[255, 0, 0], # 5 red
[255, 0, 255], # 6 magenta
[255, 255, 0], # 7 yellow
[153, 204, 0], # 8 Green 1
[128, 128, 0], # 9 Green 2
[128, 0, 128], # 10 purple
[255, 255, 153], # 11 light yellow
[204, 153, 255], # 12 light purple
[ 0, 204, 255], # 13 cool blue
[228, 109, 10], # 14 orange
[255, 204, 153], # 15 peal
[246, 96, 134], # 16 rose1
[ 96, 118, 246], # 17 blue2
[152, 18, 13], # 18 red2
[153, 102, 204], # 19 violet2
[123, 160, 91], # 20 asperge
]
unless defined $lut;
for (@$lut..PALETTE_SLICE-1) {
push (@{$lut}, [100+$_, 100+$_, 100+$_]);
}
lib/Graphics/HotMap.pm view on Meta::CPAN
foreach my $gradientName (sort keys %{$self->{_gradient}}) {
my $nbColors = 1+$self->{_gradient}{$gradientName}{nbColors};
my @grad = multi_array_gradient($nbColors, @{$self->{_gradient}{$gradientName}{colorsPoints}});
push (@gradients, @grad);
$self->{_gradient}{$gradientName}{start} = $nextPaletteStart;
$nextPaletteStart += $nbColors;
}
my $lut = byte pdl((@{$self->_genLut}, @gradients));
$self->{_gradient}{colors} = PDL::cat ($lut);
}
=for item getColor($level)
Return the lut color from the specified level
=cut
sub getColor {
my $self = shift;
my ($level) = @_;
my $lut = $self->{_gradient}{colors};
return '#'.
sprintf("%02x",$lut->at(0,$level,0)).
sprintf("%02x",$lut->at(1,$level,0)).
sprintf("%02x",$lut->at(2,$level,0));
}
=for comment
Internal function for writing text on the image
=cut
sub _printText {
my $self = shift;
my ($im, $textHash) = @_;
my $text = $textHash->{text};
my $x = $textHash->{x};
my $y = $textHash->{y};
my $color = $textHash->{color} || 'black';
my $align = $textHash->{align} || 'left';
my $size = $textHash->{size} || $self->{_fontSize};
my $font = $textHash->{font} || $self->{_font};
my $rotate = $textHash->{rotate} || 0;
$im->Annotate(
font=>$self->{_font},
pointsize=>$size,
fill=>$color,
text=>$text,
align=>$align,
x=>$x,
y=>$y,
rotate=>$rotate,
);
}
=for comment
Internal function for generating legend bar on the image
=cut
sub _drawLegendBar {
my $self = shift;
my ($gradientName, $i, $im) = @_;
my $repere = 10;
my $legendBar = Graphics::HotMap->new(
wall => 1,
);
$legendBar->{_gradient} = $self->{_gradient};
$legendBar->mapSize({
sizeX => 10,
sizeY => 500,
});
$legendBar->addLayer({ layerName => '_Legend'.$gradientName, visibility => 1, gradientName => $gradientName });
my $nbGrad = $self->{_gradient}{$gradientName}{nbColors}; #$self->{_legendNbGrad}-1;
my $min = $self->{_gradient}{$gradientName}{minValue};
my $max = $self->{_gradient}{$gradientName}{maxValue};
for (0..$nbGrad) {
my $x = $legendBar->{_mapSize}{x}-1;
my $y = $_/$nbGrad*($legendBar->{_mapSize}{y}-1);
my $valeur = $max-(int(($nbGrad-$_)/$nbGrad*($max-$min)));
my $unit = $legendBar->{_gradient}{$gradientName}{unit};
$legendBar->addPoint({
layerName => '_Legend'.$gradientName,
#x => $_/$nbGrad*($legendBar->{_mapSize}{x}-1),
#y => $legendBar->{_mapSize}{y}-1-$repere*$i,
x => $x,
y => $y,
value => $valeur,
noScale => 1,
unit => $unit,
});
$legendBar->addText ( {
x => $x+15,
y => $y+10,
text => int($valeur).$unit,
size => 10,
align => 'center'
} ) if ($nbGrad < 11 || $_%5 == 0);
}
$legendBar->addZone({
layerName =>'_Legend'.$gradientName,
zoneName => '_Legend'.$gradientName,
coordonates => [
1,
1,
$legendBar->{_mapSize}{x}-1,
$legendBar->{_mapSize}{y}-1,
],
noScale => 1 });
$legendBar->_genDegradZone('_Legend'.$gradientName, $legendBar->{_zones}{'_Legend'.$gradientName}{'_Legend'.$gradientName}, 1);
my $imag = byte $legendBar->{_mapPoints};
my $tmpName = new File::Temp( TEMPLATE => 'generated-XXXXX',
DIR => '/tmp/',
SUFFIX => '.png',
OPEN => 0);
#my $tmpName = tmpnam().'.png';
my $cptLoop = 0;
do {
eval {$imag->wpic($tmpName, { LUT => $legendBar->{_gradient}{colors} }); };
# $imag->wpic($tmpName, { LUT => $legendBar->{_gradient}{colors} });
++$cptLoop;
} while ($@ && $cptLoop < 10);
if ($cptLoop > 2) {
print "ARgh ! Function: _saveImage ; nbErr for wpic:$cptLoop\n";
exit;
}
# read the temporary File in PerlMagick
my $status = $im->ReadImage($tmpName);
warn $status if $status;
#unlink $tmpName;
# Flip the image
$im->[$i+1]->Flip;
$im->[$i+1]->Border(fill=>'black', width=>-1, height=>-1);
$im->[$i+1]->Extent(
background => 'white',
geometry => ($legendBar->{_mapSize}{x}+35).'x'.($legendBar->{_mapSize}{y}+15),
gravity => 'West',
);
$legendBar->_genText($im->[$i+1]);
$im->[$i+1]->Extent(
background => 'white',
geometry => ($legendBar->{_mapSize}{x}+35).'x'.$self->{_mapSize}{y},
gravity => 'Center',
);
$im->[$i+1]->Extent(
background => 'white',
geometry => ($legendBar->{_mapSize}{x}+35+20).'x'.$self->{_mapSize}{y},
gravity => 'East',
);
$im->[$i+1]->Annotate(
font=>$self->{_font},
pointsize=>10,
fill=>'black',
text=>$gradientName,
align=>'right',
x=>10,
y=>35,
rotate=>270,
);
$self->{_im} = $im->Append(stack=>'false');
}
=for comment
Internal function for generating legend on the image
=cut
sub _genLegende {
my $self = shift;
my ($im) = @_;
my $i=0;
#print "Printing Gradient Bars",$/;
foreach my $gradientName (sort keys %{$self->{_gradient}}) {
#print "* $gradientName",$/;
next if $gradientName eq 'colors';
next if defined $self->{_gradient}{$gradientName}{visibility} && !$self->{_gradient}{$gradientName}{visibility};
$self->_drawLegendBar($gradientName, $i, $im);
$i++;
}
}
=for comment
Internal function for generating one mark on the image
=cut
sub _drawMark {
my $self = shift;
my ($im, $x, $y, $valeur, $unit) = @_;
my $red = '#FF0000';
my $white = '#FFFFFF';
my %cross = (
-2 => { 0 => $red, },
-1 => { 0 => $white, },
0 => {-2 => $red,
-1 => $white,
0 => $white,
1 => $white,
2 => $red, },
1 => { 0 => $white, },
2 => { 0 => $red, },
);
foreach my $i (sort keys %cross) {
foreach my $j (sort keys %cross) {
for (0..2) {
next unless defined $cross{$i}{$j};
my $ix = $i * $_ + $x;
my $jy = $j * $_ + $y;
next unless (0 < $ix && $ix < $self->{_mapSize}{x}-1);
next unless (0 < $jy && $jy < $self->{_mapSize}{y}-1);
$im->Set("pixel[$ix,$jy]" => $cross{$i}{$j});
}
}
}
$self->addText ( {
x => $x,
y => $y,
text => int($valeur).$unit,
size => 10,
align => 'center'
lib/Graphics/HotMap.pm view on Meta::CPAN
} );
}
=for comment
generate text on the image
=cut
sub _genText {
my $self = shift;
my ($im) = @_;
foreach my $text (@{$self->{_text}}) {
$self->_printText($im, $text);
}
}
=for comment
generate the image from the interpolated map.
=cut
sub _genPicture {
my $self = shift;
my $image = $self->{_im} = new Image::Magick();
# write a temporary image of the piddle
my $imag = byte $self->{_mapPoints};
my $tmpName = tmpnam().'.png';
#eval { $self->{_hotMap}->genImage };
#print STDERR "error: _genTemperatureImage: $@" if $@;
my $cptLoop = 0;
do {
eval {$imag->wpic($tmpName, { LUT => $self->{_gradient}{colors} }); };
++$cptLoop;
} while ($@ && $cptLoop < 10);
if ($cptLoop > 2) {
print "ARgh ! Function: _genPicture; nbErr for wpic:$cptLoop\n";
exit;
}
# read the temporary File in PerlMagick
my $status = $image->ReadImage($tmpName);
warn $status if $status;
unlink $tmpName;
# Flip the image
my $im = $image;
#my $im = $image->[0];
$im->Flip;
# Gen CrossMarks
$self->_genCrossMark($im) if $self->{_crossMark};
# Draw time on image
$self->_drawTime($im) if $self->{_horodatage}[0];
# Draw texts
$self->_genText($im);
# Gen legend in piddle
$self->_genLegende($im) if $self->{_legend};
}
=for comment
Really compute the interpolation from known points.
=cut
sub _pdlDegrad {
my $self = shift;
my ($input, $output, $sliceColors, $gradientName) = @_;
my ($d0,$d1) = whichND $input;
my $nbValues = nelem($d0);
my $norm = pdl->zeroes($input->dims);
$output .= 0;
my $t0r2;
my $t0r2inv;
if ($nbValues > 1) {
for (0..$nbValues-1) {
my $indice = $_;
$t0r2 = $input->rvals({ center=>[$d0($indice), $d1($indice)], squared=>1 } );
$t0r2->where($t0r2==0) .= -1;
$t0r2inv = 1/$t0r2;
$norm += $t0r2inv;
$output += $input($d0($indice), $d1($indice);-)*$t0r2inv;
}
$output->where($output < 0) .= 0;
$output /= $norm;
$output += $input;
} elsif ($nbValues == 1) {
$output->where($output==0) .= $input->at($d0->at(0),$d1->at(0));
} else {
# do not slice if there is no values
return;
}
if (defined $sliceColors && $sliceColors) {
my $minValue = $self->{_gradient}{$gradientName}{minValue};
my $maxValue = $self->{_gradient}{$gradientName}{maxValue};
my $ratio = $self->{_gradient}{$gradientName}{nbColors}/(1+$maxValue-$minValue);
$output *= $ratio;
$output += $self->{_gradient}{$gradientName}{start}-$minValue*$ratio;
}
}
=for comment
Fetch zones, get a slice from coordonates, then generate the interpolation.
If border is defined, place the points too.
=cut
sub _genDegradZone {
my $self = shift;
my ($layerName, $zoneHash) = @_;
my ($sX, $sY, $eX, $eY) = @{$zoneHash->{coordonates}};
( run in 2.311 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )