require 5.010;
use strict;
use warnings FATAL => 'all';
use Test::More;
use Stats::LikeR qw(friedman_test mcnemar_test prop_test cmh_test);

# Cross-validation of friedman_test(), mcnemar_test(), prop_test() and
# cmh_test() against the R functions each one ports, using R's own man-page
# examples rather than cases invented here.  The hand-written t/friedman_test.t,
# t/mcnemar_test.t and t/prop_test.t already cover the call shapes, the croak
# messages and leak checking; this file does not repeat them.
#
# Four functions share one file because they share one shape of answer -- a
# statistic, a df, a p-value, and sometimes an estimate and an interval -- and
# one source.
#
# PROVENANCE
# ----------
# The DATA section at the end holds the frozen table, regenerated by
# t/friedman_mcnemar_prop_cmh.R.R under R 4.6.1 (2026-06-24).  The generator is
# never run by the test, so the distribution installs and tests with no R.
#
#   friedman_test  <- stats::friedman.test
#       src/library/stats/man/friedman.test.Rd -- the Hollander & Wolfe (1973)
#       p.140ff RoundingTimes matrix (22 players x 3 rounding methods, and the
#       page's own conclusion is "strong evidence against the null"), and the
#       warpbreaks aggregate example, which is the k = 2 boundary.
#   mcnemar_test   <- stats::mcnemar.test
#       src/library/stats/man/mcnemar.test.Rd -- Agresti (1990) p.350,
#       Presidential Approval Ratings, 1600 voting-age Americans.
#   prop_test      <- stats::prop.test
#       src/library/stats/man/prop.test.Rd -- Fleiss (1981) p.139, four groups
#       of patients, plus the one-sample form the page opens with.
#   cmh_test       <- stats::mantelhaen.test
#       src/library/stats/man/mantelhaen.test.Rd -- Agresti (1990) pp.231-237,
#       Penicillin and Rabbits (2x2x5, where the page's own answer is
#       "p = 0.047"), and UCBAdmissions (2x2x6).
#
# Each is crossed over its own switches (correct, exact, alternative, p,
# conf.level) and over the edges the references themselves cover: all-ties,
# k = 2, b == c, 3x3 and 4x4 tables, 0 and n successes, both extremes at once.
#
# TOLERANCE
# ---------
# One limit for everything here, because every quantity in the table came out
# at much the same accuracy: over all 274 comparisons the worst relative
# disagreement with R measured on a double build is 1.24e-14, on the
# mantelhaen.test common-odds-ratio interval for UCBAdmissions (the interval is
# built through a normal quantile, so it is the one quantity here not read
# straight off the counts).  Statistics and p-values sit at 1e-16.  The limit
# leaves that worst case a factor of ~800, which is ample for long-double and
# quadmath, and is still tight enough that any real change in these functions
# fails here.  Do not widen it to make a failure go away.
my $TOL = 1e-11;

# Reading the layout conversions below:
#
#   friedman_test takes one block per row, one treatment per column, which is
#   R's matrix orientation, so those go straight across.
#
#   cmh_test takes each stratum as [a, b, c, d] = [x11, x12, x21, x22].  R's
#   array(..., dim = c(2,2,k)) fills column-major, so a group of four written
#   out in the man page is (x11, x21, x12, x22) -- a, c, b, d.  Every stratum
#   below is therefore re-ordered once, here, rather than silently in the data.
sub acbd_to_abcd {
	my @q = @_;
	return [ $q[0], $q[2], $q[1], $q[3] ];
}

my $RT = [
	[5.40,5.50,5.55], [5.85,5.70,5.75], [5.20,5.60,5.50], [5.55,5.50,5.40],
	[5.90,5.85,5.70], [5.45,5.55,5.60], [5.40,5.40,5.35], [5.45,5.50,5.35],
	[5.25,5.15,5.00], [5.85,5.80,5.70], [5.25,5.20,5.10], [5.65,5.55,5.45],
	[5.60,5.35,5.45], [5.05,5.00,4.95], [5.50,5.50,5.40], [5.45,5.55,5.50],
	[5.55,5.55,5.35], [5.45,5.50,5.55], [5.50,5.45,5.25], [5.65,5.60,5.40],
	[5.70,5.65,5.55], [6.30,6.30,6.25],
];

