File Coverage

blib/lib/Statistics/RankOrder.pm

Criterion	Covered	Total	%
statement	84	84	100.0
branch	6	6	100.0
condition	3	3	100.0
subroutine	13	13	100.0
pod	7	7	100.0
total	113	113	100.0

use 5.008001;
use strict;
use warnings;

package Statistics::RankOrder;
# ABSTRACT: Algorithms for determining overall rankings from a panel of judges
our $VERSION = '0.13'; # VERSION

use Carp;
use Class::Tiny {
    _data => sub { [] }
};



sub add_judge {
    my ( $self, $obs ) = @_;
    push @{ $self->_data }, $obs;
    return scalar @{ $self->_data };
}


sub best_majority_rank {
    my ($self) = shift;
    my %candidates = $self->candidates;
    my %best_maj;
    while ( my ( $cand, $scores ) = ( each %candidates ) ) {
        my @sorted = sort { $a <=> $b } @$scores;
        my $index  = int( @sorted / 2 );
        my $bom    = $sorted[$index];
        my ( $som, $tom, $to ) = (0) x 3;
        for (@sorted) {
            $to += $_;
            $tom += $_, $som++ if $_ <= $bom;
        }
        $best_maj{$cand} = {
            bom => $bom,
            som => $som,
            tom => $tom,
            to  => $to
        };
    }
    my %compare;
    for my $k ( keys %best_maj ) {
        $compare{$k} = 0;
        $compare{$k} += (
            $best_maj{$k}{bom} <=> $best_maj{$_}{bom}      # low is good
              || $best_maj{$_}{som} <=> $best_maj{$k}{som} # high is good
              || $best_maj{$k}{tom} <=> $best_maj{$_}{tom} # low is good
              || $best_maj{$k}{to} <=> $best_maj{$_}{to}   # low is good
        ) for keys %best_maj;
    }
    return _scores_to_ranks(%compare);
}


sub candidates {
    my ($self) = @_;
    my %c;
    for my $j ( $self->judges ) {
        push @{ $c{ $j->[$_] } }, $_ for 0 .. $#{$j};
    }
    return %c;
}


sub judges {
    my ($self) = @_;
    return @{ $self->_data };
}


sub mean_rank {
    my ($self) = shift;
    return $self->trimmed_mean_rank(0);
}


sub median_rank {
    my ($self) = shift;
    my %candidates = $self->candidates;
    my %medians;
    while ( my ( $cand, $scores ) = ( each %candidates ) ) {
        my @sorted = sort { $a <=> $b } @$scores;
        my $index = int( @sorted / 2 );
        $medians{$cand} = $sorted[$index];
    }
    return _scores_to_ranks(%medians);
}


sub trimmed_mean_rank {
    my ( $self, $trim ) = @_;
    die "Can't trim away all scores" if 2 * $trim >= $self->judges;
    my %candidates = $self->candidates;
    my %means;
    while ( my ( $cand, $scores ) = ( each %candidates ) ) {
        my @sorted = sort { $a <=> $b } @$scores;
        @sorted = @sorted[ $trim .. $#sorted - $trim ];
        my $avg = 0;
        $avg += $_ for @sorted;
        $means{$cand} = $avg / @sorted;
    }
    return _scores_to_ranks(%means);
}

#--------------------------------------------------------------------------#
# Private functions
#--------------------------------------------------------------------------#

sub _scores_to_ranks {
    my (%scores) = @_;
    my %ranks;
    my $cur_rank   = 0;
    my $index      = 0;
    my $last_score = -keys %scores;
    for my $cand ( sort { $scores{$a} <=> $scores{$b} } keys %scores ) {
        $index++;
        $cur_rank = $index if $scores{$cand} > $last_score;
        $ranks{$cand} = $cur_rank;
        $last_score = $scores{$cand};
    }
    return %ranks;
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__