File Coverage

blib/lib/Statistics/SocialNetworks.pm

Criterion	Covered	Total	%
statement	57	81	70.3
branch	12	24	50.0
condition	1	2	50.0
subroutine	7	9	77.7
pod	5	6	83.3
total	82	122	67.2

package Statistics::SocialNetworks;

use 5.008008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Statistics::SocialNetworks ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	constraint
	c
	p
	CTdi
	flushCache
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.03';


# Preloaded methods go here.

my %p = (); # cache for p() results

sub m {
	my $g = shift;
	my $i = shift;
	my $j = shift;
	my %g = %{$g};

	return $g{$i}{$j} if defined $g{$i}{$j};
	return 0;
}

sub flushCache {
	%p = ();
}

sub CTdi {
	#Coleman-Theil disorder index
	#a measure of diversity of contacts
	#0 = same for all contacts
	#1 = all constraint is measured in a single relationship

	my $g = shift;
	my $i = shift;
	my %g = %{$g};

	my @N = keys %{$g{$i}};

	my $N = $#N + 1;

	return 1 if ( $N == 1 );

	my $sum = 0;
	my $C = constraint($g,$i);
	if ( $C ) {
		foreach my $j ( @N ) {
			next if ($j eq $i);
			my $factor = c($g, $i, $j)/($C/$N);
			$sum += $factor * log($factor) if ( $factor );
		}
		$sum /= ($N * log($N));
	}
	return $sum;
}

sub p {
	my $g = shift; # graph
	my $i = shift;
	my $j = shift;
	my %g = %{$g};

	return $p{$i}{$j} if (defined $p{$i}{$j});

	my @v = keys %{$g{$i}};
	my $z = 0;

	my $total_w = 0;
	my $n;
	my $w = undef;
	foreach $n ( @v ) {
		$w = $g{$i}{$n} || 1;
		$total_w += $w;
		next unless ( $n eq $j );
		$z += $w;
	}

	return $p{$i}{$j} = 0 unless ($z > 0);

	$p{$i}{$j} = ($z/($total_w));
	return $p{$i}{$j};

}

sub c {
	my $g = shift; # graph
	my $i = shift;
	my $j = shift;
	my %g = %{$g};

	my $sum = p($g,$i,$j);

	my @v = keys %{$g{$i}};
	my $key;
	foreach $key ( @v ) {
		next if $key eq $i;
		next if $key eq $j;
		$sum += p($g, $i, $key) * p($g, $key, $j);
	}

	return $sum * $sum;
}

sub constraint {
	my $g = shift; # graph
	my $i = shift;
	my %g = %{$g};

	my $sum = 0;

	my @v = keys %{$g{$i}};
	return 1 if ($#v == 0);
	my $node;
	foreach $node ( @v ) {
		next if ( $node eq $i );
		$sum += c($g, $i, $node);
	}

	return $sum;
}

1;
__END__