view release on metacpan or  search on metacpan

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

Note that neither reduced version is appropriate to use as an image comparison hash by itself
(too many false positives), and they are chosen to be complimentary, so when used in conjunction
for either indexing or verification, their performance increases considerably.

=head1 HELPER METHODS

=head2 C<reducedimage>

  my $img = $iph->reducedimage();

Returns the reduced (rescaled) image that will be used for the DCT.

=head2 C<dctdump>

  my $dct = $iph->dctdump();

Will return the full 32x32 DCT as an arrayref of floats.

=head2 C<printbitmatrix>

  $iph->printbitmatrix(
     %phash_opt,        # Any pHash method option applies
     separator => '',   # Separator for horizontal values
     filler    => ' '   # For reduced results, filler for the missing positions
  );

Will return a print-friendly reduced size bitmask matrix as a string. Basically a
string with rows/columns of the 1s and 0s you would get from calling C<$iph-E<gt>pHash()>
with the same parameters.

=head1 HELPER FUNCTIONS

=head2 C<b2h>

  my $hash = Image::PHash::b2h(join('', @bits));

Will convert a bit value string to a hex string.

=head2 C<diff>

  my $diff = Image::PHash::diff($phash1, $phash2);

Will calculate the bit difference of two hex string hashes (their Hamming distance
of their bit stream form). On 64 bit systems (checking C<$Config{ivsize}>) it will
actually call C<_diff64> which can calculate the difference of up to 64bit hashes in
a single operation (using C<%064b>). You can call C<_diff64> directly if you prefer
in that scenario.

=head1 NOTES

=head2 Performance

The hashing performance of the module is enough to make the actual pHash generation
from the final 32x32 mono image a trivial part of the process. For a general idea,
on a single core of a 2015 Macbook Pro, over 18000 hashes/sec can be processed thanks
in part to the fast L<Math::DCT> XS module (developed specifically for Image::PHash).

So, most of the processing time is spent on loading the image, resizing, extracting
pixel values, removing color, all of which depend on the specific image module. On an
Apple M1, hashing 800x600 jpg images was measured at 131 h/s with L<Image::Magick>,
208 h/s with L<Imager>, 241 h/s with L<GD>, 547 h/s with L<Image::Imlib2>.
Higher resolutions make the process slower as you could expect. Since all images will
be resized to 32x32 in the end, the fastest hashing performance would be if you loaded
32x32 thumbnails. In that case, the performance of the libraries in the same order for
the resized imageset were: 659 h/s, 664 h/s, 1883 h/s, 2296 h/s. It is clear that
L<Image::Imlib2> should be preferred when hashing performance is desired, as it offers
dramatically better performance (unless you are hashing 32x32 images in which case L<GD>
also fast). It should be noted that the resulting hashes don't have exactly the same
behaviour/metrics, due to the different resizing algorithms used, but the differences
seem to be very small. You are encouraged to test on your own data set.

Remember, never mix image libraries (or settings), the hashes will most likely not
be compatible.

Finally, if you are curious about the performance of this module compared to the
C++ pHash.org implementation, pHash.org could achieve 33 h/s with the test setup as
above, making L<Image::PHash> over 16x faster with Imlib2. With pre-sized 32x32
images, pHash.org ran at 101 h/s (~23x slower than L<Image::PHash>/Imlin2).

=head2 Compatibility of hashes

As already mentioned, if you produce hashes with different settings, different image
libraries etc, the hashes might not be compatible. It is advisable to even freeze
the version of this module and the image library in a production environment to
avoid any degraded performance.

=head2 Calculation caching

Calculating pHashes with different dct/reduce/median/mirror arguments for the same
image is very fast (when the same object is used), as the resize and DCT transform
will only happen on the very first pHash calculation and are cached for any subsequent
call. You can essentially get the extra phash6/phash7/mirror etc "for free" after
the initial pHash calculation.

=head2 L<Image::PHash> vs L<Image::Hash>

While L<Image::Hash> may still be useful for the aHash and dHash functionality, its
pHash implementation is seriously flawed. It does not actually do a full DCT, using
instead a shortcut that seems to result to hashes with lots of zeros and thus a high
rate of collisions (~2% chance for identical hash on dissimilar images making it useless
for my large data set), which is the reason the hashing was implemented from scratch.
Despite it not doing a full DCT it was really slow (over 80x slower than the XS L<Math::DCT>),
so switching to L<Image::PHash> will give you "correct" hashes at a significant speed
increase, along with several extra features.

