acr-compare

#!/usr/bin/env perl 
#  PODNAME: acr-compare
#  compare voting methods with & without Average Choice Ranking (ACR) tiebreaking

use Modern::Perl qw(2024);
use utf8;
use Carp qw(croak);
use Readonly;
use Getopt::Long;
use FindBin;
use File::Basename;
use Text::Table::Tiny 1.02 qw(generate_table);
use HTML::Escape qw(escape_html);
use YAML::XS qw(Load LoadFile);
use IPC::Run qw(run);

# constants
Readonly::Scalar my $pvroot => dirname($FindBin::RealBin);
Readonly::Scalar my $datadir => "$pvroot/test/inputs/100-rcv-test";
Readonly::Scalar my $count_script => "$pvroot/lab/perl/prefvote/bin/vote-count";

# global flags
my $html_mode = 0;

# collect run data for all voting methods, with and without avg choice rank (ACR) tiebreaking
sub collect_rundata
{
    my ( $path, $methods ) = @_;
    my %rundata;

    # loop through voting methods - run vote counting with and without ACR tiebreaking
    foreach my $method (@$methods) {
        my $yaml_text;
        my @cmd = ($count_script, "--format=yaml", "--method=$method", $path);
        run \@cmd, \undef, \$yaml_text;
        my @raw_rundata = Load($yaml_text);
        if (not exists $raw_rundata[0]{$method}) {
            croak "malformed YAML output from $path: $method voting result not found";
        }
        $rundata{$method} = $raw_rundata[0]{$method};

        # collect non-ACR result for voting methods except Core
        next if $method eq "Core";
        my $method_key = $method."-notb"; # suffix means no-tiebreaking
        push @cmd, "--config", "no-tiebreak=1";
        my $yaml_text_notb;
        run \@cmd, \undef, \$yaml_text_notb;
        my @raw_rundata_notb = Load($yaml_text_notb);
        if (not exists $raw_rundata_notb[0]{$method}) {
            croak "malformed YAML output from $path: $method_key voting result not found";
        }
        $rundata{$method_key} = $raw_rundata_notb[0]{$method};
    }
    return \%rundata;
}

# output formatting for avg choice rank (ACR) data
sub acr_fmt
{
    my ($rundata, $choice) = @_;
    my $acr = $rundata->{Core}{average_choice_rank};
    my $cr = $rundata->{Core}{choice_rank};
    my $total_place = 0;
    my $total_votes = 0;
    my $cols = scalar @{$cr->{$choice}};
    for (my $i=0; $i<$cols; $i++) {
        $total_votes += $cr->{$choice}[$i];
        $total_place += ($i+1)*$cr->{$choice}[$i];
    }
    return sprintf "%7.5f (%d/%d)", $acr->{$choice}, $total_place, $total_votes;
}

sub html_table
{
    my %opts = @_;
    my $rows = $opts{rows};

    # table heading
    say "<table border=1>";

    # generate header from first row
    if ($opts{header_row} // 0) {
        my $header = shift @$rows;
        say "<thead>";
        say "<tr>";
        foreach my $col_item (@$header) {
            say "<th>".escape_html($col_item)."</th>";
        }
        say "</tr>";
        say "</thead>";
    }

    # generate table from remainder of rows
    say "<tbody>";
    foreach my $row (@$rows) {
        say "<tr>";
        foreach my $col_item (@$row) {
            say "<td>".escape_html($col_item)."</td>";
        }
        say "</tr>";
    }
    say "</tbody>";
    say "</table>";
    return;
}

# load data and do comparison
sub do_compare
{
    my $path = shift;
    my @yaml_doc = LoadFile($path);
    my $metadata = $yaml_doc[0];
    my @methods = split " ", $metadata->{method};
    my $rundata = collect_rundata($path, \@methods);

    # print title
    say "title: ".$metadata->{params}{name}." (".$rundata->{Core}{total_ballots}." ballots)";

    # collect some runtime data locations
    my $choices = $rundata->{Core}{choices};

    # use KR2 Copeland score for pairwise victories (pwv) and Condorcet result
    # using this we can see where Schulze, Ranked Pairs & KR2 resolve ambiguities
    my %pwv;
    my $kr2_copeland = $rundata->{KR2}{copeland};
    {
        my @pwv_order = sort {$kr2_copeland->{$b} <=> $kr2_copeland->{$a}} sort grep { not /^_/x } keys %$kr2_copeland;
        for (my $i=0; $i<scalar @pwv_order; $i++) {
            if ($i>0 and $kr2_copeland->{$pwv_order[$i]} == $kr2_copeland->{$pwv_order[$i-1]}) {
                $pwv{$pwv_order[$i]} = $pwv{$pwv_order[$i-1]};
            } else {
                $pwv{$pwv_order[$i]} = $i+1;
            }
        }
    }

    # compare result order
    my @choices = keys %$choices;
    my $num_choices = scalar @choices;
    my @core_order = sort {$rundata->{Core}{choice_to_result}{$a}[0] <=> $rundata->{Core}{choice_to_result}{$b}[0]} @choices;
    my @table = (["choice", "avg choice rank", @methods, "Copeland"]);
    for (my $i=0; $i<$num_choices; $i++) {
        my @row = ($core_order[$i], acr_fmt($rundata, $core_order[$i]));
        foreach my $method (@methods) {
            if ($method eq "Core") {
                push @row, $rundata->{$method}{choice_to_result}{$core_order[$i]}[0];
            } else {
                push @row, $rundata->{$method}{choice_to_result}{$core_order[$i]}[0]." / "
                    .$rundata->{$method."-notb"}{choice_to_result}{$core_order[$i]}[0];
            }
        }
        push @row, $pwv{$core_order[$i]}." (".$kr2_copeland->{$core_order[$i]}.")";
        push @table, \@row;
    }
    if ($html_mode) {
        say html_table(rows =>\@table, header_row => 1);
        say "<p><small><i>Voting results shown with/without ACR tie-breaking.</i></small></p>";
    } else {
        say generate_table(rows =>\@table, header_row => 1, style => 'boxrule');
        say "Voting results shown with/without ACR tie-breaking.";
        say "";
    }
}

# main
GetOptions( "html" => \$html_mode);
my @yaml_files;
if (scalar @ARGV > 0) {
    # get file list from command line
    @yaml_files = @ARGV;
} else {
    # get file list from YAML-suffixed files in blackbox test data directory
    opendir(my $dh, $datadir) || die "Can't opendir $datadir: $!";
    @yaml_files = map { $datadir."/".$_ } sort grep { /^[^.].*\.(yaml|yml)$/ and -f "$datadir/$_" } readdir($dh);
    closedir $dh;
}

binmode(STDOUT, ":encoding(UTF-8)");
#say join " ", @yaml_files;

foreach my $file (@yaml_files) {
    do_compare($file);
}