view release on metacpan or  search on metacpan

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

# 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;