File Coverage

blib/lib/Text/Summarize.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Text::Summarize;
use strict;
use warnings;
use Log::Log4perl;
use Text::Categorize::Textrank;
use Data::Dump qw(dump);

BEGIN
{
	use Exporter ();
	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = '0.50';
	@ISA         = qw(Exporter);
	@EXPORT      = qw(getSumbasicRankingOfSentences);
	@EXPORT_OK   = qw(getSumbasicRankingOfSentences);
	%EXPORT_TAGS = ();
}

#12345678901234567890123456789012345678901234
#Routine to compute summaries of text.

=head1 NAME

C - Routine to compute summaries of text.

=head1 SYNOPSIS

  use strict;
  use warnings;
  use Text::Summarize;
  use Data::Dump qw(dump);
  my $listOfSentences = [
    { id => 0, listOfTokens => [qw(all people are equal)] },
    { id => 1, listOfTokens => [qw(all men are equal)] },
    { id => 2, listOfTokens => [qw(all are equal)] },
  ];
  dump getSumbasicRankingOfSentences(listOfSentences => $listOfSentences);

=head1 DESCRIPTION

C contains a routine to score a list of sentences
for inclusion in a summary of the text using the
SumBasic algorithm from the report I
by L. Vanderwendea, H. Suzukia, C. Brocketta, and A. Nenkovab.

=head1 ROUTINES

=head2 C

  use Text::Summarize;
  use Data::Dump qw(dump);
  my $listOfSentences = [
    { id => 0, listOfTokens => [qw(all people are equal)] },
    { id => 1, listOfTokens => [qw(all men are equal)] },
    { id => 2, listOfTokens => [qw(all are equal)] },
  ];
  dump getSumbasicRankingOfSentences(listOfSentences => $listOfSentences);

C computes the sumBasic score of the list of sentences
provided. It returns an array reference containing the pairs C<[id, score]> sorted
in descending order of score, where C is from C.

=over

=item C

 listOfSentences => [{id => '..', listOfTokens => [...]}, ..., {id => '..', listOfTokens => [...]}]

C holds the list of sentences that are to be scored. Each
item in the list is a hash reference of the form C<{id =E '..', listOfTokens =E [...]}> where
C is a unique identifier for the sentence and C is an array
reference of the list of tokens comprizing the sentence.

=item C

 tokenWeight => {}

C is a optional hash reference that provides the weight of the tokens defined
in C. If C is defined, but undefined for a token in a sentence,
then the tokens weight defaults to zero unless C is true,
in which case the token is ignored and not used to compute the average weight
of the sentences containing it. If C is undefined then the weights of the tokens
are either their frequency of occurrence in the filtered text, or their textranks if C is defined.

=item C

 ignoreUndefinedTokens => 0

If C is true, then any tokens for which C is
undefined are ignored and not used to compute the average weight of a
sentence; the default is false.

=item C

 tokenWeightUpdateFunction => &subroutine (currentTokenWeight, initialTokenWeight, token, selectedSentenceId, selectedSentenceWeight)

C is an optional parameter for defining the function that updates the
weight of a token when it is contained in a selected sentence. Five parameters are passed to the
subroutine: the token's current weight (float), the token's initial weight (float), the token (string), the C of the
selected sentence (string), and the current average weight of the tokens in the selected sentence (float).
The default is L.

=item C

  textRankParameters => undef

If C is defined, then the token weights
are computed using L. The parameters to use for L,
excluding the C parameters, can be set using the hash reference defined by C.
For example, C {directedGraph =E 1}> would make the textrank weights
be computed using a directed token graph.

=back

=cut

