File Coverage

blib/lib/Text/Document.pm

Criterion	Covered	Total	%
statement	99	164	60.3
branch	23	52	44.2
condition	3	12	25.0
subroutine	12	18	66.6
pod	11	14	78.5
total	148	260	56.9

package Text::Document;

$Text::Document::VERSION = '1.05';

use strict;

use v5.6.0;

our @FIELDS = qw( lowercase );
our $COMPRESS_AVAILABLE;
our @KEYS_FOR_NEW = qw( compress lowercase );

BEGIN {
	eval "use Compress::Zlib;";
	if( $@ ){
		$COMPRESS_AVAILABLE = undef;
	} else {
		$COMPRESS_AVAILABLE = 1;
	}
}


sub new
{
	my $class = shift;
	my %self = @_;
	my $self = {
		lowercase	=> 1,
		compress	=> 1,
		terms		=> {},
	};
	foreach my $k ( @KEYS_FOR_NEW ){
		defined( $self{$k} )
			and ($self->{$k} = $self{$k});
	}

	bless $self, $class;
	return $self;
}

sub AddContent
{
	my $self = shift;
	my ($text) = @_;
# clear frequency cache
	$self->{freqs} and delete $self->{freqs};

# parse text fragment
	my @terms = $self->ScanV( $text );

# update word count
	foreach my $w (@terms){
		$self->{terms}->{$w} ++;
	}
	undef $self->{WeightedEuclideanNorm};
	undef $self->{EuclideanNorm};
	return scalar @terms;
}

# number of occurrences of a given term
sub Occurrences
{
	my $self = shift;
	my ($term) = @_;

	return $self->{terms}->{$term};
}

sub ScanV
{
	my $self =  shift;
	my ($text) = @_;
	my @words = split( /[^a-zA-Z0-9]+/, $text );
	@words = grep( /.+/, @words );
	if( $self->{lowercase} ){
		return map( lc($_), @words );
	} else {
		return @words;
	}
}

sub KeywordFrequency
{
	my $self = shift;

	return $self->{freqs} if $self->{freqs};

# all the distinct terms in the doc
	my @terms = $self->Terms();
# total number of terms
	my $sum = 0;
	foreach my $t (@terms) { $sum += $self->{terms}->{$t}; }
# if zero, frequency is not defined
	($sum > 0) or return undef;
# list of [term,frequency] pairs
	my @freqs = map( [$_, $self->{terms}->{$_}/$sum ] , @terms );
# sort by ascending frequency
	@freqs = sort { $a->[1] <=> $b->[1] } @freqs;

# return reference to result
	return $self->{freqs} = \@freqs;
}

# all distinct term names
sub Terms
{
	my $self = shift;
	return keys %{$self->{terms}};
}

# number of common terms divided by total number of terms
sub CommonTermsRatio
{
	my $self = shift;
	my ($other) = @_;
	my @terms = $self->Terms();
	my %terms;
	@terms{@terms} = 1 .. @terms;
	my @oTerms = $other->Terms();
	my (%union);
	@union{@terms} = 1 .. @terms;
	@union{@oTerms} = 1 .. @oTerms;
	my @intersection = map( ( $terms{$_} ? 1 : () ), @oTerms );
	my $unionCardinality = scalar( keys %union );
	($unionCardinality > 0) or return undef;
	return scalar(@intersection) /  $unionCardinality;
}

sub PureASCII
{
	my $self = shift;
	$self->{compress} = 1;
}

sub WriteToString
{
	my $self = shift;

	my $block = join( ',', %{$self->{terms}} );
	my $compressed = undef;
	if( $COMPRESS_AVAILABLE && $self->{compress} ){
		$block = Compress::Zlib::compress( $block );
#		$block = compress( $block );
		$compressed = 1;
	}
	my $header =
		'p='
		. __PACKAGE__
		. ' v='
		. $Text::Document::VERSION
		. ' l='
		. length( $block )
		. ' compress='
		. ($compressed?'1':'0')
		. ' '
		. join( ' ', map( "$_=$self->{$_}", @FIELDS))
		. "\n";

	my $str = $header . $block;

# add 8-char hex-encoded 4-byte checksum at the end of data
	return $str . sprintf( '%08x', unpack( '%32C*', $str ) );
}

