view release on metacpan or  search on metacpan

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

#!perl
# 80-sklearn-comparison-undef.t
#
# Verifies consistent handling of undef (Perl) / NaN (Python) when one or
# more feature columns are missing during scoring and prediction.
#
# Perl coerces undef to 0 in numeric comparisons, so score_samples and
# predict on data with undef columns are bit-for-bit identical to the same
# calls with explicit 0 in those columns.  The Python side uses
# numpy.where(isnan, 0, x) to apply the same substitution before scoring.
#
# The same battery runs against multiple datasets so the undef handling is
# exercised on more than the 2-feature case:
#
#   * "2d_grid"      -- 225 grid inliers + 8 outliers (2 dims); y-column undef
#   * "5d_gaussian"  -- 200 Gaussian inliers + 8 corner outliers (5 dims);
#                       4 trailing columns undef
#   * "10d_gaussian" -- same shape in 10 dims; 9 trailing columns undef
#
# For each dataset:
#   1. score_samples([x, undef, ...]) == score_samples([x, 0, ...])  exact
#   2. predict([x, undef, ...])       == predict([x, 0, ...])        exact
#   3. Spearman rho between Perl(undef→0) and sklearn(NaN→0) scores >= 0.90
#   4. Both implementations still rank the x-axis outliers above the
#      inliers after the trailing columns are erased.
#
# Subtests 3 and 4 are skipped per-dataset if Python or scikit-learn is
# unavailable.

use strict;
use warnings;
use Test::More;
use List::Util qw(sum min max);
use File::Temp qw(tempfile);
use JSON::PP   ();

use Algorithm::Classifier::IsolationForest;

my $CLASS = 'Algorithm::Classifier::IsolationForest';

# Run the undef-handling battery against each backend: pure-Perl always, C
# when it compiled.  A missing C backend skips that arm rather than failing.
# sklearn is run only once (it is unaffected by which Perl backend scores).
my @BACKENDS = ( [ 'pure-perl' => 0 ] );
push @BACKENDS, [ 'C' => 1 ]
	if $Algorithm::Classifier::IsolationForest::HAS_C;

use constant PI => 3.14159265358979;

# -----------------------------------------------------------------------
# Helpers
# -----------------------------------------------------------------------
sub mean { @_ ? sum(@_) / @_ : 0 }

sub _assign_ranks {
	my @v   = @_;
	my @idx = sort { $v[$a] <=> $v[$b] } 0 .. $#v;
	my @r;
	$r[ $idx[$_] ] = $_ + 1 for 0 .. $#idx;
	return @r;
}

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 {

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

		note 'Python/sklearn script did not return usable output; cross-language subtests will be skipped';
	}
} else {
	note 'Python with scikit-learn not found; cross-language subtests will be skipped';
}

