#!/usr/bin/env perl
#
# Cross-validation of sum(), min(), max(), mean(), var(), sd(), cov() and
# cor() against R, and the regression guard for the algorithms underneath
# them.
#
# 0.302 replaced the single-pass Welford recurrence in var(), sd() and cov()
# with the two-pass form R itself uses, and replaced the av_fetch() walk in
# all eight with a direct AvARRAY() scan.  Neither change can fail loudly: a
# variance computed the wrong way does not crash, it returns a plausible
# number that is not the sample's variance, and a scan that reads the array
# wrongly returns a plausible number computed over the wrong values.  So the
# guard has to be a frozen table of what R says, over inputs chosen to
# separate the algorithms rather than to be representative.
#
# Provenance:
#
#   * R 4.6.1 (2026-06-24) stats::var, stats::sd, stats::cov, stats::cor,
#     base::sum, base::min, base::max, at options(digits = 17).  The table in
#     __DATA__ is generated by t/var_sd_cov.R.R, committed next to this file;
#     re-run that script to regenerate it.  This test never calls R.
#   * R's variance is src/library/stats/src/cov.c.  Its MEAN macro takes a
#     first mean and refines it with a second pass, tmp = tmp + sum(x-tmp)/n,
#     and the COV macros then sum the centred products about the refined
#     mean.  Expanding that about the unrefined mean is the compensated
#     two-pass form the XS side computes, which is why these values agree.
#   * The two documented examples R pins in tests/Examples/stats-Ex.Rout.save
#     are asserted directly as well: var(1:10) == 9.166667 (from
#     src/library/stats/man/cor.Rd) and sd(1:2)^2 == 0.5 (man/sd.Rd).
#
# The corpus is rebuilt here rather than pasted in.  Every vector is exact
# integer arithmetic over a power-of-two denominator, so these are the same
# numbers R saw on a double, long double or __float128 perl alike; the n, sum,
# min and max columns are what pin this construction to R's.  A corpus of
# tenths would not survive the trip -- R would have computed on the double
# nearest 0.1 and a quadmath perl on a closer one.
#
# offset_1e9 is the case that earns its place twice: a mean of 1e9 carrying a
# spread of 0.05 is where a naive sum-of-squares variance loses every
# significant digit, and is the reason R refines its mean at all.

require 5.010;
use strict;
use warnings FATAL => 'all';
use Test::More;
use Stats::LikeR qw(sum min max mean var sd cov cor);

# 
# The corpus, rebuilt in perl.  Each sub returns the same vector its namesake
# in t/var_sd_cov.R.R builds in R.
# 
my %CASE = (
	int10       => sub { [ 1 .. 10 ] },
	int2        => sub { [ 1 .. 2 ] },
	eighths     => sub { [ map { $_ / 8 } 0 .. 63 ] },
	sixteenths  => sub { [ map { ( $_ % 17 ) / 16 - 0.5 } 0 .. 99 ] },
	offset_1e9  => sub { [ map { 1e9 + $_ / 1024 } 0 .. 99 ] },
	offset_1e6  => sub { [ map { 1e6 + ( $_ % 29 ) / 4 } 0 .. 499 ] },
	identical   => sub { [ (0.25) x 50 ] },
	two         => sub { [ 1.5, -2.25 ] },
	negpos      => sub { [ -8.5, 4.25, -2.125, 16, -32.75, 0.5 ] },
	long_dyadic => sub { [ map { ( $_ % 8191 ) / 512 - 8 } 0 .. 4999 ] },
);

