File Coverage

blib/lib/Text/TFIDF/Ngram.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	23	24	95.8
condition	9	11	81.8
subroutine	13	13	100.0
pod	4	5	80.0
total	125	129	96.9

package Text::TFIDF::Ngram;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Compute the TF-IDF measure for ngram phrases

our $VERSION = '0.0508';

use Moo;
use strictures 2;
use namespace::clean;

use Carp;
use Lingua::EN::Ngram;
use Lingua::StopWords qw( getStopWords );
use List::Util qw( sum0 );


has files => (
    is  => 'ro',
    isa => sub { croak 'Invalid files list' unless ref $_[0] eq 'ARRAY' },
);


has size => (
    is      => 'ro',
    isa     => sub { croak 'Invalid integer' unless $_[0] && $_[0] =~ /^\d+$/ && $_[0] > 0 },
    default => sub { 1 },
);


has stopwords => (
    is      => 'ro',
    isa     => sub { croak 'Invalid Boolean' unless defined $_[0] },
    default => sub { 1 },
);


has punctuation => (
    is      => 'ro',
    default => sub { qr/(?!')[[:punct:]]/ },
);


has lowercase => (
    is      => 'ro',
    default => sub { 0 },
);


has counts => (
    is       => 'ro',
    init_arg => undef,
);


has file_tfidf => (
    is       => 'ro',
    init_arg => undef,
);


sub BUILD {
    my ( $self, $args ) = @_;

    return unless $args->{files};

    $args->{size} ||= 1;

    for my $file ( @{ $args->{files} } ) {
        $self->_process_ngrams( $file, $args->{size} );
    }
}

sub _process_ngrams {
    my ( $self, $file, $size ) = @_;

    my $ngram  = Lingua::EN::Ngram->new( file => $file );
    my $phrase = $ngram->ngram($size);

    if ( $self->lowercase ) {
        $phrase = { map { lc $_ => $phrase->{$_} } keys %$phrase };
    }

    my $stop = getStopWords('en');

    my $counts;

    for my $p ( keys %$phrase ) {
        next if $self->stopwords
            && grep { $stop->{$_} } split /\s+/, $p;  # Exclude stopwords

        my $pat = $self->punctuation;
        $p =~ s/$pat//g if $pat; # Remove unwanted punctuation

        # Skip if we don't have an ngram of the requested size anymore
        my @p = grep { $_ } split /\s+/, $p;
        next unless @p == $size;

        # Skip an ngram with a lone single quote (allowed by the default punctuation)
        next if grep { $_ eq "'" } @p;

        $p = lc $p if $self->lowercase;

        $counts->{$p} = $phrase->{$p};
    }

    $self->{counts}{$file} = $counts;
}


sub tf {
    my ( $self, $file, $phrase ) = @_;
    return 0 unless exists $self->counts->{$file} && exists $self->counts->{$file}{$phrase};
    return $self->counts->{$file}{$phrase} / sum0( values %{ $self->counts->{$file} } );
}


sub idf {
    my ( $self, $phrase ) = @_;

    my $count = 0;

    for my $file ( keys %{ $self->counts } ) {
        $count++ if exists $self->counts->{$file}{$phrase};
    }

    unless ( $count ) {
        carp "'$phrase' is not present in any document";
        return undef;
    }

    return - log( $count / keys %{ $self->counts } ) / log(10) + 0;
}


sub tfidf {
    my ( $self, $file, $phrase ) = @_;
    my $idf = $self->idf($phrase);
    return undef unless $idf;
    return $self->tf( $file, $phrase ) * $idf;
}


sub tfidf_by_file {
    my ($self) = @_;

    my %seen;

    for my $file ( keys %{ $self->counts } ) {
        for my $phrase ( keys %{ $self->counts->{$file} } ) {
            my $tfidf = $self->tfidf( $file, $phrase );

            next if $seen{$phrase}++ || !defined $tfidf;

            $self->{file_tfidf}{$file}{$phrase} = $tfidf;
        }
    }

    return $self->file_tfidf;
}

1;

__END__