# -----------------------------------------------------------------------
# Per-dataset test battery
# -----------------------------------------------------------------------
sub run_dataset_tests {
	my ( $ds, $sk_scores, $use_c ) = @_;

	my $f = $CLASS->new(
		n_trees     => 100,
		sample_size => 256,
		seed        => 42,
		use_c       => $use_c
	);
	$f->fit( $ds->{train} );

	# ---- Subtest 1: score_samples bit-for-bit identity ----
	subtest 'Perl score_samples: undef columns give identical scores to explicit 0' => sub {
		my ( $s_undef, $s_zero );
		{
			local $SIG{__WARN__} = sub { };
			$s_undef = $f->score_samples( $ds->{undef_test} );
		}
		$s_zero = $f->score_samples( $ds->{zero_test} );

		is( scalar @$s_undef, scalar @$s_zero, 'same number of scores returned' );

		my $diffs = grep { $s_undef->[$_] != $s_zero->[$_] } 0 .. $#$s_undef;
		is( $diffs, 0, 'every score with undef columns is bit-for-bit identical to score with explicit 0' );
	}; ## end 'Perl score_samples: undef columns give identical scores to explicit 0' => sub

	# ---- Subtest 2: predict bit-for-bit identity ----
	subtest 'Perl predict: undef columns give identical labels to explicit 0' => sub {
		my ( $l_undef, $l_zero );
		{
			local $SIG{__WARN__} = sub { };
			$l_undef = $f->predict( $ds->{undef_test} );
		}
		$l_zero = $f->predict( $ds->{zero_test} );

		is( scalar @$l_undef, scalar @$l_zero, 'same number of labels returned' );

		my $diffs = grep { $l_undef->[$_] != $l_zero->[$_] } 0 .. $#$l_undef;
		is( $diffs, 0, 'every predict label with undef columns is identical to label with explicit 0' );
	}; ## end 'Perl predict: undef columns give identical labels to explicit 0' => sub

	return unless defined $sk_scores;

	# Perl scores for the same test points (undef → 0 coercion)
	my $perl_scores;
	{
		local $SIG{__WARN__} = sub { };
		$perl_scores = $f->score_samples( $ds->{undef_test} );
	}

	# ---- Subtest 3: Spearman rho between Perl and sklearn ----
	subtest 'Spearman rank correlation Perl(undef->0) vs sklearn(NaN->0) >= 0.90' => sub {
		my @neg_sk = map { -$_ } @$sk_scores;
		my $rho    = spearman_rho( $perl_scores, \@neg_sk );
		cmp_ok( $rho, '>=', 0.90, sprintf( 'Spearman rho(Perl, -sklearn) = %.4f (must be >= 0.90)', $rho ) );
	};

	# ---- Subtest 4: outliers still separated after column erasure ----
	subtest 'both agree: x-axis outliers still flagged after trailing columns erased' => sub {
		my $n_in  = $ds->{n_in_test};
		my $n_out = $ds->{n_out_test};

		my @perl_in  = @{$perl_scores}[ 0 .. $n_in - 1 ];
		my @perl_out = @{$perl_scores}[ $n_in .. $n_in + $n_out - 1 ];

		my $gap_min = $ds->{mean_gap_min};
		cmp_ok( mean(@perl_out), '>', mean(@perl_in) + $gap_min,
			sprintf( 'Perl: mean outlier score (undef cols) exceeds mean inlier score by at least %.3f', $gap_min )
		);
		cmp_ok( min(@perl_out), '>', max(@perl_in),
			'Perl: every x-axis outlier scores strictly higher than every inlier (undef cols)' );

		my @sk_in  = @{$sk_scores}[ 0 .. $n_in - 1 ];
		my @sk_out = @{$sk_scores}[ $n_in .. $n_in + $n_out - 1 ];

		cmp_ok( mean(@sk_out), '<', mean(@sk_in),
			'sklearn: mean outlier score (NaN cols) is lower (more anomalous) than mean inlier score' );
		cmp_ok( max(@sk_out), '<', min(@sk_in),
			'sklearn: every x-axis outlier scores strictly lower than every inlier (NaN cols)' );
	}; ## end 'both agree: x-axis outliers still flagged after trailing columns erased' => sub
} ## end sub run_dataset_tests

# -----------------------------------------------------------------------
# Run the battery for each dataset
# -----------------------------------------------------------------------
for my $be (@BACKENDS) {
	my ( $be_name, $USE_C ) = @$be;
	for my $ds (@datasets) {
		my $sk_scores = $sk_by_label && $sk_by_label->{ $ds->{label} };
		if ( defined $sk_scores
			&& !( ref $sk_scores eq 'ARRAY' && @$sk_scores == @{ $ds->{undef_test} } ) )
		{
			fail("sklearn output missing or wrong length for dataset '$ds->{label}'");
			$sk_scores = undef;
		}
		subtest "[$be_name] $ds->{label} ($ds->{n_feat} features)" => sub {
			run_dataset_tests( $ds, $sk_scores, $USE_C );
		};
	} ## end for my $ds (@datasets)
} ## end for my $be (@BACKENDS)

done_testing;