String::Trigram - Find similar strings by trigram (or 1, 2, 4, etc.-gram) method

  use String::Trigram;

  my @cmpBase = qw(establishment establish establishes established disestablish disestablishmentarianism);

  my $trig = new String::Trigram(cmpBase => \@cmpBase);

  my $numOfSimStrings = $trig->getSimilarStrings("establishing", \%result);

  print "Found $numOfSimStrings similar strings.\n";

  foreach (keys %result) {
    print "Similar string $_ has a similarity of ", sprintf ("%02f", ($result{$_} * 100)), "%\n";
  }

  my $string1 = "foo";
  my $string2 = "boo";

  my $smlty = String::Trigram::compare($string1, $string2);

  print "$string1 and $string2 have a similarity of ", sprintf("%.2f", ($smlty * 100)), "%.\n";

  $smlty = String::Trigram::compare($string1, $string2);

  print "$string1 and $string2 have a similarity of ", sprintf("%.2f", ($smlty * 100)), "%.\n";

        1.0
  simi-  |                                   %            *      %
  larity |             %           *                   #         #
  value  |      %         *          #
         |            *     #
         |    %    *    #
         |       *   #
         |      *
         |   % * #
         |
         |   *
         |  % #
         |  *
         |                         ***  no warp (i.e. warp == 1.0)
         | %#                      %%%                    warp > 1
         | *                       ###                    warp < 1
         |________________________________________________________
        0.0
                                                  length of string

       Dependency of similarity value on length of string and warp

  my @base = qw(chimpanzee lion emu kangaroo);

  my $trig = new String::Trigram(cmpBase => \@base);

  my $trig = new String::Trigram(cmpBase        => \@base,
                                 minSim         => 0.5,
                                 warp           => 1.6,
                                 ignoreCase     => 0,
                                 keepOnlyAlNums => 1,
                                 ngram          => 5,
                                 debug          => 1);

  $trig->reInit(["zebra", "tiger", "snake", "gorilla", "kangaroo"]);

  $trig->extendBase(["zebra", "tiger", "snake", "gorilla", "kangaroo"]);

  $trig->minSim();
  $trig->minSim(0.8);

  $trig->warp();
  $trig->warp(1.4);

  $trig->ignoreCase();
  $trig->ignoreCase(0);

  $trig->keepOnlyAlNums();
  $trig->keepOnlyAlNums(1);

  $trig->padding();
  $trig->padding(2);

  $trig->debug();
  $trig->debug(1);

  my %results = ();
  my $numOfSimStrings = $trig->getSimilarStrings("zebrilla", \%results [, minSim => 0.6, warp => 0.7]);

  my @bestMatches = ();
  my $sim = $trig->getBestMatch("zebrilla", \@bestMatches [, minSim => 0.6, warp => 0.7]);

  my $sim = compare($string1, $string2);

  my $sim = compare($string1,
                    $string2,
                    minSim         => 0.3,
                    warp           => 1.8,
                    ignoreCase     => 0,
                    keepOnlyAlNums => 1,
                    ngram          => 5,
                    debug          => 1);

  compare()

package String::Trigram;

use Carp;
use locale;

use 5.6.0;
use strict;
use warnings;

require Exporter;
require DynaLoader;

our @ISA = qw(Exporter DynaLoader);
our @EXPORT_OK = ( 'compare' );
our $VERSION = '0.11';

bootstrap String::Trigram $VERSION;

our $DEFAULT_MIN_SIM          = 0;
our $DEFAULT_WARP             = 1.0;
our $DEFAULT_IGNORE_CASE      = 1;
our $DEFAULT_KEEP_ONLY_ALNUMS = 0;
our $DEFAULT_DEBUG            = 0;
our $DEFAULT_NGRAM_LEN        = 3;
our $DEFAULT_PADDING          = $DEFAULT_NGRAM_LEN - 1;