=head2 L<Image::PHash> vs L<pHash.org>

Apart from the significant speed advantage of Image::PHash noted above, there are a couple
of important differences, in that pHash.org will apply a 7x7 mean filter to the image
before the resize and the conversion to bits is always done with the median method. This
seems to keep false positives quite low, but its false negatives are higher. Since with
Image::PHash you can get even better hashes with, for example, C<geometry=64> and you can
combine them with C<method='average_x'> or C<method='log'>, you will get even lower false
positive rate than pHash.org, but with less false negatives as well. Feel free to share
your own comparisons with the author if in doubt.

Note that the differences you are to use as a threshold for Image::PHash and pHash.org are
quite different - pHash.org will give about 50% greater diffs on average (e.g. where I would
use 7 for the former, 11 would be the equivalent for the latter).

=head2 Selecting a C<diff> threshold

The appropriate C<diff> threshold for declaring images as "similar" is not a precise
art and will depend on the application (type of images, tolerance for false positives
etc.). The exact application is very important too, if you have 2 images and want to
check whether they are similar, a false positive rate of even over 1% is fine, in which
case the diff can be chosen to be probably over 10, whereas having a big collection of
photos in which you want to check whether a duplicate exists, requires a very low false
positive rate. Example diff ranges for a full pHash are 3-7 if you want to keep false
positives close to 0%. For the small pHash7 and pHash6 probably not more than 3 and 2
respectively are useful for lookups (and still with lots of false positives as noted above).

=cut

my $_64bit;

sub pHash7 {
    my ($self, %opt) = @_;
    return $self->pHash(%opt, geometry => '7x7', reduce => 1);
}

sub pHash6 {
    my ($self, %opt) = @_;
    return $self->pHash(%opt, geometry => '6x6', reduce => 1, method => 'median');
}

sub new {
    my $class = shift;

    my $self = {};
    bless($self, $class);

    $self->{image}    = shift || croak("Image file or data expected.");
    $self->{module}   = shift;
    $self->{settings} = shift || {};

    croak("Hashref expected for settings argument") unless ref($self->{settings}) eq 'HASH';
    $self->{dct_size} = int($self->{settings}->{resize} || 32);
    $self->{imager_qtype} = $self->{settings}->{imager_qtype} || 'mixing';
    $self->{magick_filter} = $self->{settings}->{magick_filter} || 'Cubic';
    croak("resize > 5 expected.") unless $self->{dct_size} > 5;

    my %libs = ( # Library, reduce/resize function, pixels function, support for passing data variable
        Imlib2      => ['Image::Imlib2', \&_reduce_Imlib2, \&_pixels_Imlib2],
        GD          => ['GD', \&_reduce_GD, \&_pixels_GD, 1],
        ImageMagick => ['Image::Magick', \&_reduce_Magick, \&_pixels_Magick, 1],
        Imager      => ['Imager', \&_reduce_Imager, \&_pixels_Imager, 1],
    );

    my $ref  = ref($self->{image});
    my $file = $ref ? undef : -f $self->{image};

    if ($ref) {    # Passed image object
        $self->{module} = undef;
        foreach (_lib_order()) {
            my $type = $_ eq 'GD' ? 'GD::Image' : $libs{$_}->[0];
            if ($type eq $ref) {
                $self->{module} = $_;
                last;
            }
        }
        croak("Object of unknown type $ref.") unless $self->{module};
    } elsif ($self->{module}) {    # User specified image module
        $libs{$libs{$_}->[0]} = $libs{$_} for keys %libs;    # Allow synonyms
        my $lib = $libs{$self->{module}}->[0];

        croak("Unknown image library specified: '$self->{module}'. "
            . "Choose from: ".join(', ', map {/:/ ? () : $_} keys %libs)
        ) unless $lib;

        eval "require $lib"
            or croak("Specified image library '$self->{module}' could not be loaded.");

        $self->{module} = $lib; # Normalize
    } else {
        # Try to load Imlib2, GD, Imager, ImageMagick in that order
        foreach my $lib (_lib_order()) {
            if (eval "require $libs{$lib}->[0]" && ($file || $libs{$lib}->[3])) {
                $self->{module} = $lib;
                last;
            }
        }
        croak("None of the supported image libraries could be loaded. "
            . " Tried loading: ".join(', ', keys %libs)
        ) unless $self->{module};
    }
    croak("No file at $self->{image}")
        unless $ref || $file || (length($self->{image}) > 255 && $libs{$self->{module}}->[3]);

    my $error = '';
    if ($libs{$self->{module}}->[0] eq 'Image::Imlib2') {
        $self->{im} = $ref ? $self->{image} : Image::Imlib2->load($self->{image});
    } elsif ($libs{$self->{module}}->[0] eq 'GD') {
        GD::Image->trueColor(1);
        $self->{im} = $ref ? $self->{image} : GD::Image->new($self->{image});
    } elsif ($libs{$self->{module}}->[0] eq 'Image::Magick') {
        if ($ref) {
            $self->{im} = $self->{image};
        } else {
            $self->{im} = Image::Magick->new();
            $error =
                ($file)
                ? $self->{im}->Read($self->{image})
                : $self->{im}->BlobToImage($self->{image});
            $self->{im} = undef if $error;
        }
    } else {
        my $type = $file ? 'file' : 'data';
        $self->{im} = $ref ? $self->{image} : Imager->new($type => $self->{image});
        $error = Imager->errstr() || '';
    }

    unless ($self->{im}) {
        carp("Cannot load ".($file ? $self->{image} : 'data')." with $self->{module}. $error");
        return;
    }

    $self->{reduced} = $libs{$self->{module}}->[1];
    $self->{pixels}  = $libs{$self->{module}}->[2];

    $self->{methods} = {
        average   => \&_apply_average,
        average_x => \&_apply_average,
        median    => \&_apply_median,
        diff      => \&_apply_diff,
        log       => \&_apply_log_average,
    };

    return $self;
}

