File Coverage

lib/Lingua/EN/Ngram.pm

Criterion	Covered	Total	%
statement	104	105	99.0
branch	27	28	96.4
condition	1	3	33.3
subroutine	9	9	100.0
pod	5	5	100.0
total	146	150	97.3

package Lingua::EN::Ngram;

# Ngram.pm - Extract and count words and phrases from texts

# Eric Lease Morgan
# September 12, 2010 - first investigations; based on Lingua::EN::Bigram
# November  25, 2010 - added non-Latin characters; Happy Thanksgiving!
# March     28, 2018 - removed lower-casing the text; why did I do lower case previously?


# include
use strict;
use warnings;

# define
our $VERSION = '0.03';


sub new {

	# get input
	my ( $class, %options ) = @_;

	# initialize
	my $self = {};

	# process optional options
	if ( %options ) {

		# check for one and only one argument
		my @keys = keys %options;
		if ( scalar @keys != 1 ) { die "This method -- new -- can only take one and only one option (text or file)." }

		# initalize from text
		if ( $options{ 'text' } ) { $self->{ text } = $options{ 'text' } }

		# initialize from file
		elsif ( $options{ 'file' } ) {

			# slurp
			my $file = $options{ 'file' };
			open F, $file or die "The file argument ($file) passed to this method is invalid: $!\n";
			my $text = do { local $/;  };
			close F;

			# do the work
			$self->{ text } = $text;

		}

		# invalid option
		else { die "This method -- new -- can only take one option, text or file." }

	}

	# return
	return bless $self, $class;

}


sub text {

	# get input
	my ( $self, $text ) = @_;

	# set
	if ( $text ) { $self->{ text } = $text }

	# return
	return $self->{ text };

}


sub ngram {

	# get input
	my ( $self, $n ) = @_;

	# sanity check
	if ( ! $n ) { die "This method -- ngram -- requires an integer as an argument." }
	if ( $n =~ /\D/ ) { die "This method -- ngram -- requires an integer as an argument." }

	# initalize
	my $text = $self->text;
	$text =~ tr/a-zA-Zà-ƶÀ-Ƶ'()\-,.?!;:/\n/cs;
	$text =~ s/([,.?!:;()\-])/\n$1\n/g;
	$text =~ s/\n+/\n/g;
	my @words = split /\n/, $text;

	my @ngrams = ();
	my %count  = ();
	no warnings;

	# process each word
	for ( my $i = 0; $i <= $#words; $i++ ) {

		# repeat n number of times
		my $tokens = '';
		for ( my $j = $i; $j < $i + $n; $j++ ) { $tokens .= $words[ $j ] . ' ' }

		# remove the trailing space
		chop $tokens;

		# build the ngram and count
		$ngrams[ $i ] = $tokens;
		$count{ $ngrams[ $i ] }++;

	}

	# done
	return \%count;

}