sub new
{
  my ($pkg, %params) = @_;

  my $seen = {};
  
  _setParams(\%params);

  foreach (keys %params)
  {
    croak "Unknown parameter $_!" if ($_ !~ /^(cmpBase|minSim|warp|ignoreCase|keepOnlyAlNums|padding|debug|ngram)$/);
  }

  # check for reasonable values
  if ((!$params{cmpBase}) or (ref(@{$params{cmpBase}} ne 'ARRAY')))
  {
    croak "We need a base for comparison, so you should specify the parameter cmpBase as a reference to an anonymous array of strings being the base of comparison. Don't bother specifying anything else, but this we do need.\n";
  }

  if (($params{minSim} < 0) || ($params{minSim} > 1.0))
  {
    croak "Minimal similarity must be >= 0 and <= 1.0";
  }

  if (defined $params{ngram} && ($params{ngram} <= 0))
  {
    croak "n in n-gram must be > 0";
  }

  if ($params{warp} == 0)
  {
    croak "Warp must be > 0";
  }

  if (($params{padding} < 0) || ($params{padding} > $params{ngram} - 1))
  {
    croak "Padding must be between 0 and " . ($params{ngram} - 1) . ".";
  }

  my $self = bless
  {
    ngram          => int ($params{ngram}),
    minSim         => $params{minSim},
    warp           => $params{warp},

    # index for trigrams
    trigIdx        => _trigramify($params{cmpBase},
				  $params{ignoreCase}, 
				  $params{keepOnlyAlNums},
				  ' ' x $params{padding},
				  undef,
				  $params{ngram},
				  $seen),

    # index of all strings fed to the object, so no string is 
    # processed twice (this might lead to wrong results)
    seenStrings    => $seen,

    ignoreCase     => $params{ignoreCase},
    keepOnlyAlNums => $params{keepOnlyAlNums},
    padding        => ' ' x $params{padding},
    debug          => $params{debug},

  }, $pkg;

  return $self;
}

sub compare
{
  my ($s1, $s2) = (shift, shift);

  croak "I need at least 2 strings to compare as parameters, died" unless defined $s2;

  my $result = {};

  new String::Trigram(cmpBase => [$s1], @_)->getSimilarStrings($s2, $result);

  $result->{$s1} || 0;
}

sub reInit
{
  my ($self, $newCmpBase) = @_;

  if ((!$newCmpBase) or (ref(@$newCmpBase ne 'ARRAY')))
  {
    croak "We need a base for comparison, so, as a parameter to this method, we do need a reference to an anonymous array of strings being the base of comparison.\n";
  }

  $self->{seenStrings} = {};

  $self->_setTrigIdx(_trigramify($newCmpBase,
				 $self->{ignoreCase},
				 $self->{keepOnlyAlNums},
				 $self->{padding},
		                 undef, 
				 $self->{ngram},
				 $self->{seenStrings}));
}

sub extendBase
{
  my ($self, $newStrings) = @_;

  if ((!$newStrings) or (ref(@$newStrings ne 'ARRAY')))
  {
    croak "We need to add to the base for comparison, so, as a parameter to this method, we do need a reference to an anonymous array of strings being added to the base of comparison.\n";
  }

  $self->_setTrigIdx(_trigramify($newStrings,
				 $self->{ignoreCase},
				 $self->{keepOnlyAlNums},
				 $self->{padding},
				 $self->{trigIdx},
				 $self->{ngram},
				 $self->{seenStrings}));
}

sub minSim
{
  my ($self, $newMinSim) = @_;

  if ((defined $newMinSim) && ((($newMinSim < 0) || ($newMinSim > 1.0))))
  {
    croak "Minimal similarity must be >= 0 and <= 1.0";
  }

  $self->{minSim} = $newMinSim if ($newMinSim);

  return $self->{minSim};
}

sub warp
{
  my ($self, $newWarp) = @_;

  if ((defined $newWarp) && ($newWarp <= 0))
  {
    croak "Warp must be > 0";
  }

  $self->{warp} = $newWarp if ($newWarp);

  return $self->{warp};
}

sub ignoreCase
{
  my ($self, $newIgnoreCase) = @_;

  $self->{ignoreCase} = $newIgnoreCase if ($newIgnoreCase);

  return $self->{ignoreCase};
}

sub keepOnlyAlNums
{
  my ($self, $newKeepOnlyAlNums) = @_;

  $self->{keepOnlyAlNums} = $newKeepOnlyAlNums if ($newKeepOnlyAlNums);

  return $self->{keepOnlyAlNums};
}

