view release on metacpan or  search on metacpan

lib/Image/Heatmap.pm  view on Meta::CPAN

package Image::Heatmap;

use strict;
use warnings;

use Image::Magick;

our $VERSION = join( '.', 0, sprintf( '%03d', map{ $_ - 47 + 500 } ( '$Rev: 112 $' =~ /(\d+)/g ) ) ); 
our $DEBUG = 0;

use constant {
    TRANSPARENCY_V1 => 0x1,
    TRANSPARENCY_V2 => 0x2,
};

sub new {
    my $self = bless( Image::Heatmap::private::next_oid(), shift ); 

    Image::Heatmap::private::init();

    # Defaults
    $self->tmp_dir('/tmp/');
    $self->transparent_bg(0);
    $self->transparent_version(TRANSPARENCY_V2);
    $self->processes(1);
    $self->x_adjust(0);
    $self->y_adjust(0);
    $self->width_adjust(0);
    $self->height_adjust(0);
    $self->output('heatmap.png');
    $self->colors('colors.png');
    $self->plot_base('bolilla.png');

    return $self;
}

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

    if ( my $error = Image::Heatmap::private::validate($self) ) {
        Image::Heatmap::private::throw($error);
    }

    my $max_rep = 0;

    my $width  = $self->width();
    my $height = $self->height();
    my $map    = Image::Magick->new();
    $map->Read( $self->map() );
    $self->image_width( $map->Get('width') );
    $self->image_height( $map->Get('height') );

    # If there is no width/height defined then we will default
    # to what the image is defined to.  We will trust the implementor
    # of this module knows what they're doing, otherwise.
    unless ( $width && $height ) {
        $width  = $self->image_width();
        $height = $self->image_height();
    }
    note("W x H: $width x $height");

    unless ( $self->width_adjust() && $self->height_adjust() ) {
        $self->width_adjust( $self->image_width() );
        $self->height_adjust( $self->image_height() );
        note('W x H Adjust: ' . join( ' x ', map{ $self->$_() } qw( width_adjust height_adjust ) ) );
    }

    my $loader;

    if ( my $sth = $self->statement() ) {
        my $sth = $self->statement();
        $sth->execute();
        $loader = sub {
            return $sth->fetchrow_hashref();
        };
    }
    elsif ( my $geo_list = $self->geo_list() ) {
        $loader = sub {
            return shift( @$geo_list );
        }
    }
    else {
        Image::Heatmap::private::throw(
            'No value for "statement" or "geo_list"... not sure what you want from me.'
        );
    }


    while ( my $point = $loader->() ) {
        my ( $lat, $lng ) = @$point{ qw( latitude longitude ) };

        # Make sure a lat/lng exist
        Image::Heatmap::private::throw(
            'Invalid parameters in statement, must include "latitude" and "longitude"'
        ) unless ( defined($lat) && defined($lng) ); 

        my $x = ( 180 + $lng ) * ( $width / 360 );
        my $y = ( 90 - $lat ) * ( $height / 180 );

        $_ *= $self->zoom() || 1 for ( ( $x, $y ) );

        $x += $self->x_adjust();
        $y += $self->y_adjust();

        my $coords = join( '|', $lat, $lng );
        Image::Heatmap::private::shove( $self => 'coords', [ $x, $y ] );
        my $reps = Image::Heatmap::private::get( $self => 'reps' => $coords );
        $max_rep = $reps->{$coords} if ( ++$reps->{$coords} > $max_rep );
    }

    my $x_canvas = $width * ( $self->width_adjust() / $width );
    my $y_canvas = $height * ( $self->height_adjust() / $height );
    note("$width x $height vs. $x_canvas x $y_canvas");

    my $kid_seed  = int( rand( time() ) );
    my $kid_layer = "layer_slice-%d-$kid_seed.png";
    my $kids      = $self->processes();
    my @children  = ();
    foreach my $child_num ( 1 .. $kids ) {
        $children[ $child_num - 1 ] = Image::Heatmap::private::distribute_work($self);

        Image::Heatmap::private::throw(
            'Error when generating sub-process'
        ) unless ( defined( $children[-1] ) );

        unless ( $children[-1] ) {

            note("Resize -geometry ${x_canvas}x${y_canvas}");
            my $child_layer = Image::Magick->new( size => "${x_canvas}x${y_canvas}");
            $child_layer->Read('pattern:gray100');

            my $cperc  = int( 100 / ( $max_rep || 1 ) );
            $cperc    /= 2 if ( $cperc > 80 );
            note("Colorize -fill white -opacity $cperc%");
            my $plot = Image::Magick->new();
            $plot->Read( $self->plot_base() );
            $plot->Resize( $self->plot_size() ) if ( $self->plot_size() );
            $plot->Colorize( fill => 'white', 'opacity' => "$cperc%" );

            my @coords        = @{ Image::Heatmap::private::get( $self => 'coords' ) || [] };
            my $bucket_size   = scalar( @coords ) / $kids;
            my $bucket_offset = ( $child_num - 1 ) * $bucket_size;
            my @new_coords    = splice( @coords, $bucket_offset, $bucket_size ); 

            foreach my $coordinate ( @new_coords ) {
                my ( $x, $y ) = @$coordinate;
                note("Composite -compose Multiply -geometry +$x+$y");

                $child_layer->Composite(
                    'image'    => $plot,
                    'compose'  => 'Multiply',
                    'geometry' => "+$x+$y",
                );
            }

            my $child_image = sprintf( $kid_layer, $child_num );
            note("Write $child_image"); 
            $child_layer->Write( $self->tmp_dir() . $child_image ); 

            Image::Heatmap::private::finish_work($self);
        }
    }

    foreach my $child ( @children ) {
        note("Blocking wait on pid:$child");
        my $pid_state = waitpid( $child, 0 );
        note("pid:$child - $pid_state :: $?");
    }

    my $layer = Image::Magick->new( size => "${x_canvas}x${y_canvas}");
    $layer->Read('pattern:gray100');

    foreach my $child_num ( 1 .. $kids ) {
        my $child_image = $self->tmp_dir() . sprintf( $kid_layer, $child_num );
        my $child_slice = Image::Magick->new();
        $child_slice->Read($child_image);

        note("Composite -image $child_image -compose Multiply -geometry +0+0");
        $layer->Composite( 
            'image'    => $child_slice,
            'compose'  => 'Multiply',
            'geometry' => '+0+0',
        );

        unlink($child_image);
    }

    note("Negate && Fx -expression v.p{0,u*v.h}");
    $layer->Negate();
    $layer->Read( $self->colors() );
    my $fx = $layer->Fx( 'expression' => 'v.p{0,u*v.h}' );

    note("Composite -image $map -compose Blend -blend 40%");
    $fx->Composite(
        'image'   => $map,
        'compose' => 'Multiply',
        'blend'   => '+0+0',
    );

    if ( $self->transparent_bg() ) {

        if ( $self->transparent_version() == ( TRANSPARENCY_V1 | TRANSPARENCY_V2 ) ) {
            throw('Only a single transparency version is allowed at one time.');
        }
        elsif ( $self->transparent_version() & TRANSPARENCY_V1 ) {
            my ( $rx, $gx, $bx ) = $fx->GetPixel( 
                'x' => $fx->Get('width'), 
                'y' => $fx->Get('height'), 
            );

            my ( $r, $g, $b );
            foreach my $x_new ( 0 .. $fx->Get('width') ) {
                foreach my $y_new ( 0 .. $fx->Get('height') ) {
                    ( $r, $g, $b ) = $fx->GetPixel( 'x' => $x_new, 'y' => $y_new );
                    if ( $r == $rx && $b == $bx && $g == $gx ) {
                        $fx->SetPixel( 'x' => $x_new, 'y' => $y_new, 'color' => [ 1,1,1 ] );
                    }
                }
            }
            $fx->Transparent( 'color' => '#FFFFFF' );
        }
        elsif ( $self->transparent_version() & TRANSPARENCY_V2 ) {
            my $trans_width  = $fx->Get('width')  - 1;
            my $trans_height = $fx->Get('height') - 1;

            foreach my $trans_coord ( 
                [ 0,            0             ],
                [ $trans_width, 0             ],
                [ 0,            $trans_height ],
                [ $trans_width, $trans_height ],
            ) { 
                my ( $x, $y ) = @$trans_coord;
                $fx->MatteFloodfill(
                    'x' => $x, 
                    'y' => $y, 

lib/Image/Heatmap.pm  view on Meta::CPAN

to determine the background color and apply transparency to all pixels that match
the same color exactly.

=head2 transparent_version

There are numerous supported methods of forcing backgrounds to be transparent
depending on the version of PerlMagik you have backing this module.  Depending
on this, there are two methods available for doing so; one more efficient
than the other.  Both are the same in that they take the "magic wand" apprach
to backgrounding, finding the common colors in the corners of the image and 
making all simliar colors transparent.

The older and less efficient approach can be enabled such as:

    my $heat = Image::Heatmap->new();
    $heat->transparent_bg(1);
    $heat->transparent_bg( Image::Heatmap::TRANSPARENT_V1 );

The newer and more efficient approach can be enabled such as:

    my $heat = Image::Heatmap->new();
    $heat->transparent_bg(1);
    $heat->transparent_bg( Image::Heatmap::TRANSPARENT_V2 );

The latter of the examples is defaulted.

=head2 contrast

Will adjust the contrast of the final image.  0 is default,
3 is normal and 10 is a LOT.

    my $heat = Image::Heatmap->new();
    $heat->constrast(3);

=head1 EXAMPLES

    use Image::Heatmap;
    use DBI;

    my $heatmap = Image::Heatmap->new();
    my $dbh     = DBI->connect( 'dsn', 'username', 'password', {} );
    my $sth     = $dbh->prepare('select latitude, lon AS longitude from table');

    $heatmap->statement( $sth );
    $heatmap->process();

    $heatmap->tmp_dir('/tmp'); 
    $heatmap->output('/tmp/heatmap.gif');
    $heatmap->process();

    $heatmap->output('/tmp/heatmap.jpg');
    $heatmap->process();

    $heatmap->output('/tmp/heatmap.png');
    $heatmap->process();

=head1 SEE ALSO

=over

=item L<Image::Magick>

=item L<File::Find>

=back

=head1 TODO

=over

=item $VERSION > 1

There are a few known bugs and missing unit tests that prevent me from making this module's
$VERSION >= 1.  It is my goal to fix this and release it as a 'production ready' module.

=back

=head1 AUTHOR

Trevor Hall, E<lt>wazzuteke@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Trevor Hall

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut