view release on metacpan or  search on metacpan

t/80-sklearn-comparison-undef.t  view on Meta::CPAN

}

sub spearman_rho {
	my ( $xs, $ys ) = @_;
	my @rx = _assign_ranks(@$xs);
	my @ry = _assign_ranks(@$ys);
	my $n  = scalar @rx;
	my ( $sa, $sb, $saa, $sbb, $sab ) = (0) x 5;
	for my $i ( 0 .. $n - 1 ) {
		$sa  += $rx[$i];
		$sb  += $ry[$i];
		$saa += $rx[$i]**2;
		$sbb += $ry[$i]**2;
		$sab += $rx[$i] * $ry[$i];
	}
	my ( $ma, $mb ) = ( $sa / $n, $sb / $n );
	my $cov = $sab / $n - $ma * $mb;
	my $da  = sqrt( $saa / $n - $ma**2 );
	my $db  = sqrt( $sbb / $n - $mb**2 );
	return ( $da > 0 && $db > 0 ) ? $cov / ( $da * $db ) : 0;
} ## end sub spearman_rho

sub gaussian {
	my ( $mu, $sigma ) = @_;
	return $mu + $sigma * sqrt( -2 * log( rand() || 1e-12 ) ) * cos( 2 * PI * rand() );
}

# Test points used by every dataset: column 0 (x) carries the signal,
# columns 1..nf-1 are undef.  The matching @zero variant replaces undef
# with explicit 0.0 so the pure-Perl identity test has something to
# compare against.
sub make_undef_test_points {
	my ($nf) = @_;
	my @undef_test = (
		( map { [ $_ * 0.1, (undef) x ( $nf - 1 ) ] } -9 .. 9 ),              # 19 inlier-like
		( map { [ $_, (undef) x ( $nf - 1 ) ] } ( 6, 7, 8, -6, -7, -8 ) ),    # 6 outlier-like
	);
	my @zero_test = map { [ $_->[0], (0.0) x ( $nf - 1 ) ] } @undef_test;
	return ( \@undef_test, \@zero_test );
}

# -----------------------------------------------------------------------
# Datasets
#
# Each dataset hashref has:
#   label      -- short id (Python output key + subtest name)
#   n_feat     -- feature count
#   train      -- arrayref of training rows (no undef)
#   undef_test -- arrayref of test rows with undef in columns 1..nf-1
#   zero_test  -- same test rows but with explicit 0.0 in place of undef
#   n_in_test  -- number of leading inlier-like test rows
#   n_out_test -- number of trailing outlier-like test rows
#   mean_gap_min -- lower bound for mean(outlier) - mean(inlier) Perl scores.
#                   Set per-dataset because the gap shrinks as nf grows:
#                   trees that don't split on the lone signal column treat
#                   inlier-like and outlier-like test points identically, so
#                   their contribution to the score is the same.  Ordering
#                   (min/max separation) still holds in every dimension.
# -----------------------------------------------------------------------

# 2D regular grid + corner/axis outliers (the original undef dataset).
sub make_2d_grid_dataset {
	my @inliers;
	for my $i ( -7 .. 7 ) {
		for my $j ( -7 .. 7 ) {
			push @inliers, [ $i / 7.0, $j / 7.0 ];
		}
	}
	my @outliers = ( [ 6, 6 ], [ -6, 6 ], [ 6, -6 ], [ -6, -6 ], [ 0, 8 ], [ 8, 0 ], [ -8, 0 ], [ 0, -8 ] );
	my ( $undef_test, $zero_test ) = make_undef_test_points(2);
	return {
		label        => '2d_grid',
		n_feat       => 2,
		train        => [ @inliers, @outliers ],
		undef_test   => $undef_test,
		zero_test    => $zero_test,
		n_in_test    => 19,
		n_out_test   => 6,
		mean_gap_min => 0.20,
	};
} ## end sub make_2d_grid_dataset

# N-D Gaussian inliers + corner outliers far from origin in every axis.
# Test points still only carry signal in column 0; the other nf-1 columns
# are undef.  Seeded deterministically per dimension.
sub make_nd_gaussian_dataset {
	my ($nf) = @_;
	srand( 20260629 + $nf );

	my @inliers;
	push @inliers, [ map { gaussian( 0, 0.3 ) } 1 .. $nf ] for 1 .. 200;

	my @outliers;
	for ( 1 .. 8 ) {
		my @row;
		for ( 1 .. $nf ) {
			my $mag  = 5 + rand() * 3;
			my $sign = rand() > 0.5 ? 1 : -1;
			push @row, $mag * $sign;
		}
		push @outliers, \@row;
	}

	# Empirical gaps with 1 signal column out of nf, 100 trees, seed 42:
	#   nf=5  -> ~0.13   nf=10 -> ~0.05
	# The threshold is set well under the observed value so trivial RNG
	# noise doesn't flap the test, but high enough to still detect a real
	# regression that would collapse the gap further.
	my $mean_gap_min = $nf <= 5 ? 0.08 : 0.025;

	my ( $undef_test, $zero_test ) = make_undef_test_points($nf);
	return {
		label        => "${nf}d_gaussian",
		n_feat       => $nf,
		train        => [ @inliers, @outliers ],
		undef_test   => $undef_test,
		zero_test    => $zero_test,
		n_in_test    => 19,
		n_out_test   => 6,
		mean_gap_min => $mean_gap_min,
	};
} ## end sub make_nd_gaussian_dataset

my @datasets = ( make_2d_grid_dataset(), make_nd_gaussian_dataset(5), make_nd_gaussian_dataset(10), );

# -----------------------------------------------------------------------
# Locate Python + scikit-learn (cross-language subtests are skipped if
# absent; pure-Perl subtests still run)
# -----------------------------------------------------------------------
my $python_bin;
for my $cmd (qw(python3 python)) {
	my $probe = `$cmd -c "import sklearn; print('ok')" 2>/dev/null`;
	if ( defined $probe && $probe =~ /\bok\b/ ) {
		$python_bin = $cmd;
		last;
	}
}

# -----------------------------------------------------------------------
# Python helper: scores all datasets in one subprocess.  Each argv spec
# is "csv_path|label|n_train"; the CSV concatenates training rows then
# test rows, and n_train is the split point.  Test rows may use the
# token "nan" / "undef" / empty for missing values.