File Coverage

blib/lib/Math/KullbackLeibler/Discrete.pm

Criterion	Covered	Total	%
statement	31	31	100.0
branch	6	6	100.0
condition			n/a
subroutine	7	7	100.0
pod	1	1	100.0
total	45	45	100.0

package Math::KullbackLeibler::Discrete;
$Math::KullbackLeibler::Discrete::VERSION = '0.07';
use 5.006;
use strict;
use warnings FATAL => 'all';
use parent 'Exporter';

our @EXPORT = qw(kl);


sub kl {
    my ($P, $Q, %opts) = @_;

    my $eps = 0.00001;

    $eps = $opts{epsilon} if exists $opts{epsilon};

    # Universe
    my $SU = {};
    $SU->{$_}++ for (keys %$P, keys %$Q);

    # | Universe - P |
    my $susp = scalar(keys %$SU) - scalar(keys %$P);

    # | Universe - Q |
    my $susq = scalar(keys %$SU) - scalar(keys %$Q);

    my $pc = $eps * ($susp/scalar(keys %$P));
    my $qc = $eps * ($susq/scalar(keys %$Q));

    my $Pline = sub {
        my $i = shift;
        return exists($P->{$i}) ? $P->{$i} - $pc : $eps;
    };
    my $Qline = sub {
        my $i = shift;
        return exists($Q->{$i}) ? $Q->{$i} - $qc : $eps;
    };

    my $kl = 0;
    for (keys %$SU) {
        $kl += $Pline->($_) * log($Pline->($_) / $Qline->($_));
    }

    return $kl;
}


1; # End of Math::KullbackLeibler::Discrete

__END__