sub getSumbasicRankingOfSentences
{
	my (%Parameters) = @_;

	# get the list of sentences.
	my $listOfSentences = $Parameters{listOfSentences} if exists $Parameters{listOfSentences};
	return [] unless defined $listOfSentences;

	# get the original token weights.
	my $originalTokenWeights;
	$originalTokenWeights = $Parameters{tokenWeight} if (exists($Parameters{tokenWeight}) && defined($Parameters{tokenWeight}));

	# if textRankParameters is defined, compute the token weights via textrank.
	if (exists($Parameters{textRankParameters}) && defined($Parameters{textRankParameters}))
	{
    $originalTokenWeights = _getTextRankWeightOfTokens(%Parameters, listOfSentences => $listOfSentences);
	}

  # if $originalTokenWeights is not defined, then use the frequency of the tokens as their weight.
  if (!defined ($originalTokenWeights))
  {
    $originalTokenWeights = _getFrequencyWeightOfTokens(listOfSentences => $listOfSentences);
  }

	# get the function to update the weights of the tokens.
	my $tokenWeightUpdateFunction = \&tokenWeightUpdateFunction_Squared;
	$tokenWeightUpdateFunction = $Parameters{tokenWeightUpdateFunction} if exists $Parameters{tokenWeightUpdateFunction};

	# set the flag for ignoreUndefinedTokens.
	my $ignoreUndefinedTokens = exists $Parameters{ignoreUndefinedTokens} && $Parameters{ignoreUndefinedTokens};

	# copy the weights of only the tokens that occur in the sentences.
	# the default weight of a token is zero.
	my %tokenWeight;
	for (my $i = 0 ; $i < @$listOfSentences ; $i++)
	{

		# if the sentence has no id, skip it.
		unless (exists $listOfSentences->[$i]->{id})
		{

			# get the list of tokens in the sentence as a string.
			my $stringOfTokens;
			if (exists($listOfSentences->[$i]->{listOfTokens}))
			{
				$stringOfTokens = join(' ', @{ $listOfSentences->[$i]->{listOfTokens} });
			}

			# create the message to log.
			my $logger = Log::Log4perl->get_logger();
			my $message;
			if (defined $stringOfTokens)
			{
				$message = "warning: skipping sentence number $i with tokens $stringOfTokens since it is missing an id.\n";
			}
			else
			{
				$message = "warning: skipping sentence number $i since it is missing an id and listOfTokens.\n";
			}

			# log the message as a warning.
			$logger->logwarn($message);

			# skip processing the sentence.
			next;
		}

		# get the listOfTokens of the sentence.
		if ((exists $listOfSentences->[$i]->{listOfTokens}) && (@{ $listOfSentences->[$i]->{listOfTokens} }))
		{
			my $listOfTokens = $listOfSentences->[$i]->{listOfTokens};
			foreach my $token (@$listOfTokens)
			{

				# if the weight is already defined for the token, skip it.
				next if exists $tokenWeight{$token};

				# if weight for token not defined, it defaults to zero if ignoreUndefinedTokens is false.
				if (exists $originalTokenWeights->{$token})
				{
					$tokenWeight{$token} = $originalTokenWeights->{$token};
				}
				elsif (!$ignoreUndefinedTokens)
				{
					$tokenWeight{$token} = 0;
				}
			}
		}
	}

	# normalize the token weights to sum to one.
	my $sum = 0;
	while (my ($token, $weight) = each %tokenWeight) { $sum += $weight; }
	$sum = 1 if ($sum == 0);
	while (my ($token, $weight) = each %tokenWeight) { $tokenWeight{$token} /= $sum; }

	# keep a copy of the initial token weights.
	my %initialTokenWeight = %tokenWeight;

	# @listOfEmptySentenceIds will hold the list of empty sentence ids.
	my @listOfEmptySentenceIds;

	# make a copy of the list of sentences
	my @localListOfSentences;
	for (my $i = 0 ; $i < @$listOfSentences ; $i++)
	{

		# if the sentence has no id, skip it.
		next unless exists $listOfSentences->[$i]->{id};

		# copy the id of the sentence.
		my %sentence;
		$sentence{id} = $listOfSentences->[$i]->{id};

		# convert the list of tokens in a sentence to a hash with the key as the token and the value its occurance in the sentence.
		if ((exists $listOfSentences->[$i]->{listOfTokens}) && (@{ $listOfSentences->[$i]->{listOfTokens} }))
		{
			my %tokenCount;
			my $empty = 1;
			foreach my $token (@{ $listOfSentences->[$i]->{listOfTokens} })
			{

				# if the weight for the token is not defined, skip it.
				if (exists $tokenWeight{$token})
				{
					++$tokenCount{$token};
					$empty = 0;
				}
			}

			# if the sentence has no defined tokens, store the id on @listOfEmptySentenceIds.
			if ($empty)
			{
				push @listOfEmptySentenceIds, [ $listOfSentences->[$i]->{id}, scalar @{ $listOfSentences->[$i]->{listOfTokens} } ];
			}
			else
			{
				$sentence{tokenCounts} = \%tokenCount;

				# store the sentence in a list.
				push @localListOfSentences, \%sentence;
			}
		}
		else
		{

			# if the sentence has no tokens, store the id on @listOfEmptySentenceIds.
			push @listOfEmptySentenceIds, [ $listOfSentences->[$i]->{id}, scalar @{ $listOfSentences->[$i]->{listOfTokens} } ];
		}
	}

	# compute the average weight of each sentence and initialize its selected flag to false.
	for (my $i = 0 ; $i < @localListOfSentences ; $i++)
	{

		# get the pointer to the sentence.
		my $sentence = $localListOfSentences[$i];

		# compute the weight of the sentence.
		my $weight        = 0;
		my $tokenCountSum = 0;
		while (my ($token, $count) = each %{ $sentence->{tokenCounts} })
		{
			$weight += $count * $tokenWeight{$token};
			$tokenCountSum += $count;
		}
		$sentence->{size}   = $tokenCountSum;
		$sentence->{weight} = $weight / $sentence->{size};

		# initialize each sentence as not selected.
		$sentence->{selected} = 0;
	}

	# build the inverted index of the sentences and tokens, called tokenSentenceIndex.
	my %tokenSentenceIndex;
	for (my $i = 0 ; $i < @localListOfSentences ; $i++)
	{

		# get the pointer to the sentence.
		my $sentence = $localListOfSentences[$i];

		# get the list of tokens in the sentence.
		foreach my $token (keys %{ $sentence->{tokenCounts} })
		{

			# add the weightSentence pointer to the tokenSentenceIndex.
			$tokenSentenceIndex{$token} = [] unless exists $tokenSentenceIndex{$token};

			# note we are storing the index of the sentence, not the pointer to the sentence.
			push @{ $tokenSentenceIndex{$token} }, $i;
		}
	}

	# make the list of just the tokens.
	my @listOfTokens = keys %tokenWeight;

	# @rankedListOfSentences will hold the sentences in sumbasic order.
	my @rankedListOfSentences;

	# loop over the sentences until they have all been selected.
	while (scalar(@rankedListOfSentences) < scalar(@localListOfSentences))
	{

		# if there are no tokens left, exit the loop.
		last unless @listOfTokens > 0;

		# get the token with the greatest (weight, length, -order).
		my $maxIndex       = 0;
		my $maxToken       = $listOfTokens[$maxIndex];
		my $maxTokenWeight = $tokenWeight{$maxToken};
		for (my $i = 1 ; $i < scalar(@listOfTokens) ; $i++)
		{
			my $cmp;
			if ($maxTokenWeight < $tokenWeight{ $listOfTokens[$i] })
			{

				# $maxTokenWeight is smaller.
				$cmp = -1;
			}
			elsif ($maxTokenWeight > $tokenWeight{ $listOfTokens[$i] })
			{

				# $maxTokenWeight is larger.
				$cmp = 1;
			}
			else
			{

				# weights are equal, compare token lengths, choose the longer one.
				$cmp = length($maxToken) <=> length($listOfTokens[$i]);

				# if tokens have equal length, choose the one lexically smaller.
				if ($cmp == 0) { $cmp = $listOfTokens[$i] cmp $maxToken; }
			}

			# if the current max is smaller, replace it.
			if ($cmp == -1)
			{
				$maxIndex       = $i;
				$maxToken       = $listOfTokens[$maxIndex];
				$maxTokenWeight = $tokenWeight{$maxToken};
			}
		}

		# copy the last token to where the max was, it may be popped off if there are no
		# sentences left containing it.
		$listOfTokens[$maxIndex] = $listOfTokens[-1];
		$listOfTokens[-1] = $maxToken;

		# if there are no sentences remaining with the token, move on to the next token.
		unless (exists $tokenSentenceIndex{$maxToken})
		{
			pop @listOfTokens;
			next;
		}

		# get the list of sentences that have the token.
		my $listOfSentencesWithToken = $tokenSentenceIndex{$maxToken};

		# if there are no sentences remaining with the token, move on to the next token.
		unless (scalar(@$listOfSentencesWithToken) > 0)
		{
			pop @listOfTokens;
			delete $tokenSentenceIndex{$maxToken};
			next;
		}

		# find the sentence having the token with the highest weight not yet selected.
		my $maxSentenceIndex;
		my $maxSentence;
		my @remainingListOfSentencesWithToken;
		foreach my $sentenceIndex (@$listOfSentencesWithToken)
		{

			# get the pointer to the sentence.
			my $sentence = $localListOfSentences[$sentenceIndex];

			# skip the sentence if already selected.
			next if $sentence->{selected};

			# if no sentence has been selected, just take the first valid sentence.
			unless (defined($maxSentence))
			{
				$maxSentence      = $sentence;
				$maxSentenceIndex = $sentenceIndex;
				next;
			}

			# choose the sentence with the greater weight, or the greater size, or the lesser id.
			my $cmp =
				   ($sentence->{weight} <=> $maxSentence->{weight})
				|| ($sentence->{size} <=> $maxSentence->{size})
				|| ($sentence->{id} cmp $maxSentence->{id});

			# store the new maximum sentence.
			if ($cmp == 1)
			{

				# store the previous maximum as an unselected sentence.
				push @remainingListOfSentencesWithToken, $maxSentenceIndex;
				$maxSentence      = $sentence;
				$maxSentenceIndex = $sentenceIndex;
			}
			else
			{

				# store the current sentence as unselected.
				push @remainingListOfSentencesWithToken, $sentenceIndex;
			}
		}

		# update the list of sentences with the token that were not selected for the summary.
		if (@remainingListOfSentencesWithToken == 0)
		{
			delete $tokenSentenceIndex{$maxToken};
		}
		else
		{

			# update the list of sentences that the token is contained in.
			$tokenSentenceIndex{$maxToken} = \@remainingListOfSentencesWithToken;
		}

		# if no sentence selected, then there are no unselected sentences with the
		# token, so move on to the next token.
		unless (defined $maxSentence)
		{
			pop @listOfTokens;
			delete $tokenSentenceIndex{$maxToken};
			next;
		}

		# store the sentence selected and its weight.
		$maxSentence->{selected} = 1;
		push @rankedListOfSentences, [ $maxSentence, $maxSentence->{weight} ];

		# update the weight of all the tokens in the max sentence.
		my @sentenceTokens = keys %{ $maxSentence->{tokenCounts} };
		foreach my $token (@sentenceTokens)
		{

			# (currentTokenWeight, initialTokenWeight, token, selectedSentenceId, selectedSentenceWeight)
			$tokenWeight{$token} =
				&$tokenWeightUpdateFunction($tokenWeight{$token}, $initialTokenWeight{$token}, $token, $maxSentence->{id}, $maxSentence->{weight});
		}

		# get all of the sentences that share tokens with the max sentence.
		my %sentencesToUpdate;
		foreach my $token (@sentenceTokens)
		{
			next unless exists $tokenSentenceIndex{$token};
			foreach my $sentenceIndex (@{ $tokenSentenceIndex{$token} })
			{
				$sentencesToUpdate{$sentenceIndex} = 1;
			}
		}
		my @listOfSentencesToUpdate = keys %sentencesToUpdate;

		# recompute the weight of the sentences that have tokens whose weight changed.
		# floating point calculations will become unstable due to rounding errors if the
		# old weights are subtracted and the new weights added. slower, but best to
		# recompute the average weights by summing.
		foreach my $sentenceIndex (@listOfSentencesToUpdate)
		{

			# get the pointer to the sentence.
			my $sentence = $localListOfSentences[$sentenceIndex];

			# skip the sentence if it was already selected.
			next if $sentence->{selected};

			# compute the weight of the sentence.
			my $weight = 0;
			while (my ($token, $count) = each %{ $sentence->{tokenCounts} })
			{
				$weight += $count * $tokenWeight{$token};
			}
			$sentence->{weight} = $weight / $sentence->{size};
		}
	}

	# normalize the sentence weights so they sum to one.
	my $totalSentenceWeight = 0;
	foreach my $sentenceWeight (@rankedListOfSentences)
	{
		$totalSentenceWeight += $sentenceWeight->[1];
	}
	$totalSentenceWeight = 1 if ($totalSentenceWeight == 0);

	foreach my $sentenceWeight (@rankedListOfSentences)
	{

		# normalize the sentence weight.
		$sentenceWeight = [ $sentenceWeight->[0]->{id}, $sentenceWeight->[1] / $totalSentenceWeight ];
	}

	# add the empty sentences to the list.
	push @rankedListOfSentences, map { [ $_->[0], 0 ] } sort { ($a->[1] <=> $b->[1]) || ($a->[0] cmp $b->[0]) } @listOfEmptySentenceIds;

	# adjust the weights to be descending (a kludge).
	if (@rankedListOfSentences)
	{
    my $totalSentenceWeight = 0;
    my $runningSum = 0;
    for (my $i = @rankedListOfSentences - 1; $i > -1; $i--)
    {
      $runningSum += $rankedListOfSentences[$i]->[1];
      $rankedListOfSentences[$i]->[1] = $runningSum;
      $totalSentenceWeight += $rankedListOfSentences[$i]->[1];
    }
    $totalSentenceWeight = 1 if ($totalSentenceWeight <= 0);
    foreach my $idWeight (@rankedListOfSentences)
    {
      $idWeight->[1] = abs ($idWeight->[1]/ $totalSentenceWeight);
    }
	}

	return \@rankedListOfSentences;
}

