source: gsdl/trunk/perllib/textcat.pm@ 16554

###########################################################################
#
# textcat.pm -- Identify the language of a piece of text
#
#
# This file is based on TextCat version 1.08 by Gertjan van Noord
# Copyright (C) 1997 Gertjan van Noord ([email protected])
# TextCat is available from: http://odur.let.rug.nl/~vannoord/TextCat 
#
# It was modified by Gordon Paynter ([email protected]) and turned
# into a package for use in Greenstone digital library system.  Most of
# the modifications consist of commenting out or deleting functionality
# I don't need.  
#
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################

package textcat;

use strict;

# OPTIONS
my $model_dir = $ENV{'GSDLHOME'} . "/perllib/textcat";

my $opt_f = 1;                # Ngrams which occur <= this number of times are removed
my $opt_t = 400;              # topmost number of ngrams that should be used
my $opt_u = 1.05;             # how much worse result must be before it is ignored

my $non_word_characters = '0-9\s';

# caching related
my %cache = (); # map of cached text-strings each to array of char-encodings
my $MAX_CACHE_SIZE = 1000;

sub new {
    my $class = shift (@_);
    my ($tmp_f, $tmp_t, $tmp_u) = @_;

    my $self = {};

    # open directory to find which languages are supported
    opendir DIR, "$model_dir" or die "directory $model_dir: $!\n";
    my @languages = sort(grep { s/\.lm// && -r "$model_dir/$_.lm" } readdir(DIR));
    closedir DIR;
    @languages or die "sorry, can't read any language models from $model_dir\n" .
    "language models must reside in files with .lm ending\n";

    # load model and count for each language.
    foreach my $language (@languages) {
    my %ngram=();
    my $rang=1;
    open(LM, "$model_dir/$language.lm") || die "cannot open $language.lm: $!\n";
    while (<LM>) {
        chomp;
        # only use lines starting with appropriate character. Others are ignored.
        if (/^[^$non_word_characters]+/o) {
        $self->{'ngrams'}->{$language}->{$&} = $rang++;
        } 
    }
    close(LM);
    }

    $self->{'languages'} = \@languages;

    $self->{'opt_f'} = defined($tmp_f) ? $tmp_f : $opt_f;
    $self->{'opt_t'} = defined($tmp_t) ? $tmp_t : $opt_t;
    $self->{'opt_u'} = defined($tmp_u) ? $tmp_u : $opt_u;
    $self->{'max_cache_size'} = $MAX_CACHE_SIZE;

    return bless $self, $class;
}



# CLASSIFICATION
#
# What language is a text string?
#   Input:  text string
#   Output: array of language names

sub classify {
    my ($self, $inputref, $opt_freq, $opt_factor, $opt_top)=@_;
    
    $self->{'opt_f'} = $opt_freq if defined $opt_freq;
    $self->{'opt_u'} = $opt_factor if defined $opt_factor;
    $self->{'opt_t'} = $opt_top if defined $opt_top;
    
    my %results = ();
    my $maxp = $self->{'opt_t'};

    # create ngrams for input.
    my $unknown = $self->create_lm($inputref);

    foreach my $language (@{$self->{'languages'}}) {
    
    # compare language model with input ngrams list
    my ($i,$p)=(0,0);
    while ($i < scalar (@$unknown)) {
        if (defined ($self->{'ngrams'}->{$language}->{$unknown->[$i]})) {
        $p=$p+abs($self->{'ngrams'}->{$language}->{$unknown->[$i]}-$i);
        } else { 
        $p=$p+$maxp; 
        }
        ++$i;
    }
    $results{$language} = $p;
    }

    my @results = sort { $results{$a} <=> $results{$b} } keys %results;
    my $a = $results{$results[0]};
  
    my @answers=(shift(@results));
    while (@results && $results{$results[0]} < ($self->{'opt_u'} *$a)) {
    @answers=(@answers,shift(@results));
    }

    return \@answers;
}

# Same as above, but caches textcat results for subsequent use.
# The cache is a map of the string to the corresponding array of results 
# returned by textcat of the possible filename-encodings for that string.
# Use this method for short strings (such as filenames) rather than huge text
# files. The cache will be cleared when the max_cache_size is reached, which
# is MAX_CACHE_SIZE by default or can be specified as a parameter. The cache
# can also be cleared by a call to clear_cache.
sub classify_cached {
    my ($self, $inputref, $opt_freq, $opt_factor, $opt_top, $max_size_of_cache)=@_;
    $self->{'max_cache_size'} = $max_size_of_cache if defined $max_size_of_cache;
    
    # if not already in the cache, work it out and put it there
    if (!defined $cache{$$inputref}) 
    {
    if (scalar (keys %cache) >= $self->{'max_cache_size'}) {
        $self->clear_cache();
    }
##  print STDERR "$$inputref is not yet in the cache\n";
    $cache{$$inputref} = $self->classify($inputref, $opt_freq, $opt_factor, $opt_top);
    } else {
##  print STDERR "$$inputref is already in the cache\n";
    }

##    print STDERR "Count of elements in cache is now: ".scalar (keys %cache)."\n";

    # return cached array of encodings for the given string
    return $cache{$$inputref}; 
}

# Clears the cache (a map of strings to the textcat results for each string).
sub clear_cache {
    my $self = shift (@_);

    %cache = undef; # does this suffice to release memory?
    %cache = ();
}

sub create_lm {
    # $ngram contains reference to the hash we build
    # then add the ngrams found in each word in the hash
    my ($self, $textref) = @_;  
    
    my $ngram = {};

    foreach my $word (split(/[$non_word_characters]+/, $$textref)) {
    $word = "_" . $word . "_";
    my $len = length($word);
    my $flen=$len;
    my $i;

    for ($i=0; $i<$flen; $i++) {
        $ngram->{substr($word,$i,5)}++ if $len > 4;
        $ngram->{substr($word,$i,4)}++ if $len > 3;
        $ngram->{substr($word,$i,3)}++ if $len > 2;
        $ngram->{substr($word,$i,2)}++ if $len > 1;
        $ngram->{substr($word,$i,1)}++;
        $len--;
    }
    }

    map { if ($ngram->{$_} <= $self->{'opt_f'}) { delete $ngram->{$_}; }
      } keys %$ngram;
  
    # sort the ngrams, and spit out the $opt_t frequent ones.
    # adding  `or $a cmp $b' in the sort block makes sorting five
    # times slower..., although it would be somewhat nicer (unique result)
    my @sorted = sort { $ngram->{$b} <=> $ngram->{$a} } keys %$ngram;
    splice(@sorted,$self->{'opt_t'}) if (@sorted > $self->{'opt_t'}); 
    return \@sorted;
}

1;