sub NewFromString
{
	my ($str) = @_;

	my $self = {};

# verify checksum
# try to be compatible with version 1.03
	my $stored_checksum = unpack( 'N', substr( $str, -4 ));
	my $data_payload = substr( $str, 0, -4 );
	my $computed_checksum = unpack( '%32C*', $data_payload );

	if( $stored_checksum != $computed_checksum ){
		$stored_checksum = hex( substr( $str, -8 ));
		$data_payload = substr( $str, 0, -8 );
		$computed_checksum = unpack( '%32C*', $data_payload );
	}

	if( $stored_checksum != $computed_checksum ){
		die( __PACKAGE__ . '::NewFromString : '
			. 'checksum test failed '
			. $stored_checksum
			. ' != '
			. $computed_checksum
		);
	}

# split data in header and block
	my ($header,$block) = split( /\n/, $data_payload, 2 );

# parse header line
	my %header = split( /[ 	=]+/, $header );

# check that the reading package is the same as the one that wrote
	if( $header{p} ne __PACKAGE__ ){
		die( __PACKAGE__ . '::NewFromString : '
			. "file was not written by "
			. __PACKAGE__
		);
	}

# version must be identical
	if( $header{v} > $Text::Document::VERSION ){
		die( __PACKAGE__ . '::NewFromString : '
			. "Current version is $Text::Document::VERSION"
			. " and the file version is $header{v}"
		);
	}

# size of block must match
	if( $header{l} != length( $block ) ){
		die( __PACKAGE__ . '::NewFromString : '
			. "data size is "
			. length( $block )
			. "instead of $header{l} "
		);
	}

# compressed?
	if( $header{compress} and not($COMPRESS_AVAILABLE) ){
		die( __PACKAGE__ . '::NewFromString : '
			. 'header indicates that data is compressed, '
			. 'but Compress::Zlib is not available'
		);
	}

	if( $header{compress} ){
		$block = Compress::Zlib::uncompress( $block );
#		$block = uncompress( $block );
	}


	@{$self}{@FIELDS} = @header{ @FIELDS };

# retrieve terms and recurrence count
	%{$self->{terms}} = split( /,/, $block );

	bless $self, $header{p};

	return $self;
}

sub JaccardSimilarity
{
	my $self = shift;
	my ($e) = @_;

	my @inter = map(
		( $self->{terms}->{$_} ?  $_ : () ),
		keys %{$e->{terms}}
	);
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	if( (my $unionSize = scalar keys %union) > 0 ){
		return scalar(@inter) / $unionSize;
	} else {
		return undef;
	}
}

sub CosineSimilarity
{
	my $self = shift;
	my ($e) = @_;

	my ($Dv,$Ev) = ($self->{terms}, $e->{terms});
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	my $dotProduct = 0.0;
	map( $dotProduct +=
		(defined($Dv->{$_}) ? $Dv->{$_} : 0.0)
		* (defined($Ev->{$_}) ? $Ev->{$_} : 0.0 ),
		keys %union
	);

	my $nD = $self->EuclideanNorm();
	my $nE = $e->EuclideanNorm();

	if( ($nD==0) || ($nE==0) ){
		return undef;
	} else {
		return $dotProduct / $nD / $nE;
	}
}

sub EuclideanNorm
{
	my $self = shift;
	defined( $self->{EuclideanNorm} ) and return $self->{EuclideanNorm};
	my $sum = 0.0;
	map( $sum += $_*$_, values %{$self->{terms}} );
	return ($self->{EuclideanNorm} = sqrt( $sum ));
}

# this is rather rough
sub WeightedCosineSimilarity
{
	my $self = shift;
	my ($e,$weightFunction,$rock) = @_;

	my ($Dv,$Ev) = ($self->{terms}, $e->{terms});

# compute union
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	my @allkeys = keys %union;

# weighted D
	my @Dw = map(( defined( $Dv->{$_} )?
		&{$weightFunction}( $rock, $_ )*$Dv->{$_} : 0.0 ),
		@allkeys
	);

# weighted E
	my @Ew = map(( defined( $Ev->{$_} )?
		&{$weightFunction}( $rock, $_ )*$Ev->{$_} : 0.0 ),
		@allkeys
	);

# dot product of D and E
	my $dotProduct = 0.0;
	map( $dotProduct += $Dw[$_] * $Ew[$_] , 0..$#Dw );

# norm of D
	my $nD = 0.0;
	map( $nD += $Dw[$_] * $Dw[$_] , 0..$#Dw );
	$nD = sqrt( $nD );

# norm of E
	my $nE = 0.0;
	map( $nE += $Ew[$_] * $Ew[$_] , 0..$#Ew );
	$nE = sqrt( $nE );

# dot product scaled by norm
	if( ($nD==0) || ($nE==0) ){
		return undef;
	} else {
		return $dotProduct / $nD / $nE;
	}
}

1;


__END__