# Helper function:
# Convert from binary to hexadecimal
#
# Borrowed from http://www.perlmonks.org/index.pl?node_id=644225
sub b2h {
    my $num   = shift;
    my $WIDTH = 4;
    my $index = length($num) - $WIDTH;
    my $hex   = '';
    do {
        my $width = $WIDTH;
        if ($index < 0) {
            $width += $index;
            $index = 0;
        }
        my $cut_string = substr($num, $index, $width);
        $hex = sprintf('%X', oct("0b$cut_string")) . $hex;
        $index -= $WIDTH;
    } while ($index > (-1 * $WIDTH));
    return $hex;
}

sub _lib_order {qw/Imlib2 GD Imager ImageMagick/}

sub _is_64bit {
    $_64bit //= $Config{ivsize} >= 8;
    return $_64bit;
}

# Difference in bits between two hex strings
# About 30% slower than using %064b directly, but this is portable to 32 bits
sub diff {
    return _diff64(@_) if length($_[0]) <= 16 && ($_64bit || &_is_64bit);
    my $diff;
    for (my $i = 0; $i < length($_[0]); $i += 8) {
        my $d =
            sprintf("%032b", hex(substr($_[0], $i, 8))) ^
            sprintf("%032b", hex(substr($_[1], $i, 8)));
        $diff += $d =~ tr/\0//c;
    }
    return $diff;
}

sub _diff64 {
    my $k = sprintf("%064b", hex($_[0]));
    my $l = sprintf("%064b", hex($_[1]));
    my $diff = $k ^ $l;
    my $num_mismatch = $diff =~ tr/\0//c;
    return $num_mismatch;
}

# Reduce the size of an image using Imlib2
sub _reduce_Imlib2 {
    my $self = shift;
    return $self->{im_scaled} = $self->{im}
        if $self->{im}->width == $self->{dct_size}
        && $self->{im}->height == $self->{dct_size};

    $self->{im_scaled} =
        $self->{im}->create_scaled_image($self->{dct_size}, $self->{dct_size});
}

# Reduce the size of an image using GD
sub _reduce_GD {
    my $self = shift;
    $self->{im_scaled} = $self->{im};
    return
        if $self->{im}->width == $self->{dct_size}
        && $self->{im}->height == $self->{dct_size};

    my $dest = GD::Image->new($self->{dct_size}, $self->{dct_size});

    $dest->copyResampled(
        $self->{im_scaled}, 0, 0,                    # (srcimg, dstX, dstY)
        0, 0, $self->{dct_size}, $self->{dct_size},  # (srcX, srxY, destX, destY)
        $self->{im_scaled}->width, $self->{im_scaled}->height
    );
    $self->{im_scaled} = $dest;
}

