Ranking algorithms

rank.pl

#!/usr/bin/env perl

use 5.01;
use strict;
use warnings;
use File::Basename qw/dirname/;
use lib dirname($0);
use Rank qw/twipie/;

my @slates;
my $fn = shift // dirname($0) . '/slates.txt';

if (-e $fn) {
	open my $fh, '<', $fn;
	while (my $line = readline $fh) {
		push @slates, [ split /\s+/, $line ];
	}
}
else {
	while (my $line = <STDIN>) {
		push @slates, [ split /\s+/, $line ];
	}
}

my ($scores,$error) = twipie(\@slates);

for my $id (reverse sort { $scores->{$a} <=> $scores->{$b} } keys %$scores) {
	printf "%-4s %7.3f %8.5f\n", $id, $scores->{$id}, $error->{$id};
}

Rank.pm

package Rank;

use 5.01;
use strict;
use warnings;
use base 'Exporter';

our @EXPORT_OK = qw/twipie/;

sub uniq {
	my %uniq;
	$uniq{$_} = 1 for @_;
	keys %uniq;
}

sub flatten {
	map { ref $_ eq 'ARRAY' ? map { flatten($_) } @$_ : $_ } @_;
}

# Algorithm: Perfecting Probabilities using Test Scoring (a.k.a. TwiPie)
#
# N = (of times story N has been rated higher than another story) /
# sum over all M {(number of times story N has been compared to story M) / (N+M)}
# Initialising
sub twipie {
	my $slates = shift;

	# Initialise
	my (%scores, %p, %error, %wins, %comps);

	# Imaginary team, key guaranteed unique
	my $x = join '', uniq flatten @$slates;

	for my $n ($x, uniq flatten @$slates) {
		$scores{$n} = 1;
		$wins{$n} = 0;
		$comps{$n} = {};
		$p{$n} = [] unless $n eq $x;
		for my $m ($x, uniq flatten @$slates) {
			$comps{$n}{$m} = 0;
		}
	}

	# Calculate wins and comps
	for my $slate (@$slates) {
		for my $i (0..$#$slate) {
			$wins{$slate->[$i]} += $#$slate - $i;
			for my $j ($i+1..$#$slate) {
				$comps{$slate->[$i]}{$slate->[$j]} += 1;
				$comps{$slate->[$j]}{$slate->[$i]} += 1;
			}
		}
	}

	# Add win and loss for each story against imaginary team
	for my $n (keys %scores) {
		next if $n eq $x;
		$wins{$n} += 1;
		$wins{$x} += 1;
		$comps{$n}{$x} = 2;
		$comps{$x}{$n} = 2;
	}

	# Calculate scores
	for (0..100) {
		my %newScores;
		for my $n (keys %scores) {
			my $sum = 0;
			for my $m (keys %scores) {
				next if $scores{$n} + $scores{$m} == 0;
				$sum += $comps{$n}{$m} / ($scores{$n} + $scores{$m});
			}
			$newScores{$n} = $wins{$n} / $sum;
		}
		%scores = %newScores;
	}

	# Calculate probability of match results for each story
	#
	# Expected outcome for N is N/(N+M)
	for my $slate (@$slates) {
		for my $i (0..$#$slate) {
			for my $j ($i+1..$#$slate) {
				my $n = $slate->[$i];
				my $m = $slate->[$j];
				push @{ $p{$n} }, abs(1 - $scores{$n} / ($scores{$n} + $scores{$m}) );
				push @{ $p{$m} }, abs(0 - $scores{$m} / ($scores{$n} + $scores{$m}) );
			}
		}
	}

	# Calculate error score, the root mean square error
	for my $i (keys %p) {
		my $sum = 0;
		for my $diff (@{ $p{$i} }) {
			$sum += $diff ** 2;
		}
		$error{$i} = sqrt($sum / @{ $p{$i} });
	}

	# Remove imaginary team from output
	delete $scores{$x};
	delete $error{$x};

	return (\%scores, \%error);
}

1;