Text::DeDuper - near duplicates detection module

    use Text::DeDuper;

    $deduper = new Text::DeDuper();
    $deduper->add_doc("doc1", $doc1text);
    $deduper->add_doc("doc2", $doc2text);

    @similar_docs = $deduper->find_similar($doc3text);

    ...

    # delete near duplicates from an array of texts
    $deduper = new Text::DeDuper();
    foreach $text (@texts)
    {
        next if $deduper->find_similar($text);

        $deduper->add_doc($i++, $text);
        push @no_near_duplicates, $text;
    }

    $deduper = new Text::DeDuper(<attribute-value-pairs>);

    $deduper->add_doc($document_id, $document_text);

    $deduper->find_similar($document_text);

    if ($deduper->find_similar($document_text))
    {
        print "at least one near duplicate found";
    }

    $deduper->clean()

    $deduper = new Text::DeDuper(
        ngram_size => 4,
        encoding   => 'iso-8859-1'
    );

    $deduper->ngram_size(4);
    $deduper->encoding('iso-8859-1');

    $ngram_size = $deduper->ngram_size();
    @stoplist   = $deduper->stoplist();

package Text::DeDuper;

use strict;
use warnings;
use vars qw($VERSION);

use Digest::MD4;
use Encode;

$VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d", @r };

sub new
{
    my $class   = shift;
    my %options = @_;

    my $self = bless {
        ngram_size => 5,
        sim_trsh   => 0.2,
        encoding   => 'utf8',
        _stoplist     => {},
        _digest_count => {},
        _doc_ids      => {},
    }, $class;

    $self->stoplist(  $options{stoplist});
    $self->ngram_size($options{ngram_size});
    $self->sim_trsh(  $options{sim_trsh});
    $self->encoding(  $options{encoding});

    return $self;
}

sub add_doc
{
    my $self  = shift;
    my $docid = shift;
    my $text  = shift;

    croak("duplicate document id '$docid'")
        if defined $self->{_digest_count}->{$docid};
    
    my @tokens = $self->_tokenise($text);
    my @filtered_tokens = $self->_apply_stoplist(@tokens);
    my @digests = $self->_build_ngram_digests(@filtered_tokens);

    $self->{_digest_count}->{$docid} = scalar(@digests);
    foreach my $digest (@digests)
    {
        if (not defined $self->{_doc_ids}->{$digest})
            { $self->{_doc_ids}->{$digest} = [ $docid ]; }
        else
            { push @{$self->{_doc_ids}->{$digest}}, $docid; }
    }
}

sub find_similar
{
    my $self = shift;
    my $text = shift;

    my @tokens = $self->_tokenise($text);
    my @filtered_tokens = $self->_apply_stoplist(@tokens);
    my @digests = $self->_build_ngram_digests(@filtered_tokens);

    # compute intersection sizes with all documents in the database
    my %intersection_size;
    foreach my $digest (@digests)
    {
        next
            unless defined($self->{_doc_ids}->{$digest});

        foreach my $docid (@{$self->{_doc_ids}->{$digest}})
        { 
            if (defined $intersection_size{$docid})
                { $intersection_size{$docid}++; }
            else
                { $intersection_size{$docid} = 1; }
        }
    }

    my @similar;
    foreach my $docid (keys %intersection_size)
    {
        # union size
        my $union_size = scalar(@digests) + $self->{_digest_count}->{$docid} -
            $intersection_size{$docid};
        # resemblance
        my $resemblance = $union_size > 0 ?
            $intersection_size{$docid} / $union_size : 0;
        # return docs with resemblance above treshold
        push @similar, $docid
            if $resemblance > $self->{sim_trsh};
    }

    return @similar;
}

sub clean
{
    my $self = shift;
    
    $self->{_doc_ids}      = {};
    $self->{_digest_count} = {};
}

sub encoding
{
    my $self     = shift;
    my $encoding = shift;
    $self->{encoding} = $encoding
        if defined $encoding;
    return $self->{encoding};
}

sub sim_trsh
{
    my $self     = shift;
    my $sim_trsh = shift;
    $self->{sim_trsh} = $sim_trsh
        if defined $sim_trsh;
    return $self->{sim_trsh};
}

sub ngram_size
{
    my $self     = shift;
    my $ngram_size = shift;
    $self->{ngram_size} = $ngram_size
        if defined $ngram_size;
    return $self->{ngram_size};
}

sub stoplist
{
    my $self     = shift;
    my @stoplist = @_;
    if (@stoplist && defined $stoplist[0])
    {
        if (@stoplist == 1 && -f $stoplist[0])
            { $self->_process_stoplist($stoplist[0]); }
        else
            { $self->_process_stoplist(\@stoplist); }
    }
    return sort keys %{$self->{_stoplist}};
}

# process stoplist attribute value
sub _process_stoplist
{
    my $self     = shift;
    my $stoplist = shift;

    $self->{_stoplist} = {};

    return unless
        defined $stoplist;

    # if not array, treat as filename
    if (ref($stoplist) ne 'ARRAY')
    {
        open(STOPLIST, '<', $stoplist)
            or croak("can't open '$stoplist' for reading: $!");
        while (<>)
        {
            chomp;
            $self->{_stoplist}->{$_} = 1;
        }
        close(STOPLIST);
    }
    else
    {
        foreach (@$stoplist)
            { $self->{_stoplist}->{$_} = 1; }
    }
}

# convert text into array of tokens (words)
sub _tokenise
{
    my $self = shift;
    my $text = shift;

    no warnings;
    my $dec_text = Encode::decode($self->{encoding}, $text);
    my $lc_text  = lc($dec_text);

    my @result;
    while ($lc_text =~ /([[:alnum:]]+)/g)
        { push @result, Encode::encode($self->{encoding}, $1); }
    use warnings;

    return @result;
}

# apply stoplist to array tokens (filter out stop words)
sub _apply_stoplist
{
    my $self   = shift;
    my @tokens = @_; 

    my @result;
    foreach my $token (@tokens)
    {
        push @result, $token
            unless $self->{_stoplist}->{$token};
    }

    return @result;
}

# convert array of tokens to array of unique hashes
# of ngrams (built out of the tokens)
sub _build_ngram_digests
{
    my $self   = shift;
    my @tokens = @_;

    my %digests;
    for my $i (0 .. scalar(@tokens) - $self->{ngram_size})
    {
        my @ngram  = @tokens[$i..($i+$self->{ngram_size}-1)];
        my $digest = Digest::MD4::md4_base64(@ngram);
        $digests{$digest} = 1;
    }

    return keys(%digests);
}

1;

__END__