sub padding
{
  my ($self, $newPadding) = @_;

  if ((defined $newPadding) && ((($newPadding < 0) || ($newPadding > $self->{ngram} - 1))))
  {
    croak "Padding must be between 0 and " . $self->{ngram} - 1 . ".";
  }

  $self->{padding} = ' ' x $newPadding if ($newPadding);

  return length $self->{padding};
}

sub debug
{
  my ($self, $newDebug) = @_;

  $self->{debug} = $newDebug if (defined($newDebug));

  return $self->{debug};
}

# Splits str into trigrams and looks up every trigram in trigIdx. If
# successfull, it finds a list of strings containing the trigram and
# increases the value of the string containing the trigram by 1 in the
# lexical $simInfo (ref. to hash). Uses _computeSimilarity() to compute
# the similarity value.
#
# Parameters
#
# result KEY = matching string, VALUE = similarity value
# str    string to be matched
# data   further key-val-pairs for min sim and warp
#
# Returns
#
# 0-n number of similar strings
# -1  no match found

sub getSimilarStrings
{
  my $self    = shift;
  my $str     = shift;
  my $result  = shift;
  my %data    = @_ if @_;

  my $curMinSim = $data{minSim};
  my $curWarp   = $data{warp};

  $curMinSim ||= $self->{minSim};
  $curWarp   ||= $self->{warp};

  croak "I need a reference to a hash as second parameter for getSimilarStrings()!" if (ref($result) ne 'HASH');

  my $trigram;      # contains current trigram
  my $matches;      # is pointed to all strings containing current trigram
  my $len;          # length of the string to compare
  my $actNum;       # that's how many times current trigram is found in string
  my $actName;      # this is a string containing current trigram
  my $actMatch;     # current match

  # KEY = trigram, SUBKEY = potentially similar string, VALUE = number
  # of times, trigrams is found in string.
  # Here the frequency of every trigram in every string is saved. The
  # table is filled with the existing strings containing some trigram
  # the frequencys of the trigram in the string are noted and decreased
  # every time, a matching trigram is found until the value is 0. If
  # the value is 0, a match cannot be counted anymore.
  my %trigNumBuf = ();

  # KEY = potentially similar string, VALUE = number of identical trigrams
  my $simInfo = {};

  $str =~ s/\W//g if $self->{keepOnlyAlNums};
  $str = lc $str  if $self->{ignoreCase};

  $str = $self->{padding} . $str . $self->{padding};

  # Number of n-grams is length of string minus n + 1
  $len = length($str) - $self->{ngram} + 1;

  # **********************************************************
  # divide string to compare into trigrams and search trigrams
  # **********************************************************

  for (my $i = 0; $i < $len; $i++)
  {
    $trigram = substr($str, $i, $self->{ngram});

    # look for every trigram in $self->{trigIdx}
    # contine unless found
    next unless (exists($self->{trigIdx}->{$trigram}));

    # point matches to strings containing current trigram
    $matches = $self->{trigIdx}->{$trigram};

    # check every string containing current trigram
    while (($actName, $actMatch) = each %$matches)
    {
      $actNum  = $actMatch->{trigs}; # so many times current trigram is found in string

      $trigNumBuf{$trigram}->{$actName} = $actNum unless (exists($trigNumBuf{$trigram}->{$actName}));

      # if there are instances of current trigram left for string
      if ($trigNumBuf{$trigram}->{$actName} > 0)
      {
        # mark that we used on instance of current trigram
        $trigNumBuf{$trigram}->{$actName}--;

        # mark that we have found one more matching trigram for $actName
        $simInfo->{$actName}->{name}++;
        $simInfo->{$actName}->{len} = $actMatch->{len};
      }
    }
  }

  return $self->_computeSimilarity($str, $simInfo, $result, $curMinSim, $curWarp);
}

# Uses getSimilarStrings() to get matching strings and filters out the
# best one(s).
#
# Parameters
#
# $inpStr     string to be matched
# $outStrList list of best strings
#
# Returns
#
# similarity value of best match or -1, of no match