# aggregate(warpbreaks$breaks, by = list(w = wool, t = tension), FUN = mean)
# returns wool varying fastest, so the six means are (A,L) (B,L) (A,M) (B,M)
# (A,H) (B,H) -- three blocks of two treatments.
my @WB = (44.555555555555557, 28.222222222222221, 24,
          28.777777777777779, 24.555555555555557, 18.777777777777779);
my $WB_MATRIX = [ [ $WB[0], $WB[1] ], [ $WB[2], $WB[3] ], [ $WB[4], $WB[5] ] ];

# UCBAdmissions, as R prints each stratum column-major
my @UCB_RAW = ([512,313,89,19], [353,207,17,8], [120,205,202,391],
               [138,279,131,244], [53,138,94,299], [22,351,24,317]);
my @UCB = map { acbd_to_abcd(@$_) } @UCB_RAW;

# Agresti's Rabbits, likewise
my @RABBITS = map { acbd_to_abcd(@$_) }
	([0,0,6,5], [3,0,3,6], [6,2,0,4], [5,6,1,0], [2,5,0,0]);

# the man page's own three-stratum illustration
my @DOC3 = map { acbd_to_abcd(@$_) } ([10,5,3,12], [20,8,6,15], [7,9,4,11]);

#
# label => a closure returning the numbers in the table's own order.
#
# htest3 order is (statistic, parameter, p.value); prop and mh append the
# estimate(s) and then the interval, exactly as the generator emits them.
#
sub htest3 { my $r = shift; [ $r->{statistic}, $r->{parameter}, $r->{'p.value'} ] }

sub with_est {
	my $r = shift;
	my @est = ref $r->{estimate} ? @{ $r->{estimate} } : ($r->{estimate});
	return [ $r->{statistic}, $r->{parameter}, $r->{'p.value'}, @est,
	         @{ $r->{'conf.int'} || [] } ];
}

my %CASE = (
	# ---- friedman_test ----
	'friedman.roundingtimes' => sub { htest3(friedman_test($RT)) },
	'friedman.warpbreaks'    => sub { htest3(friedman_test($WB_MATRIX)) },
	'friedman.noties'        => sub { htest3(friedman_test([[1,2,3],[2,3,1],[3,1,2],[1,3,2]])) },
	'friedman.ties'          => sub { htest3(friedman_test([[1,1,2],[2,2,2],[3,1,1],[1,2,2]])) },
	'friedman.k2'            => sub { htest3(friedman_test([[1,2],[2,1],[1,2],[2,2],[1,1]])) },
	'friedman.allsame'       => sub { htest3(friedman_test([[1,1,1],[1,1,1],[1,1,1],[1,1,1]])) },

	# ---- mcnemar_test ----
	'mcnemar.perf.corr'    => sub { htest3(mcnemar_test([[794,86],[150,570]])) },
	'mcnemar.perf.nocorr'  => sub { htest3(mcnemar_test([[794,86],[150,570]], correct => 0)) },
	'mcnemar.small.corr'   => sub { htest3(mcnemar_test([[10,8],[2,12]])) },
	'mcnemar.small.nocorr' => sub { htest3(mcnemar_test([[10,8],[2,12]], correct => 0)) },
	'mcnemar.small.exact'  => sub { [ mcnemar_test([[10,8],[2,12]], exact => 1)->{'p.value'} ] },
	'mcnemar.equal.corr'   => sub { htest3(mcnemar_test([[10,5],[5,10]])) },
	'mcnemar.equal.nocorr' => sub { htest3(mcnemar_test([[10,5],[5,10]], correct => 0)) },
	'mcnemar.3x3'          => sub { htest3(mcnemar_test([[10,5,2],[3,12,4],[1,6,15]])) },
	'mcnemar.4x4'          => sub {
		htest3(mcnemar_test([[20,3,1,2],[4,25,2,1],[0,3,18,5],[1,2,4,22]]))
	},

	# ---- prop_test ----
	'prop.1s.83.100.corr'   => sub { with_est(prop_test(83, 100)) },
	'prop.1s.83.100.nocorr' => sub { with_est(prop_test(83, 100, correct => 0)) },
	'prop.1s.cl90'          => sub { with_est(prop_test(83, 100, 'conf.level' => 0.9)) },
	'prop.1s.cl99'          => sub { with_est(prop_test(83, 100, 'conf.level' => 0.99)) },
	'prop.fleiss4'          => sub { with_est(prop_test([83,90,129,70], [86,93,136,82])) },
	'prop.1s.0.10'          => sub { with_est(prop_test(0, 10)) },
	'prop.1s.10.10'         => sub { with_est(prop_test(10, 10)) },
	'prop.1s.5.10'          => sub { with_est(prop_test(5, 10)) },
	'prop.2s.extreme'       => sub { with_est(prop_test([0,10], [10,10])) },

	# ---- cmh_test ----
	'mh.rabbits.corr'   => sub { with_est(cmh_test(\@RABBITS)) },
	'mh.rabbits.nocorr' => sub { with_est(cmh_test(\@RABBITS, correct => 0)) },
	'mh.ucb.corr'       => sub { with_est(cmh_test(\@UCB)) },
	'mh.ucb.nocorr'     => sub { with_est(cmh_test(\@UCB, correct => 0)) },
	'mh.ucb.cl90'       => sub { with_est(cmh_test(\@UCB, 'conf.level' => 0.9)) },
	'mh.doc3.corr'      => sub { with_est(cmh_test(\@DOC3)) },
	'mh.doc3.nocorr'    => sub { with_est(cmh_test(\@DOC3, correct => 0)) },
);