=head2 C

Returns the tokens current weight squared.

=cut

sub tokenWeightUpdateFunction_Squared    # (currentTokenWeight, initialTokenWeight, token, selectedSentenceId, selectedSentenceWeight)
{
	return $_[0] * $_[0];
}

=head2 C

Returns the tokens current weight times its intial weight.

=cut

sub tokenWeightUpdateFunction_Multiplicative   # (currentTokenWeight, initialTokenWeight, token, selectedSentenceId, selectedSentenceWeight)
{
	return $_[0] * $_[1];
}

=head2 C

Returns the tokens current weight times its the average weight of the tokens in the selected sentence.

=cut

sub tokenWeightUpdateFunction_Sentence         # (currentTokenWeight, initialTokenWeight, token, selectedSentenceId, selectedSentenceWeight)
{
	return $_[0] * $_[4];
}

# computes the textrank of the tokens.
sub _getTextRankWeightOfTokens
{
	my %Parameters = @_;

	# use any textrank parameters if defined.
	my %textRankParameters;
	%textRankParameters = %{ $Parameters{textRankParameters} } if ((exists $Parameters{textRankParameters}) && (defined $Parameters{textRankParameters}));

	# if no sentences, return now.
	return {} unless exists $Parameters{listOfSentences};
	my $listOfSentences = $Parameters{listOfSentences};

	# build the list of tokens.
	my @listOfTokens = map { ($_->{listOfTokens}) } @$listOfSentences;

	# return the textrank of each token.
	return getTextrankOfListOfTokens(%textRankParameters, listOfTokens => \@listOfTokens);
}