sub getBestMatch
{
  my $self       = shift;
  my $inpStr     = shift;
  my $outStrList = shift;

  croak "I need a reference to an array as second parameter for getBestMatch()!" if (ref($outStrList) ne 'ARRAY');

  my $maxVal     = -1; # similarity of maximally similar string
  my $name       = ""; # current potentially similar string
  my $val        = -1; # similarity of $name
  my $rslt       = {}; # KEY = similar name, VALUE = degree of similarity
  my @rsltKeys   = (); # contains keys(%rslt)

  # clear list ultimatively containing similar strings
  @$outStrList = ();

  # there are no similar strings at all
  if ($self->getSimilarStrings($inpStr, $rslt, @_) == 0)
  {
    return 0;
  }

  # there is at least one similar string
  @rsltKeys = keys(%$rslt);

  # looking for the best matching string, make the first one the best ...
  $name   = $rsltKeys[0];
  $maxVal = $rslt->{$name};

  # since there might be several best strings (containing same degree of similarity)
  # we put them into an array and not into a scalar
  push @$outStrList, $name;

  # ... and check if there are better ones
  for (1 .. @rsltKeys - 1)
  {
    $name = $rsltKeys[$_];
    $val  = $rslt->{$rsltKeys[$_]};

    if ($val == $maxVal)
    {
      push @$outStrList, $name;
    }
    elsif ($val > $maxVal)
    {
      # if we found a still better string, clear the array and put the better string into it
      @$outStrList = ();
      $maxVal = $val;
      push @$outStrList, $name;
    }
  }

  return $maxVal;
}

sub _setTrigIdx
{
  my ($self, $newTrigIdx) = @_;

  $self->{trigIdx} = $newTrigIdx;
}

sub _getTrigIdx
{
  my $self = shift;
  return $self->{trigIdx};
}

# Computes similarity of potientially matching strings in hash
# newSimInfo. The result is saved in newResult. The computation of the
# similarity works like this:
#
# (a = all trigrams, d = different trigrams, e = warp)
#
# (a**e - d**e)/a**e
#
# The default for e is 1. If e is > 1.0, short strings are getting away
# better, if e is < 1.0 short strings are getting away worse.
#
# Parameters
#
# $newStr     string to be matched
# $newSimInfo KEY = potentially matching string, VALUE = number of matching trigrams
# $newResult  KEY = actually matching string, VALUE = similarity value
# $curMinSim  current minimal similarity
# $curWarp    current warp
#
# Returns
#
# number of matching strings

sub _computeSimilarity
{
  my $self       = shift;
  my $newStr     = shift;
  my $newSimInfo = shift;
  my $newResult  = shift;
  my $curMinSim  = shift;
  my $curWarp    = shift;

  # clear hash containing the results
  %$newResult = ();

  my $strCnt    = 0;                            # number of similar strings (return value)
  my $allTrigs;                                 # number of all trigrams
  my $sameTrigs;                                # number of same trigrams
  my $actSim;                                   # similarity (0 - 1)
  my $len       = length($newStr);              # length of string - $padNum for the padded blanks

  # check every potientially similar string (i.e. every string containing at least one
  # identical trigram)
  foreach (keys(%$newSimInfo))
  {
    $sameTrigs = $newSimInfo->{$_}->{name};
    
    # the number of n-grams in a string result from subtracting n from the length of
    # the string and adding 1. If it is padded with blanks, there is one additional
    # n-gram for each blank. So to compute the number of n-grams of two strings we
    # subtract n twice, add 2 and add the number of padded blanks * 2. Since $newStr
    # is already padded and the length noted for $_ contains already the padding we
    # do not need to take the padding explicitly into account. Finally, to get
    # $allTrigs (types not tokens) we need to subtract the number of matching trigrams
    # - those occuring in both strings - once.
    $allTrigs = $len + $newSimInfo->{$_}->{len} - 2 * $self->{ngram} - $sameTrigs + 2;

    $actSim = _computeActSim($sameTrigs, $allTrigs, $curWarp);

    if ($self->{debug})
    {
	my $tmpStr = $self->{padding} . $_ . $self->{padding};
      print STDERR "\nCompare\n";
      print STDERR "$newStr ->", sort join (":", $newStr =~ /(?=(...))/g), "<-\n";
      print STDERR "$tmpStr ->", sort join (":", $tmpStr  =~ /(?=(...))/g), "<-\n";
      print STDERR "-" x (22 + length ($newStr) + 2 * length ($self->{padding}) + length ($_)), "\n";
      print STDERR "N-GRAM-LEN: ", $self->{ngram}, "\n";
      print STDERR "ALL :       ", $allTrigs, "\n";
      print STDERR "SAME:       ", $sameTrigs, "\n";
      print STDERR "DIFF:       ", $allTrigs - $sameTrigs, "\n";
      print STDERR "ACTSIM:     ", $actSim, "\n";
      print STDERR "PADDING:    ", length $self->{padding}, "\n";
      print STDERR "MINSIM:     ", $self->{minSim}, "\n";
      print STDERR "WARP:       ", $curWarp, "\n\n";
    }

    # count string as similar only if similarity exceeds minimal similarity
    if ($actSim > $curMinSim)
    {
      $newResult->{$_} = $actSim;
      $strCnt++;
    }
  }

  return $strCnt;
}

