File Coverage

blib/lib/Text/Ngrams.pm

Criterion	Covered	Total	%
statement	293	332	88.2
branch	117	158	74.0
condition	35	48	72.9
subroutine	22	23	95.6
pod	8	8	100.0
total	475	569	83.4

# (c) 2003-2017 Vlado Keselj http://web.cs.dal.ca/~vlado
#
# Text::Ngrams - A Perl module for N-grams processing

package Text::Ngrams;

use strict;
require Exporter;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);
%EXPORT_TAGS = ( 'all' => [ qw(new encode_S decode_S) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = qw(new);
$VERSION = '2.006';

use vars qw($Version);
$Version = $VERSION;

use vars @EXPORT_OK;
use vars qw();			# non-exported package globals go here

sub new {
  my $package = shift;
  $package = ref($package) || $package;
  my $self = {};

  my (%params) = @_;

  $self->{windowsize} = exists($params{windowsize}) ?
      $params{windowsize} : 3;
  die "nonpositive window size: $self->{windowsize}" unless $self->{windowsize} > 0;
  delete($params{windowsize});

  if (! exists($params{type}) or $params{type} eq 'character') {
      $self->{skiprex} = '';
      $self->{tokenrex} = qr/([a-zA-Z]|[^a-zA-Z]+)/;
      $self->{processtoken} =  sub { s/[^a-zA-Z]+/ /; $_ = uc $_ };
      $self->{allow_iproc} = 1;
  }
  elsif ($params{type} eq 'utf8') {
      $self->{skiprex} = '';
      $self->{tokenrex} = qr/([\xF0-\xF4][\x80-\xBF][\x80-\xBF][\x80-\xBF]
                             |[\xE0-\xEF][\x80-\xBF][\x80-\xBF]
                             |[\xC2-\xDF][\x80-\xBF]
                             |[\x00-\xFF])/x;
      $self->{processtoken} = '';
  }
  #MJ ->
  #this type is analogous to the "character" type but defined for utf8 characters
  elsif ($params{type} eq 'utf8_character') {
    # $self->{inputlayer}
    # input layer to be put on the input stream by the function binmode
    # before reading from a given stream and to be removed by
    # ***binmode HANDLE,":pop"*** after the reading from the particular
    # stream is done has to be a real layer (like ":encoding(utf8)"), not a
    # pseudo layer (like ":utf8") so that the psuedo layer ":pop" is able to
    # remove this input layer

    $self->{inputlayer} = ':encoding(utf8)';
    # this will automatically decode input text from utf8 into Perl internal
    # reporesentation of Unicode strings and so the regular expressions for
    # Unicode as well as the uc function can be performed on them

    $self->{skiprex} = '';

    $self->{tokenrex} = qr/(\p{IsAlpha}|\P{IsAlpha}+)/;

    $self->{processtoken} =  sub { s/\P{IsAlpha}+/ /; $_ = uc $_ ;
				   $_ = Encode::encode_utf8( $_ ); };
    # the last operation ***$_=Encode::encode_utf8( $_ )*** is necessary
    # to go back to utf8 encoding from the internal Perl representation
    # so that for the output the n-grams are in utf8 (encoded by encode_S though)

      $self->{allow_iproc} = 0;
      # allow_iproc has to be 0. Otherwise the last token in the read block will
      # be preprocessed and encoded in utf8,
      # and then attached at the beginning of the next block read from input,
      # which will be in the internal Perl representation
  }
  #MJ <-
  elsif ($params{type} eq 'byte') {
      $self->{skiprex} = '';
      $self->{tokenrex} = '';
      $self->{processtoken} = '';
  }
  elsif ($params{type} eq 'word') {
      $self->{skiprex} = qr/[^a-zA-Z0-9]+/;
      $self->{skipinsert} = ' ';
      $self->{tokenrex} = qr/([a-zA-Z]+|(\d+(\.\d+)?|\d*\.\d+)([eE][-+]?\d+)?)/;
      $self->{processtoken} = sub { s/(\d+(\.\d+)?|\d*\.\d+)([eE][-+]?\d+)?// }
  }
  else { die "unknown type: $params{type}" }
  delete($params{type});

  $self->{'table'} = [ ];
  $self->{'total'} = [ ];
  $self->{'total_distinct_count'} = 0;
  $self->{'lastngram'} = [ ];
  $self->{'next_token_id'} = 0;
  $self->{'token_dict'} = { };
  $self->{'token_S'} = [ ];
  $self->{'token'} = [ ];

  foreach my $i ( 1 .. $self->{windowsize} ) {
      $self->{table}[$i] = { };
      $self->{total}[$i] = 0;
      $self->{firstngram}[$i] = '';
      $self->{lastngram}[$i] = '';
  }

  if (exists($params{'limit'})) {
      die "limit=$params{'limit'}" if $params{'limit'} < 1;
      $self->{'limit'} = $params{'limit'};
  }
  delete($params{'limit'});

  die "unknown parameters:".join(' ', %params) if %params;

  bless($self, $package);
  return $self;
}

sub feed_tokens {
    my $self = shift;
    # count all n-grams sizes starting from max to 1
    foreach my $t1 (@_) {
	my $t = $t1;
	if (defined($self->{token_dict}->{$t})) {
	    $t = $self->{token_dict}->{$t};
	} else {
	    my $id = $self->{next_token_id}++;
	    $self->{token_S}->[$id] = &encode_S($t);
	    $self->{token}->[$id]   = $t;
	    $t = $self->{token_dict}->{$t} = $id;
	}
	for (my $n=$self->{windowsize}; $n > 0; $n--) {
	    if ($n > 1) {
		next unless $self->{lastngram}[$n-1] ne '';
		$self->{lastngram}[$n] = $self->{lastngram}[$n-1] .
		    ' ' . $t;
	    } else { $self->{lastngram}[$n] = $t }

	    if ( ($self->{table}[$n]{$self->{lastngram}[$n]} += 1)==1)
	    { $self->{'total_distinct_count'} += 1 }

	    $self->{'total'}[$n] += 1;
	    if ($self->{'firstngram'}[$n] eq '')
	    { $self->{'firstngram'}[$n] = $self->{lastngram}[$n] }
	}
    }
    if (exists($self->{'limit'}) and
	$self->{'total_distinct_count'} > 2 * $self->{'limit'})
    { $self->_reduce_to_limit }
}

sub process_text {
    my $self = shift;
    $self->_process_text(0, @_);
    if (exists($self->{'limit'})) { $self->_reduce_to_limit }
}

sub _process_text {
    my $self = shift;
    my $cont = shift; # the minimal number of chars left for
                      # continuation (the new-line problem, and the
                      # problem with too long lines)
                      # The remainder of unprocessed string is
                      # returned.
    if ($cont < 0) { $cont = 0 }

    if (			# type is byte
 	$self->{skiprex}        eq '' and
        $self->{tokenrex}       eq '' and
        $self->{processtoken}   eq '' and
 	$cont == 0
        )
    { return $self->_process_text_byte(@_) }

    my (@tokens);
    my $text;
    while (@_) {
	$text .= shift @_;
	while (length($text) > 0) {
	    my $textl = $text;
	    my $skip = '';
	    if ($self->{skiprex} ne '' && $textl =~ /^$self->{skiprex}/)
	    { $skip = $&; $textl = $'; }
	    if (defined($self->{skipinsert})) {
		$skip = $self->{skipinsert};
		$text = $skip.$textl;
	    }
	    if (length($textl) < $cont) { last }
	    if (length($textl)==0) { $text=$textl; last; }

	    local $_;
	    if ($self->{tokenrex} ne '') {
		if ($textl =~ /^$self->{tokenrex}/)
		{ $_ = $&; $textl = $'; }
	    }
	    else
	    { $_ = substr($textl, 0, 1); $textl = substr($textl, 1) }
	    last if $_ eq '';

	    if (length($textl) < $cont) {
		if (defined($self->{allow_iproc}) && $self->{allow_iproc}
		    && ref($self->{processtoken}) eq 'CODE')
		{ &{$self->{processtoken}} }
		$text = $skip.$_.$textl;
		last;
	    }
	    if (ref($self->{processtoken}) eq 'CODE')
	    { &{$self->{processtoken}} }
	    push @tokens, $_;
	    $text = $textl;
	}
    }
    $self->feed_tokens(@tokens);
    return $text;
}

sub _process_text_byte {
    my $self = shift;

    for (my $i=0; $i<=$#_; ++$i) {
	my @a = split('', $_[$i]);
	next if $#a==-1;
	$self->feed_tokens( @a );
    }
    return '';
}

sub process_files {
    my $self = shift;

    #MJ ->
    my $input_layer='';
    if (defined($self->{inputlayer})) {$input_layer=$self->{inputlayer};}
    #MJ <-

    foreach my $f (@_) {
	my $f1;
	local *F;
	if (not ref($f))
	{ open(F, "$f") or die "cannot open $f:$!"; $f1 = *F }
	else { $f1 = $f }
	binmode $f1;  # avoid text mode

	#MJ ->
	#put the encoding layer on the input when requested
	if ($input_layer ne '') {
		binmode $f1, $input_layer;
	}
	#MJ <-

	my ($text, $text_l, $cont) = ('', 0, 1);
	if (			# type is byte
 	    $self->{skiprex}        eq '' and
            $self->{tokenrex}       eq '' and
            $self->{processtoken}   eq ''
           )
 	{ $cont = 0 }

	while (1) {
	    $text_l = length($text);
	    read($f1, $text, 1024, length($text));
	    last if length($text) <= $text_l;
	    $text = $self->_process_text($cont, $text);
	}
	$text = $self->_process_text(0, $text);

	#MJ ->
	#remove the encoding layer from the input stream if it was added
	#Caution: here is what the Perl documentation says about the pseudo layer ":pop"
	#"Should be considered as experimental. (...) A more elegant (and safer) interface is needed."
	if ($input_layer ne '') {
		binmode $f1,":pop";
	}
	#MJ <-

	close($f1) if not ref($f);
	if (exists($self->{'limit'})) { $self->_reduce_to_limit }
    }
}

sub _reduce_to_limit {
    my $self = shift;
    return unless exists($self->{'limit'}) and
	$self->{'limit'} > 0;

    while ($self->{'total_distinct_count'} > $self->{'limit'}) {
	my $nextprunefrequency = 0;
	for (my $prunefrequency=1;; $prunefrequency = $nextprunefrequency) {
	    $nextprunefrequency = $self->{'total'}[1];

	    foreach my $n (1 .. $self->{'windowsize'}) {

		my @keys = keys(%{$self->{table}[$n]});
		foreach my $ngram (@keys) {
		    my $f = $self->{table}[$n]{$ngram};
		    if ($f <= $prunefrequency) {
			delete $self->{'table'}[$n]{$ngram};
			$self->{'total'}[$n] -= $prunefrequency;
			$self->{'total_distinct_count'} -= 1;
		    }
		    elsif ($nextprunefrequency > $f)
		    { $nextprunefrequency = $f }
		}

		return if $self->{'total_distinct_count'} <= $self->{'limit'};
		die if $nextprunefrequency <= $prunefrequency;
}   }   }   }

# Sorts keys according to the lexicographic order.
sub _keys_sorted {
    my $self = shift;
    my $n = shift;
    my @k = keys(%{$self->{table}[$n]});
    my %k1 = ();
    foreach my $k (@k) {
	$k1{
	    join (' ', map { $self->{token}->[$_] } split(/ /, $k) )
	    } = $k;
    }
    @k = ();
    foreach my $k (sort(keys(%k1))) {
	push @k, $k1{$k};
    }
    return @k;
}

sub get_ngrams {
    my $self = shift;
    my (%params) = @_;
    my $n = exists($params{'n'})? $params{'n'} : $self->{windowsize};
    my $onlyfirst = exists($params{'onlyfirst'}) ? $params{'onlyfirst'} : '';
    my $opt_normalize = exists($params{'normalize'}) ?$params{'normalize'} : '';

    my $total = $self->{total}[$n]; my @keys = ();
    if (!exists($params{'orderby'}) or $params{'orderby'} eq 'ngram') {
      @keys = $self->_keys_sorted($n);
    } elsif ($params{'orderby'} eq 'none') {
      die "onlyfirst requires order" if $onlyfirst;
      @keys = keys(%{$self->{table}[$n]})
    }
    elsif ($params{'orderby'} eq 'frequency') {
      @keys = $self->_keys_sorted($n);
      my %keysord = ();
      for (my $i=0; $i<=$#keys; ++$i) { $keysord{$keys[$i]} = $i }
      @keys = sort { $self->{table}[$n]{$b} <=> $self->{table}[$n]{$a}
		   or $keysord{$a} <=> $keysord{$b} }
	keys(%{$self->{table}[$n]});
    }
    else { die }

    @keys = splice(@keys,0,$onlyfirst) if $onlyfirst;

    my @ret;
    foreach my $ngram (@keys) {
        my $count = $self->{table}[$n]{$ngram};
        $count = ($opt_normalize ? ($count / $total ) : $count);
	push @ret, $self->_encode_S($ngram), $count;
    }

    return @ret;
}

sub to_string {
    my $self = shift;
    my (%params) = @_;
    my $n = exists($params{'n'})? $params{'n'} : $self->{windowsize};
    my $onlyfirst = exists($params{'onlyfirst'}) ? $params{'onlyfirst'} : '';
    my $opt_normalize = exists($params{'normalize'}) ?$params{'normalize'} : '';

    #my $onlyfirst = exists($params{'onlyfirst'}) ?
    #$params{'onlyfirst'} : '';
    #delete $params{'onlyfirst'};

    my $out =  exists($params{'out'}) ? $params{'out'} : '';
    delete $params{'out'};
    my $outh = $out;
    if ($out and (not ref($out))) {
	local *FH; open(FH, ">$out") or die "cannot open $out:$!";
        $outh = *FH;
    }

    #my $opt_normalize = $params{'normalize'};
    #delete $params{'normalize'};

    my $spartan = $params{'spartan'};
    delete $params{'spartan'};

    my $ret='';
    $ret = "BEGIN OUTPUT BY Text::Ngrams version $VERSION\n\n" unless $spartan;

    foreach my $n (1 .. $self->{windowsize}) {
	if ($spartan and $n < $self->{windowsize}) { next }
	if (! $spartan ) {
	    my $tmp = "$n-GRAMS (total count: $self->{total}[$n])";
	    $ret .= "$tmp\n" .
		"FIRST N-GRAM: ".  $self->_encode_S($self->{firstngram}[$n]).
		"\n LAST N-GRAM: ".$self->_encode_S($self->{lastngram}[$n])."\n".
		('-' x length($tmp)) . "\n";
        }
	my $total = $self->{total}[$n];

	my @keys;
	if (!exists($params{'orderby'}) or $params{'orderby'} eq 'ngram')
	{ @keys = $self->_keys_sorted($n) }
	elsif ($params{'orderby'} eq 'none') {
	    die "onlyfirst requires order" if $onlyfirst;
	    @keys = keys(%{$self->{table}[$n]})
	    }
	elsif ($params{'orderby'} eq 'frequency') {
	    @keys = sort { $self->{table}[$n]{$b} <=>
			   $self->{table}[$n]{$a} }
	            keys(%{$self->{table}[$n]});
	}
	else { die }

	@keys = splice(@keys,0,$onlyfirst) if $onlyfirst;

	my %params1=%params; $params1{n}=$n;
	my @a = $self->get_ngrams(%params1);
	for (my $i=0; $i<=$#a; $i+=2) {
	  my $ng = $a[$i]; my $f = $a[$i+1];
	  $ret.="$ng\t$f\n";
	}
	if ($out) { print $outh $ret; $ret = '' }

	$ret .= "\n" unless $spartan;
    }

    $ret .= "END OUTPUT BY Text::Ngrams\n" unless $spartan;

    if ($out) {
	print $outh $ret; $ret = '';
	close($outh) if not ref($out);
    }

    return $ret;
}

# http://web.cs.dal.ca/~vlado/srcperl/snip/decode_S
sub decode_S ( $ ) {
    local $_ = shift;
    my $out;

    while (length($_) > 0) {
        if (/^\\(\S)/) {
            $_ = $'; my $tmp = $1;
            $tmp =~ tr/0-5Aabtnvfroil6-9NSTcEseFGRUd/\x00-\x1F\x7F/;
            $out .= $tmp;
        }
        elsif (/^\^_/) { $_ = $'; $out .= "\240" }
        elsif (/^\^(\S)/) { $_ = $'; $out .= pack('C',ord($1)+128); }
        elsif (/^\`(\S)/) {
            $_ = $'; my $tmp = $1;
            $tmp =~ tr/0-5Aabtnvfroil6-9NSTcEseFGRUd/\x00-\x1F\x7F/;
            $out .= pack('C', ord($tmp)+128);
        }
        elsif (/^_+/) { $_ = $'; my $tmp = $&; $tmp =~ tr/_/ /; $out .= $tmp; }
        elsif (/^[^\\^\`\s_]+/) { $_ = $'; $out .= $&; }
        else { die "decode_S unexpected:$_" }
    }

    return $out;
}

sub _encode_S {
    my $self = shift;
    my @r = ();
    while (@_) {
	push @r,
	map { $self->{token_S}->[$_] } split(/ /, shift @_);
    }
    return join(' ', @r);
}

# http://www.cs.dal.ca/~vlado/srcperl/snip/encode_S
sub encode_S( $ ) {
    local $_ = shift;

    s/=/=0/g;    # first hide a special character (=)
    s/\\/=b/g;			# encode backslashes

    s/([\x80-\xFF])/=x$1/g; # replace >127 with 127
    tr/\x80-\xFF/\x00-\x7F/;
    s/=x=/=X/g;			# hide again =

    s/([\x00-\x1F\x5C\x5E-\x60\x7F])/=B$1/g;
    tr/\x20\x00-\x1F\x7F/_0-5Aabtnvfroil6-9NSTcEseFGRUd/;

    s/=x=B(\S)/`$1/g;		# hex backslash
    s/=x(\S)/^$1/g;		# hex other
    s/=B(\S)/\\$1/g;		# backslashed
    s/=b/\\\\/g;		# original backslashes
    s/=X/^=0/g;
    s/=0/=/g;			# put back =

    return $_;
}

1;
__END__