# computes the frequency of the tokens.
sub _getFrequencyWeightOfTokens
{
  my %Parameters = @_;

  # if no sentences, return now.
  return {} unless exists $Parameters{listOfSentences};
  my $listOfSentences = $Parameters{listOfSentences};

  # compute total occurrence and frequency of the tokens.
  my $totalOccurrence = 0;
  my %tokenFrequency;

  foreach my $sentence (@$listOfSentences)
  {
    foreach my $token (@{$sentence->{listOfTokens}})
    {
      ++$tokenFrequency{$token};
      ++$totalOccurrence;
    }
  }
  $totalOccurrence = 1 if $totalOccurrence < 1;

  while (my ($token, undef) = each %tokenFrequency)
  {
    $tokenFrequency{$token} /= $totalOccurrence;
  }

  # return the frequency of each token.
  return \%tokenFrequency;
}

=head1 INSTALLATION

Use L to install the module and all its prerequisites:

  perl -MCPAN -e shell
  >install Text::Summarize

=head1 BUGS

Please email bugs reports or feature requests to C, or through
the web interface at L.  The author
will be notified and you can be automatically notified of progress on the bug fix or feature request.

=head1 AUTHOR

 Jeff Kubina

=head1 COPYRIGHT

Copyright (c) 2009 Jeff Kubina. All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=head1 KEYWORDS

information processing, summary, summaries, summarization, summarize, sumbasic, textrank

=head1 SEE ALSO

L, L, L

=begin html

The SumBasic algorithm for ranking sentences is from
Beyond SumBasic: Task-Focused Summarization with Sentence Simplification and Lexical Expansion
by L. Vanderwendea, H. Suzukia, C. Brocketta, and A. Nenkovab.

=end html

=cut

1;

# The preceding line will help the module return a true value