# The cov()/cor() partner, mirroring partner() in t/var_sd_cov.R.R.
sub partner {
	my ($x) = @_;
	return [ map { $x->[$_] * 0.5 + ( $_ % 13 ) / 4 - 1.5 } 0 .. $#$x ];
}

# 
# Tolerances.
#
# Both are relative, and both are the worst disagreement actually observed on
# this build (perl-5.44.0, NV = double, -O2) rounded up to the next power of
# ten, so there is room for a long-double or __float128 perl to land a little
# differently.  Neither was widened to make anything pass; if one has to be,
# the algorithm changed and that is the thing to look at.
#
# $TOL_EXACT covers the quantities that come out exactly: n, sum, min and max.
# Every value in the corpus is dyadic and every one of these sums stays inside
# 53 bits, so the answer is the same number at every NV width, and the frozen
# column is that number's exact decimal expansion (see the %.40g note in
# t/var_sd_cov.R.R).  The arithmetic is therefore exact and the limit would be
# zero -- except that reading the literal back is not.
#
# perl's string-to-NV conversion is not correctly rounded on a long-double
# build: perl-5.12.5 reads "100000000004.833984375" as the long double one ulp
# below it (relative 7.45e-20, and 2^-27 / 1e11 is exactly one ulp there).  The
# number in the file is right and the sum is right; the reading is a bit short.
# So the limit is two ulps of whatever NV this perl was built with, measured at
# run time rather than hardcoded -- a double-sized epsilon here would be no
# limit at all on quadmath.
#
# Observed: 0 on perl-5.10.1, perl-5.42.3, perl-5.44.0 and 5.44.0-quadmath,
# 7.45e-20 on perl-5.12.5 -- against a limit of 2.17e-19 there.
#
# $TOL_ROUND covers mean().  sum/n is a real division, so unlike the columns
# above it rounds -- and it rounds to a different number at each NV width,
# while the frozen value is the double R computed.  The gap is bounded by half
# a double ulp; observed worst case 4.42e-17, on perl-5.12.5 (long double) and
# 5.44.0-quadmath.
#
# $TOL_STAT covers var, sd, cov and cor.  R accumulates these in LDOUBLE
# (long double) where a double-NV perl accumulates in double, so the two
# cannot be expected to agree to the last bit on an ill-centred column.
# Observed worst case 8.74e-15, on offset_1e9 -- mean 1e9, spread 0.05 -- so
# the limit is that rounded up by two orders of magnitude.  A long-double or
# __float128 perl computes the same quantities more precisely than the frozen
# doubles R rounded to, so it moves towards this limit, not away from it.
#
# The headroom is deliberately far short of what a wrong algorithm costs: the
# one-pass correlation this release replaced missed offset_1e6 by 2.15e-05 and
# returned NaN for offset_1e9, and the naive sum-of-squares variance fails
# these columns by more still.  A regression has to fail, not squeak through.
# 
# NV_EPSILON for the perl actually running this, found by bisection: perl
# exposes no constant for it, and $Config{nvsize} does not distinguish an
# x87 long double from a __float128.
my $NV_EPS = do {
	my $e = 1.0;
	$e /= 2 while ( 1.0 + $e / 2 ) != 1.0;
	$e;
};

my $TOL_EXACT = 2 * $NV_EPS;
my $TOL_ROUND = 1e-15;
my $TOL_STAT  = 1e-12;

sub rel {
	my ( $got, $want ) = @_;
	return abs($got) if $want == 0;
	return abs( $got - $want ) / abs($want);
}

sub close_to {
	my ( $got, $want, $tol, $name ) = @_;
	my $r = rel( $got, $want );
	ok( $r <= $tol, $name )
		or diag(
		sprintf "got %.17g\nwant %.17g\nrelative error %.3g > %.3g",
		$got, $want, $r, $tol );
	return $r;
}

# 
# Parse the frozen table.
# 
my ( %STAT, %PAIR );
while ( my $line = <DATA> ) {
	next if $line =~ /^\s*(?:#|$)/;
	chomp $line;
	my @f = split /\t/, $line;
	if ( $f[0] eq 'STAT' ) {
		my ( undef, $name, @v ) = @f;
		@{ $STAT{$name} }{qw(n sum min max mean var sd)} = @v;
	}
	elsif ( $f[0] eq 'PAIR' ) {
		my ( undef, $name, @v ) = @f;
		@{ $PAIR{$name} }{qw(n cov cor)} = @v;
	}
	else { die "unparsable line in __DATA__: $line" }
}

my $worst_exact = 0;
my $worst_stat  = 0;
sub note_worst { my ( $r, $which ) = @_;
	if   ($which) { $worst_stat  = $r if $r > $worst_stat }
	else          { $worst_exact = $r if $r > $worst_exact }
}

# 
# A. every case, as a plain array ref -- the AvARRAY() fast path.
# 
for my $name ( sort keys %CASE ) {
	my $x = $CASE{$name}->();
	my $e = $STAT{$name} or die "no frozen row for $name";

	is( scalar @$x, $e->{n}, "$name: length matches R" );
	note_worst( close_to( sum($x), $e->{sum}, $TOL_EXACT, "$name: sum" ),  0 );
	note_worst( close_to( min($x), $e->{min}, $TOL_EXACT, "$name: min" ),  0 );
	note_worst( close_to( max($x), $e->{max}, $TOL_EXACT, "$name: max" ),  0 );

	# R's own mean() refines its mean with a second pass, exactly as var()
	# does; Stats::LikeR's mean() is the single-pass sum/n.  So the column
	# frozen for it is R's sum(x)/length(x), not R's mean(x).  The two differ
	# only in the last bits, but comparing against mean() would be comparing
	# against an algorithm this module does not implement.
	close_to( mean($x), $e->{mean}, $TOL_ROUND, "$name: mean" );

	next if @$x < 2;
	note_worst( close_to( var($x), $e->{var}, $TOL_STAT, "$name: var" ), 1 );
	note_worst( close_to( sd($x),  $e->{sd},  $TOL_STAT, "$name: sd" ),  1 );

	my $p = $PAIR{$name} or die "no frozen pair row for $name";
	my $y = partner($x);
	note_worst( close_to( cov( $x, $y ), $p->{cov}, $TOL_STAT, "$name: cov" ), 1 );

	if ( $p->{cor} eq 'NA' ) {
		# Zero variance: R warns and returns NA, Stats::LikeR croaks.
		eval { cor( $x, $y ); 1 };
		like( $@, qr/standard deviation of x is 0/,
			"$name: cor croaks on a zero-variance column" );
	}
	else {
		note_worst( close_to( cor( $x, $y ), $p->{cor}, $TOL_STAT, "$name: cor" ), 1 );
	}
}

# 
# B. the two examples R pins in tests/Examples/stats-Ex.Rout.save, asserted at
#    the precision R prints them.
# 
close_to( var( [ 1 .. 10 ] ), 9.166667, 1e-7, 'var(1:10) == 9.166667 (R man/cor.Rd)' );
close_to( sd( [ 1, 2 ] )**2, 0.5,       1e-15, 'sd(1:2)^2 == 0.5 (R man/sd.Rd)' );

# 
# C. the same corpus through a tied array, which cannot use the AvARRAY() scan
#    and must reach the same answers through av_fetch().
#
#    This is the assertion that the fast path and the slow path are the same
#    function.  Without it a scan that read, say, one element short would pass
#    every value check above only if it were wrong in both paths at once.
# 
{
	package t::TiedArray;
	require Tie::Array;
	our @ISA = ('Tie::StdArray');
}

for my $name ( sort keys %CASE ) {
	my $x = $CASE{$name}->();
	my @t;
	tie @t, 't::TiedArray';
	@t = @$x;

	is( sum( \@t ), sum($x), "$name: sum agrees between tied and plain" );
	is( min( \@t ), min($x), "$name: min agrees between tied and plain" );
	is( max( \@t ), max($x), "$name: max agrees between tied and plain" );
	is( mean( \@t ), mean($x), "$name: mean agrees between tied and plain" );
	next if @$x < 2;
	is( var( \@t ), var($x), "$name: var agrees between tied and plain" );
	is( sd( \@t ),  sd($x),  "$name: sd agrees between tied and plain" );

	my $y = partner($x);
	my @ty;
	tie @ty, 't::TiedArray';
	@ty = @$y;
	is( cov( \@t, \@ty ), cov( $x, $y ), "$name: cov agrees between tied and plain" );
}

diag( sprintf 'NV_EPSILON %.3g; worst relative error: exact %.3g (limit %.3g), statistical %.3g (limit %.3g)',
	$NV_EPS, $worst_exact, $TOL_EXACT, $worst_stat, $TOL_STAT );

done_testing();

__DATA__
# name	n	sum	min	max	mean_naive	var	sd
STAT	int10	10	55	1	10	5.5	9.166666666666666074547720199916511774063	3.027650354097491725013924224185757339001
STAT	int2	2	3	1	2	1.5	0.5	0.7071067811865475727373109293694142252207
STAT	eighths	64	252	0	7.875	3.9375	5.416666666666666962726139900041744112968	2.327373340628156928033831718494184315205
STAT	sixteenths	100	-0.9375	-0.5	0.5	-0.009374999999999999653055304804638581117615	0.09204348169191918505038785269789514131844	0.3033866867413914647499950660858303308487
STAT	offset_1e9	100	100000000004.833984375	1000000000	1000000000.0966796875	1000000000.04833984375	0.0008026758829752603805265942504831855330849	0.0283315351326972816869975702047668164596
STAT	offset_1e6	500	500001730.75	1000000	1000007	1000003.46149999997578561305999755859375	4.430503757515030116564958007074892520905	2.104876185792178500122417972306720912457
STAT	identical	50	12.5	0.25	0.25	0.25	0	0
STAT	two	2	-0.75	-2.25	1.5	-0.375	7.03125	2.651650429449553314498189138248562812805
STAT	negpos	6	-22.625	-32.75	16	-3.770833333333333481363069950020872056484	267.665104166666651508421637117862701416	16.36047383686263145818884368054568767548
STAT	long_dyadic	5000	-15590.8203125	-8	1.763671875	-3.1181640625	7.94887542724609375	2.819375006494541313628587886341847479343
# name	n	cov	cor
PAIR	int10	10	6.875	1
PAIR	int2	2	0.375	1
PAIR	eighths	64	3.062996031746031633247184799984097480774	0.8200938004691451510552724357694387435913
PAIR	sixteenths	100	0.03581025094696969890417648230140912346542	0.1261376821218928578893780922953737899661
PAIR	offset_1e9	100	0.001671362404871468620645713620831429579994	0.06345446373380146665166279262848547659814
PAIR	offset_1e6	500	2.231880886773546901480358428671024739742	0.7494399781759596423924563168839085847139
PAIR	identical	50	0	NA
PAIR	two	2	3.046875	1
PAIR	negpos	6	132.635677083333320069868932478129863739	0.9983805197732339431482273539586458355188
PAIR	long_dyadic	5000	3.976392206084038871694019690039567649364	0.8333788643107939986265364495920948684216