# The alternative/correct sweeps, built the same way the generator built them.
for my $alt (qw(two.sided less greater)) {
	for my $co (1, 0) {
		my $suffix = $co ? 'corr' : 'nocorr';
		$CASE{"prop.1s.p7.$alt.$suffix"} = sub {
			with_est(prop_test(83, 100, p => 0.7, alternative => $alt, correct => $co))
		};
		$CASE{"prop.2s.$alt.$suffix"} = sub {
			with_est(prop_test([83, 90], [100, 100], alternative => $alt, correct => $co))
		};
	}
}

# cmh_test returns a scalar estimate (the common odds ratio), while prop_test
# returns one estimate per group; with_est() flattens either.
sub check_row {
	my ($label, $exp) = @_;
	my $fn = $CASE{$label} or do { fail("no case registered for '$label'"); return 0 };
	my $got = eval { $fn->() };
	if ($@) { fail("$label: died: $@"); return 0 }
	is(scalar @$got, scalar @$exp, "$label: value count")
		or diag("got [@$got] against [@$exp]");
	my $worst = 0;
	for my $i (0 .. $#$exp) {
		my ($e, $g) = ($exp->[$i], $got->[$i]);
		if ($e eq 'NaN') {
			ok(!defined $g || $g != $g, "$label\[$i]: NaN, as in R");
			next;
		}
		if (!defined $g) { fail("$label\[$i]: got undef, expected $e"); next }
		my $err = $e == 0 ? abs($g) : abs($g - $e) / abs($e);
		$worst = $err if $err > $worst;
		ok($err <= $TOL, "$label\[$i]")
			or diag(sprintf 'got %.17g, expected %s, rel err %.4g', $g, $e, $err);
	}
	return $worst;
}

my ($rows, $worst_overall, $worst_at) = (0, 0, '');
while (my $line = <DATA>) {
	next if $line =~ /\A\s*#/ || $line !~ /\S/;
	chomp $line;
	my ($label, $values) = split /\t/, $line;
	$rows++;
	my $w = check_row($label, [ split /,/, $values ]);
	if ($w > $worst_overall) { $worst_overall = $w; $worst_at = $label }
}
cmp_ok($rows, '>', 40, "reference cases exercised ($rows)");