# Reduce the size of an image using Image::Magick
sub _reduce_Magick {
    my $self = shift;
    $self->{im_scaled} = $self->{im};
    
    my ($w, $h) = $self->{im}->Get('width', 'height');
    return if $w == $self->{dct_size} && $h == $self->{dct_size};

    $self->{im_scaled}->Set(antialias => 'True');
    $self->{im_scaled}->Resize(
        width  => $self->{dct_size},
        height => $self->{dct_size},
        filter => $self->{magick_filter}
    );
}

# Reduce the size of an image using Imager
sub _reduce_Imager {
    my $self = shift;
    return $self->{im_scaled} = $self->{im}
        if $self->{im}->getwidth() == $self->{dct_size}
        && $self->{im}->getheight() == $self->{dct_size};

    $self->{im_scaled} = $self->{im}->scale(
        xpixels => $self->{dct_size},
        ypixels => $self->{dct_size},
        qtype   => $self->{imager_qtype},
        type    => "nonprop"
    );
}

# Return the pixel values for an image when using Imlib2
sub _pixels_Imlib2 {
    my $self = shift;
    my @pixels;
    for (my $y = 0; $y < $self->{dct_size}; $y++) {
        for (my $x = 0; $x < $self->{dct_size}; $x++) {

            my ($red, $green, $blue, $a) = $self->{im_scaled}->query_pixel($x, $y);
            my $grey = $red * 0.3 + $green * 0.59 + $blue * 0.11;
            push(@pixels, $grey);
        }
    }

    return \@pixels;
}

# Return the pixel values for an image when using GD
sub _pixels_GD {
    my $self = shift;
    my @pixels;
    for (my $y = 0; $y < $self->{dct_size}; $y++) {
        for (my $x = 0; $x < $self->{dct_size}; $x++) {

            my $color = $self->{im_scaled}->getPixel($x, $y);
            my ($red, $green, $blue) = $self->{im_scaled}->rgb($color);
            my $grey = $red * 0.3 + $green * 0.59 + $blue * 0.11;
            push(@pixels, $grey);
        }
    }

    return \@pixels;
}

# Return the pixel values for an image when using Image::Magick
sub _pixels_Magick {
    my $self = shift;
    my @pixels;
    for (my $y = 0; $y < $self->{dct_size}; $y++) {
        for (my $x = 0; $x < $self->{dct_size}; $x++) {
            my @pixel = $self->{im_scaled}->GetPixel(
                x         => $x,
                y         => $y,
                normalize => 0
            );
            my $grey = $pixel[0] * 0.3 + $pixel[1] * 0.59 + $pixel[2] * 0.11;
            push(@pixels, $grey);
        }
    }

    for (my $i = 0; $i <= $#pixels; $i++) {
        $pixels[$i] = $pixels[$i] / 256;
    }

    return \@pixels;
}

# Return the pixel values for an image when using Imager
sub _pixels_Imager {
    my $self = shift;
    my @pixels;
    for (my $y = 0; $y < $self->{dct_size}; $y++) {
        for (my $x = 0; $x < $self->{dct_size}; $x++) {
            my $c = $self->{im_scaled}->getpixel(
                x => $x,
                y => $y
            );
            my ($red, $green, $blue, $alpha) = $c->rgba();
            my $grey = $red * 0.3 + $green * 0.59 + $blue * 0.11;
            push(@pixels, $grey);
        }
    }
    return \@pixels;
}

sub reducedimage {
    my ($self, %opt) = @_;

    $self->{reduced}->($self, %opt) unless $self->{im_scaled};
    return $self->{im_scaled};
}

sub dctdump {
    my ($self, %opt) = @_;

    $self->{reduced}->($self, %opt) unless $self->{im_scaled};
    $self->{dct} ||= dct2d($self->{pixels}->(($self, %opt)));
    my $dctv = $self->_mirroring(%opt);

    return $self->{$dctv};
}

sub printbitmatrix {
    my $self  = shift;
    my %opt   = $self->_validate_options(@_);