sub tscore {

	# get input
	my ( $self ) = shift;

	# get all the words
	my $text = $self->text;
	$text =~ tr/a-zA-Z'()\-,.?!;:/\n/cs;
	$text =~ s/([,.?!:;()\-])/\n$1\n/g;
	$text =~ s/\n+/\n/g;
	my @words = split /\n/, $text;

	# count the words
	my %word_count = ();
	for ( my $i = 0; $i <= $#words; $i++ ) { $word_count{ $words[ $i ] }++ }

	# get all the bigrams
	my @bigrams = ();
	for ( my $i = 0; $i < $#words; $i++ ) {

		# repeat n number of times
		my $tokens = '';
		for ( my $j = $i; $j < $i + 2; $j++ ) { $tokens .= $words[ $j ] . ' ' }

		# remove the trailing space
		chop $tokens;

		# build the ngram
		$bigrams[ $i ] = $tokens;

	}

	# count the bigrams
	my %bigram_count = ();
	for ( my $i = 0; $i < $#words; $i++ ) { $bigram_count{ $bigrams[ $i ] }++ }

	# calculate t-score
	my %tscore = ();
	for ( my $i = 0; $i < $#words; $i++ ) {

		$tscore{ $bigrams[ $i ] } = ( $bigram_count{ $bigrams[ $i ] } -
	                                  $word_count{ $words[ $i ] } *
	                                  $word_count{ $words[ $i + 1 ] } /
	                                  ( $#words + 1 ) ) / sqrt( $bigram_count{ $bigrams[ $i ] } );

	}

	# done
	return \%tscore;

}


sub intersection {

	# get input
	my ( $self, %options ) = @_;

	# initialize
	my %intersections = ();
	my %ngrams        = ();
	my @counts        = ();
	my $objects       = '';
	my $length        = 0;
	no warnings;

	# sanity checks
	if ( ! %options ) { die 'This method -- interesection -- requires two options: corpus and length.' }
	else {

		if ( scalar keys %options != 2 ) { die 'This method -- interesection -- requires two options: corpus and length.' }
		elsif ( ! $options{ 'corpus' } or ! $options{ 'length' } ) { die 'This method -- interesection -- requires two options: corpus and length.' }
		else {

			$objects = $options{ 'corpus' };
			if ( ref( $objects ) ne 'ARRAY' )  { die 'The corpus option passed to the interesections method must be an array reference.' }

			$length = $options{ 'length' };
			if ( $length =~ /\D/ ) { die "The length option passed to the intersections method mus be an integer." }

		}

	}


	# process each object
	for ( my $i = 0; $i <= $#$objects; $i++ ) {

		# count each ngram
		my $count  = $$objects[ $i ]->ngram( $length );
		foreach ( keys %$count ) { $ngrams{ $_ }++ }

		# save counts for later reference; all puns intended
		$counts[ $i ] = $count;

	}

	# process each ngram
	foreach ( keys %ngrams ) {

		# check for intersection; ngram in all total number of objects
		if ( $ngrams{ $_ } == ( $#$objects + 1 )) {

			# calculate total occurances
			my $total = 0;
			for ( my $i = 0; $i <= $#$objects; $i++ ) { $total += $counts[ $i ]{ $_ }}

			# update result
			$intersections{ $_ } = $total;

		}

	}

	# done
	return \%intersections;

}


=head1 NAME

Lingua::EN::Ngram - Extract n-grams from texts and list them according to frequency and/or T-Score


=head1 SYNOPSIS

  # initalize
  use Lingua::EN::Ngram;
  $ngram = Lingua::EN::Ngram->new( file => './etc/walden.txt' );

  # calculate t-score; t-score is only available for bigrams
  $tscore = $ngram->tscore;
  foreach ( sort { $$tscore{ $b } <=> $$tscore{ $a } } keys %$tscore ) {

    print "$$tscore{ $_ }\t" . "$_\n";

  }

  # list trigrams according to frequency
  $trigrams = $ngram->ngram( 3 );
  foreach my $trigram ( sort { $$trigrams{ $b } <=> $$trigrams{ $a } } keys %$trigrams ) {

      print $$trigrams{ $trigram }, "\t$trigram\n";

  }


=head1 DESCRIPTION

This module is designed to extract n-grams from texts and list them according to frequency and/or T-Score.

To elaborate, the purpose of Lingua::EN::Ngram is to: 1) pull out all of the ngrams (multi-word phrases) in a given text, and 2) list these phrases according to their frequency. Using this module is it possible to create lists of the most common phrases in a text as well as order them by their probable occurance, thus implying significance. This process is useful for the purposes of textual analysis and "distant reading".

The two-word phrases (bigrams) are also listable by their T-Score. The T-Score, as well as a number of the module's other methods, is calculated as per Nugues, P. M. (2006). An introduction to language processing with Perl and Prolog: An outline of theories, implementation, and application with special consideration of English, French, and German. Cognitive technologies. Berlin: Springer.

Finally, the intersection method enables the developer to find ngrams common in an arbitrary number of texts. Use this to look for common themes across a corpus.


=head1 METHODS


=head2 new

Create a new Lingua::EN::Ngram object:

  # initalize
  $ngram = Lingua::EN::Ngram->new;


=head2 new( text => $scalar )

Create a new Lingua::EN::Ngram object whose contents equal the content of a scalar:

  # initalize with scalar
  $ngram = Lingua::EN::Ngram->new( text => 'All good things must come to an end...' );


=head2 new( file => $scalar )

Create a new Lingua::EN::Ngram object whose contents equal the content of a file:

  # initalize with file
  $ngram = Lingua::EN::Ngram->new( file => './etc/rivers.txt' );


=head2 text

Set or get the text to be analyzed:

  # fill Lingua::EN::Ngram object with content
  $ngram->text( 'All good things must come to an end...' );

  # get the Lingua::EN::Bigram object's content
  $text = $ngram->text;


=head2 tscore

Return a reference to a hash whose keys are a bigram and whose values are a T-Score -- a probabalistic calculation determining the significance of the bigram occuring in the text:

  # get t-score
  $tscore = $ngrams->tscore;

  # list bigrams according to t-score
  foreach ( sort { $$tscore{ $b } <=> $$tscore{ $a } } keys %$tscore ) {

	  print "$$tscore{ $_ }\t" . "$_\n";

  }

T-Score can only be computed against bigrams.


=head2 ngram( $scalar )

Return a hash reference whose keys are ngrams of length $scalar and whose values are the number of times the ngrams appear in the text:

  # create a list of trigrams
  $trigrams = $ngrams->ngram( 3 );

  # display frequency
  foreach ( sort { $$trigrams{ $b } <=> $$trigrams{ $a } } keys %$trigrams ) {

    print $$trigrams{ $_ }, "\t$_\n";

  }

This method requires a single parameter and that parameter must be an integer. For example, to get a list of bigrams, pass 2 to ngram. To get a list of quadgrams, pass 4.


=head2 intersection( corpus => [ @array ], length => $scalar )

Return a hash reference whose keys are ngrams of length $scalar and whose values are the number of times the ngrams appear in a corpus of texts:

  # build corpus
  $walden = Lingua::EN::Ngram->new( file => './etc/walden.txt' );
  $rivers = Lingua::EN::Ngram->new( file => './etc/rivers.txt' );
  $corpus = Lingua::EN::Ngram->new;

  # compute intersections
  $intersections = $corpus->intersection( corpus => [ ( $walden, $rivers ) ], length => 5 );

  # display frequency
  foreach ( sort { $$intersections{ $b } <=> $$intersections{ $a }} keys %$intersections ) {

    print $$intersections{ $_ }, "\t$_\n";

  }

The value of corpus must be an array reference, and each element must be Lingua::EN::Ngram objects. The value of length must be an integer.


=head1 DISCUSSION

Given the increasing availability of full text materials, this module is intended to help "digital humanists" apply mathematical methods to the analysis of texts. For example, the developer can extract the high-frequency words using the ngram method and allow the user to search for those words in a concordance. The use of ngram( 2 ) simply returns the frequency of bigrams in a text, but the tscore method can order them in a more finely tuned manner.

Consider using T-Score-weighted bigrams as classification terms to supplement the "aboutness" of texts. Concatonate many texts together and look for common phrases written by the author. Compare these commonly used phrases to the commonly used phrases of other authors.

All ngrams return by the ngram method include punctuation. This is intentional. Developers may need want to remove ngrams containing such values from the output. Similarly, no effort has been made to remove commonly used words -- stop words -- from the methods. Consider the use of Lingua::StopWords, Lingua::EN::StopWords, or the creation of your own stop word list to make output more meaningful. The distribution came with a script (bin/ngrams.pl) demonstrating how to remove puncutation from the displayed output. Another script (bin/intesections.pl) demonstrates how to extract and count ngrams across two texts.

Finally, this is not the only module supporting ngram extraction. See also Text::NSP.


=head1 TODO

There are probably a number of ways the module can be improved:

=over

* the distribution's license should probably be changed to the Perl Aristic License

* the addition of alternative T-Score calculations would be nice

* make sure the module works with character sets beyond ASCII (done, I think, as of version 0.02)

=back


=head1 CHANGES

=over

* March 28, 2018 (version 0.03) - removed lower casing of letters and install ngrams script

* November 25, 2010 (version 0.02) - added non-Latin characters

* September 12, 2010 (version 0.01) - initial release but an almost complete rewrite of Lingua::EN::Bigram



=back

=head1 ACKNOWLEDGEMENTS

T-Score, as well as a number of the module's methods, is calculated as per Nugues, P. M. (2006). An introduction to language processing with Perl and Prolog: An outline of theories, implementation, and application with special consideration of English, French, and German. Cognitive technologies. Berlin: Springer.


=head1 AUTHOR

Eric Lease Morgan

=cut

# return true or die
1;