# Every registered case must appear in the table, so a row deleted from the
# data section cannot quietly stop being checked.
is(scalar(keys %CASE), $rows, 'every registered case has a row in the table');

#
# The behaviours that are not numbers, and so cannot live in the table.
#
{
	# friedman.test on an all-identical matrix: R returns NaN rather than
	# erroring (the tie correction divides by zero), and the table above pins
	# that.  What it cannot pin is that the df is still reported.
	my $r = friedman_test([[1,1,1],[1,1,1],[1,1,1],[1,1,1]]);
	is($r->{parameter}, 2, 'friedman: df is still k-1 when the statistic is NaN');

	# mcnemar_test's two-vector form cross-tabulates, so it must agree with the
	# matrix form built from the same pairs.  R does the same via table().
	my @before = (qw(a a a a b b b), 'a', 'b', 'b');
	my @after  = (qw(a a b b b b a), 'b', 'a', 'b');
	my $v = mcnemar_test(\@before, \@after);
	# a/a = 2, a/b = 3, b/a = 2, b/b = 3
	my $m = mcnemar_test([[2, 3], [2, 3]]);
	is($v->{statistic}, $m->{statistic},
		'mcnemar: the paired-vector form matches the cross-tabulated matrix');
	is($v->{'p.value'}, $m->{'p.value'}, '...and so does its p-value');

	# prop.test's k-sample form has no confidence interval, which is R's own
	# behaviour and is what distinguishes it from the 1- and 2-group forms.
	my $k = prop_test([83, 90, 129, 70], [86, 93, 136, 82]);
	ok(!defined $k->{'conf.int'}, 'prop_test: no interval for k > 2 groups, as in R');
	is($k->{parameter}, 3, 'prop_test: df is k-1 for the k-sample chi-square');
	my $two = prop_test([83, 90], [100, 100]);
	ok(ref $two->{'conf.int'} eq 'ARRAY', 'prop_test: two groups do get an interval');
	is($two->{parameter}, 1, '...on 1 df');

	# cmh_test reports how many strata it pooled, which R does not, and R
	# refuses a single-stratum array outright ("each dimension in table must be
	# >= 2").  cmh_test accepts one, so there is nothing to compare it against;
	# all that is asserted is that k is reported and the call does not die.
	is(cmh_test(\@UCB)->{k}, 6, 'cmh_test: k counts the strata');
	my $one = eval { cmh_test([[10, 3, 5, 12]]) };
	ok(!$@, 'cmh_test accepts a single stratum, which R rejects');
	is($one->{k}, 1, '...and reports k = 1') if ref $one;
}

diag(sprintf 'worst relative error vs R: %.4g (%s)', $worst_overall, $worst_at);

done_testing();

