File Coverage

blib/lib/Text/Similarity/Overlaps.pm

Criterion	Covered	Total	%
statement	111	136	81.6
branch	21	32	65.6
condition			n/a
subroutine	14	15	93.3
pod	1	5	20.0
total	147	188	78.1

package Text::Similarity::Overlaps;

use 5.006;
use strict;
use warnings;

use Text::Similarity;
use Text::OverlapFinder;

our @ISA = qw(Text::Similarity);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Text::Similarity::Overlaps ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

our $VERSION = '0.05';

# information about granularity is not used now
# the would be that you could figure out similarity
# unit by unit, that is sentence by sentence,
# paragraph by paragraph, etc. however, at this
# point similarity is only computed document by
# document

use constant WORD      => 0;
use constant SENTENCE  => 1;
use constant PARAGRAPH => 2;
use constant DOCUMENT  => 3;

my %finder;

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new (@_);
    if ($self->stoplist) {
	$finder{$self} = Text::OverlapFinder->new(stoplist => $self->stoplist);
    }
    else {
	$finder{$self} = Text::OverlapFinder->new;
    }

    #string_compare_initialize (0, undef);
    return $self;
}


sub finder : lvalue
{
    my $self = shift;
    $finder{$self};
}

sub DESTROY
{
    my $self = shift;
    delete $finder{$self};
}

# this method requires that the input be provided in files.
# this is now just a front end to getSimilarityStrings that
# does file handling. Actual similarity measurements are
# performed between strings in getSimilarityStrings.

# this seems like it might want to move up into Similarity.pm

sub getSimilarity
{
    my $self = shift;

    # we created a separate method for getSimilarityStrings since overloading
    # to accept both strings and file names as input parameters to
    # getSimilarity would have required that we treat any file name that does
    # not have a corresponding file to be treated as a string, thus making it
    # impossible to really deal with missing file errors, and probably resulting
    # in quite a bit of user annoyance as 'textt1.txt' is measured for similarity
    # with the contents of 'text2.txt'

    my $file1 = shift;
    my $file2 = shift;

    # granularity is not currently supported

    my $granularity = shift;
    $granularity = DOCUMENT unless defined $granularity;

    unless (-e $file1) {
	$self->error ("The file '$file1' does not exist");
	return undef;
    }
    unless (-e $file2) {
	$self->error ("The file '$file2' does not exist");
	return undef;
    }

    unless (open (FH1, '<', $file1)) {
	$self->error ("Cannot open $file1: $!");
	return undef;
    }
    unless (open (FH2, '<', $file2)) {
	$self->error ("Cannot open $file2: $!");
	return undef;
    }

    my $str1;
    my $str2;
    while () {
	$str1 .= $self->sanitizeString ($_);
    }
    $str1 =~ s/\s+/ /g;
    while () {
	$str2 .= $self->sanitizeString ($_);
    }
    $str2 =~ s/\s+/ /g;

    # find compounds, not working right now

    $str1 = $self->compoundify ($str1);
    $str2 = $self->compoundify ($str2);

    close FH1;
    close FH2;

# add this call, to expose this method to users too (in case they want to
# just measure the similarity of two strings. So we have our files converted
# into strings, and now measure their similarity.

    my ($score, %allScores) = $self -> getSimilarityStrings ($str1,$str2);

# end getSimilarity here, making sure to return similarity value from
# get SimilarityStrings

    return wantarray ? ($score, %allScores) : $score;
}

# this method measures the similarity between two strings. If a string is empty
# or missing then we generate an error and return undefined

sub getSimilarityStrings {

    my $self = shift;

    my $input1 = shift;
    my $input2 = shift;

# check to make sure you have a string! empty file or string should be rejected

    if (!defined($input1)) {
	    $self->error ("first input string is undefined: $!");
	    return undef;
    }
    if (!defined($input2)) {
	    $self->error ("second input string is undefined: $!");
	    return undef;
    }

    # clean the strings, maybe make this optional

    my $str1 .= $self->sanitizeString ($input1);
    my $str2 .= $self->sanitizeString ($input2);

    # find compounds, not working right now

    $str1 = $self->compoundify ($str1);
    $str2 = $self->compoundify ($str2);

    # this is where we find our overlaps....
    # then we score them using both the standard overlaps measure
    # as well as based on the lesk.pm module from WordNet-Similarity

    my ($overlaps, $wc1, $wc2) = $self->finder->getOverlaps ($str1, $str2);

    my $score = 0;
    my $raw_lesk = 0;
    my %allScores = ('wc1' => $wc1, 'wc2' => $wc2);

    if ($self->verbose) {
	print STDERR "keys: ", scalar keys %$overlaps, "\n";
    }

    foreach my $key (sort keys %$overlaps) {

	my @words = split /\s+/, $key;

	if ($self->verbose) {
	    print STDERR "-->'$key' len(", scalar @words, ") cnt(", $overlaps->{$key}, ")\n";
	}

	    # find out how many words match, add 1 for each match

	#$score += scalar @words * scalar @words * ${$overlaps}{$key};
	$score += scalar @words * $overlaps->{$key};
	$allScores{'raw'} = $score;
            # find the length of the key, square it, multiply with its
            # value to get the lesk score for this particular match

        my $value = ($#words + 1) * ($#words + 1) * ${$overlaps}{$key};
        $raw_lesk += $value;

    }

    # fix for divide by zero error, will short circuit when score is 0
    # provided by cernst at esoft.com
    # who reported via rt.cpan.org ticket 29902

    if ($score == 0){
	$allScores{'raw'} = 0;
	$allScores{'precision'} = 0;
	$allScores{'recall'} = 0;
	$allScores{'F'} = 0;
	$allScores{'dice'} = 0;
	$allScores{'E'} = 0;
	$allScores{'cosine'} = 0;
	$allScores{'raw_lesk'} = 0;
	$allScores{'lesk'} = 0;

	return wantarray ? ($score, %allScores) : $score;
    }

    # end of fix

    my $prec = $score / $wc2;
    my $recall = $score / $wc1;
    my $f = 2 * $prec * $recall / ($prec + $recall);

    my $dice = 2 * $score / ($wc1 + $wc2) ;
    my $e = 1 - $f;
    my $cos = $score / sqrt ($wc1 * $wc2);
    my $lesk = $raw_lesk/ ($wc1 * $wc2);

    $allScores{'precision'} = $prec;
    $allScores{'recall'} = $recall;
    $allScores{'F'} = $f;
    $allScores{'dice'} = $dice;
    $allScores{'E'} = $e;
    $allScores{'cosine'} = $cos;
    $allScores{'raw_lesk'} = $raw_lesk;
    $allScores{'lesk'} = $lesk;

    # display them, if requested
    if ($self->verbose) {
	print STDERR "wc 1: $wc1\n";
	print STDERR "wc 2: $wc2\n";
	print STDERR " Raw score: $score\n";
	print STDERR " Precision: $prec\n";
	print STDERR " Recall   : $recall\n";
	print STDERR " F-measure: $f\n";
	print STDERR " Dice     : $dice\n";
	print STDERR " E-measure: $e\n";
	print STDERR " Cosine   : $cos\n";
	print STDERR " Raw lesk : $raw_lesk\n";
	print STDERR " Lesk     : $lesk\n";

#
# include might be the jaccard coefficient ....
# jaccard is 2*raw_score / union of string1 and string2
#
    }

    if ($self->normalize) {
	$score = $f;
    }

    return wantarray ? ($score, %allScores) : $score;
}

sub doStop {0}

1;

__END__