sub _computeActSimOld {
	my $sameTrigs = shift;
	my $allTrigs  = shift;
	my $curWarp   = shift;

	my $diffTrigs = -1; # number of different trigrams
	my $actSim    = -1; # similarity (0 - 1)

    # no warp here so skip the complicated stuff below
    if ($curWarp == 1) {
	$actSim = $sameTrigs/$allTrigs;
    } else {
	# we've got to take warp into account
	$diffTrigs = $allTrigs - $sameTrigs;
	$actSim = (($allTrigs**$curWarp) - ($diffTrigs**$curWarp)) / ($allTrigs**$curWarp);
    }
}

# Takes list of strings and puts them into an index of trigrams. KEY is a trigram,
# VALUE a list of strings containing that trigram. VALUE has two KEYS:
#
# trigs: count of trigram occurring in string
# len:   length of string (if $keepAlNums, after applying s/\W//g)
#
# Parameters
#
# $list       list of strings being the base of comparison
# $ignoreCase ignore case if 1
# $keepAlNums s/\W//g if 1
# $pad        contains 0 - 2 blanks for padding
#
# Returns
#
# trigram index

sub _trigramify
{
  my $list       = shift;
  my $ignoreCase = shift;
  my $keepAlNums = shift;
  my $pad        = shift;
  my $trigs      = shift;
  my $ngram      = shift;
  my $seen       = shift;
  my $tmpStr;
  my $len;
  
  foreach (@$list)
  {
    $tmpStr = $_;

   $tmpStr =~ s/\W//g   if $keepAlNums;
    $tmpStr = lc $tmpStr if $ignoreCase;

    next if exists $seen->{$tmpStr};
    $seen->{$tmpStr} = 1;

    $tmpStr = $pad . $tmpStr . $pad;

    $len = length($tmpStr);

    for (my $i = 0; $i < (length($tmpStr) - $ngram + 1); $i++)
    {
      $trigs->{substr($tmpStr, $i, $ngram)}->{$_}->{trigs}++;
      $trigs->{substr($tmpStr, $i, $ngram)}->{$_}->{len} = $len;
    }
  }

  return $trigs;
}

sub _setParams
{
  my $params = shift;

  # set defaults, if not specified otherwise
  $params->{ngram}          = $DEFAULT_NGRAM_LEN        unless exists $params->{ngram};
  $params->{minSim}         = $DEFAULT_MIN_SIM          unless exists $params->{minSim};
  $params->{warp}           = $DEFAULT_WARP             unless exists $params->{warp};
  $params->{ignoreCase}     = $DEFAULT_IGNORE_CASE      unless exists $params->{ignoreCase};
  $params->{keepOnlyAlNums} = $DEFAULT_KEEP_ONLY_ALNUMS unless exists $params->{keepOnlyAlNums};
  $params->{padding}        = $params->{ngram} - 1      unless exists $params->{padding};
  $params->{debug}          = $DEFAULT_DEBUG            unless exists $params->{debug};
}

1;
__END__