__DATA__
# ---- R 4.6.1, generated by t/friedman_mcnemar_prop_cmh.R.R ----
# label <TAB> comma-separated values (see check_row for the order per prefix)
friedman.roundingtimes	11.142857142857142,2,0.003805040775511363
friedman.warpbreaks	0.33333333333333331,1,0.56370286165077299
friedman.noties	0.5,2,0.77880078307140488
friedman.ties	0.66666666666666663,2,0.71653131057378938
friedman.k2	0.33333333333333331,1,0.56370286165077299
friedman.allsame	NaN,2,NaN
mcnemar.perf.corr	16.817796610169491,1,4.1145622813459436e-05
mcnemar.perf.nocorr	17.35593220338983,1,3.0992934410452182e-05
mcnemar.small.corr	2.5,1,0.11384629800665812
mcnemar.small.nocorr	3.6000000000000001,1,0.057779571123597537
mcnemar.small.exact	0.10937499999999994
mcnemar.equal.corr	0,1,1
mcnemar.equal.nocorr	0,1,1
mcnemar.3x3	1.2333333333333334,3,0.74502120054818577
mcnemar.4x4	2.1206349206349207,6,0.90827604470794765
prop.1s.83.100.corr	42.25,1,8.0320011677182356e-11,0.82999999999999996,0.73891304545571468,0.89506655465122231
prop.1s.83.100.nocorr	43.560000000000002,1,4.1115778187990309e-11,0.82999999999999996,0.74451995232398871,0.89106433885940062
prop.1s.p7.two.sided.corr	7.4404761904761934,1,0.0063773014216883164,0.82999999999999996,0.73891304545571468,0.89506655465122231
prop.1s.p7.two.sided.nocorr	8.0476190476190492,1,0.004556349803185129,0.82999999999999996,0.74451995232398871,0.89106433885940062
prop.1s.p7.less.corr	7.4404761904761934,1,0.99681134928915582,0.82999999999999996,0,0.88706234361363023
prop.1s.p7.less.nocorr	8.0476190476190492,1,0.99772182509840746,0.82999999999999996,0,0.88289040523192919
prop.1s.p7.greater.corr	7.4404761904761934,1,0.0031886507108441616,0.82999999999999996,0.75417684887827663,1
prop.1s.p7.greater.nocorr	8.0476190476190492,1,0.0022781749015925649,0.82999999999999996,0.7597233990511757,1
prop.1s.cl90	42.25,1,8.0320011677182356e-11,0.82999999999999996,0.75417684887827663,0.88706234361363023
prop.1s.cl99	42.25,1,8.0320011677182356e-11,0.82999999999999996,0.70786579076120171,0.90906088869165036
prop.fleiss4	12.600411297127639,3,0.0055854766616270247,0.96511627906976749,0.967741935483871,0.94852941176470584,0.85365853658536583
prop.2s.two.sided.corr	1.5414258188824661,1,0.21440569960546541,0.82999999999999996,0.90000000000000002,-0.1742210769128868,0.034221076912886686
prop.2s.two.sided.nocorr	2.0980518090344682,1,0.14748695568917752,0.82999999999999996,0.90000000000000002,-0.16422107691288682,0.024221076912886691
prop.2s.less.corr	1.5414258188824661,1,0.10720284980273266,0.82999999999999996,0.90000000000000002,-1,0.01907282037726038
prop.2s.less.nocorr	2.0980518090344682,1,0.073743477844588942,0.82999999999999996,0.90000000000000002,-1,0.0090728203772603849
prop.2s.greater.corr	1.5414258188824661,1,0.89279715019726735,0.82999999999999996,0.90000000000000002,-0.1590728203772605,1
prop.2s.greater.nocorr	2.0980518090344682,1,0.9262565221554111,0.82999999999999996,0.90000000000000002,-0.1490728203772605,1
prop.1s.0.10	8.0999999999999996,1,0.0044265258579198295,0,0,0.34453721830692247
prop.1s.10.10	8.0999999999999996,1,0.0044265258579198295,1,0.65546278169307748,1
prop.1s.5.10	0,1,1,0.5,0.23659309051256402,0.76340690948743595
prop.2s.extreme	16.199999999999999,1,5.6994116233318465e-05,0,1,-1,-0.90000000000000002
mh.rabbits.corr	3.9285714285714288,1,0.047472255142918106,7,1.026712688461668,47.725133380222566
mh.rabbits.nocorr	5.6571428571428575,1,0.017384420352066179,7,1.026712688461668,47.725133380222566
mh.ucb.corr	1.4269462285866883,1,0.23226346281704827,0.90469682825862308,0.77190736175935049,1.0603297644366556
mh.ucb.nocorr	1.5246066604434356,1,0.21692369705551837,0.90469682825862308,0.77190736175935049,1.0603297644366556
mh.ucb.cl90	1.4269462285866883,1,0.23226346281704827,0.90469682825862308,0.79186030159854326,1.0336120517835519
mh.doc3.corr	13.199697886817921,1,0.00027999424986994249,4.7735261124267723,2.0969889496845999,10.866319323927524
mh.doc3.nocorr	14.631044964163097,1,0.00013074294965583619,4.7735261124267723,2.0969889496845999,10.866319323927524
