view release on metacpan or  search on metacpan

t/34-missing-values.t  view on Meta::CPAN

				'<', 1e-9, "impute ($how) scores match densified fit" );
		}; ## end "[$be_name] impute mode ($how) learns fill and matches densified fit" => sub
	} ## end for my $how (qw(mean median))

	# -----------------------------------------------------------------------
	# impute: a feature column that's entirely undef has no statistic to
	# learn, and must croak -- on the first such column in feature order,
	# matching the pure-Perl fallback's message exactly. This exercises
	# the multi-column case (one good column, one entirely-undef column)
	# specifically: an earlier regression in the C fast path freed a
	# good column's scratch buffer once when computing its fill and then
	# again while cleaning up after discovering the later, entirely-undef
	# column -- a double free that only shows up with more than one
	# feature column, so a single-column case wouldn't have caught it.
	# -----------------------------------------------------------------------
	subtest "[$be_name] impute mode croaks on a feature with no present values" => sub {
		my @all_missing_second = map { [ $_->[0], undef ] } @holey;
		my $f                  = $CLASS->new(
			n_trees => 20,
			seed    => $SEED,
			missing => 'impute',
			use_c   => $USE_C
		);
		ok( !eval { $f->fit( \@all_missing_second ); 1 }, 'fit croaks when a feature column is entirely undef' );
		like( $@, qr/impute: feature column 1 has no present values/, 'names the offending column' );

		my @all_missing_first = map { [ undef, $_->[1] ] } @holey;
		my $g                 = $CLASS->new(
			n_trees => 20,
			seed    => $SEED,
			missing => 'impute',
			use_c   => $USE_C
		);
		ok( !eval { $g->fit( \@all_missing_first ); 1 },
			'fit croaks when the first feature column is entirely undef' );
		like( $@, qr/impute: feature column 0 has no present values/, 'names the offending column' );
	}; ## end "[$be_name] impute mode croaks on a feature with no present values" => sub

	# -----------------------------------------------------------------------
	# Persistence: every strategy round-trips, and impute carries its fill
	# -----------------------------------------------------------------------
	subtest "[$be_name] save/load round-trips each strategy" => sub {
		for my $cfg ( [ zero => {} ], [ impute => { impute_with => 'median' } ], [ nan => {} ], ) {
			my ( $strategy, $extra ) = @$cfg;
			my $f = $CLASS->new(
				n_trees => 60,
				seed    => $SEED,
				missing => $strategy,
				use_c   => $USE_C,
				%$extra,
			);
			$f->fit( \@holey );
			my $reloaded = $CLASS->from_json( $f->to_json );

			is( $reloaded->{missing}, $strategy, "$strategy: missing restored" );
			if ( $strategy eq 'impute' ) {
				is_deeply( $reloaded->{missing_fill}, $f->{missing_fill}, 'impute: fill vector restored' );
			}

			cmp_ok( _max_abs_diff( $f->score_samples( \@test ), $reloaded->score_samples( \@test ) ),
				'<', 1e-9, "$strategy: reloaded scores match original" );
		} ## end for my $cfg ( [ zero => {} ], [ impute => {...}])
	}; ## end "[$be_name] save/load round-trips each strategy" => sub

	# -----------------------------------------------------------------------
	# Old models (no `missing` key) load as zero and keep undef -> 0 scoring
	# -----------------------------------------------------------------------
	subtest "[$be_name] pre-missing models default to zero on load" => sub {
		my $f    = $CLASS->new( n_trees => 40, seed => $SEED, use_c => $USE_C )->fit( \@clean );
		my $json = $f->to_json;

		# Strip the missing-value keys to mimic a model saved by an older release.
		$json =~ s/"missing"\s*:\s*"[^"]*"\s*,?//;
		$json =~ s/"impute_with"\s*:\s*"[^"]*"\s*,?//;
		$json =~ s/"missing_fill"\s*:\s*(?:null|\[[^\]]*\])\s*,?//;

		my $reloaded = $CLASS->from_json($json);
		is( $reloaded->{missing}, 'zero', 'legacy model loads as zero' );
		ok( eval { $reloaded->score_samples( \@test ); 1 }, 'legacy model scores undef rows' );
	}; ## end "[$be_name] pre-missing models default to zero on load" => sub
} ## end for my $be (@BACKENDS)

# ---------------------------------------------------------------------------
# nan: the C and pure-Perl backends must route missing values identically.
# Only meaningful when the C backend compiled; otherwise we still confirm the
# pure-Perl path fits and scores without error.
# ---------------------------------------------------------------------------
for my $mode (qw(axis extended)) {
	subtest "nan mode ($mode): C and pure-Perl scores agree" => sub {
		my $p = $CLASS->new(
			n_trees => 80,
			seed    => $SEED,
			missing => 'nan',
			mode    => $mode,
			use_c   => 0,
		);
		my @w = _warnings( sub { $p->fit( \@holey ) } );
		is( scalar @w, 0, 'nan-mode fit emits no warnings' );
		ok( !$p->{_use_c}, 'pure-Perl model does not use the C backend' );

		my $sp = $p->score_samples( \@test );
		is( scalar @$sp, scalar @test, 'pure-Perl nan scoring returns a score per row' );

	SKIP: {
			skip 'C backend not built', 2 unless $HAS_C;

			my $c = $CLASS->new(
				n_trees => 80,
				seed    => $SEED,
				missing => 'nan',
				mode    => $mode,
				use_c   => 1,
			);
			$c->fit( \@holey );
			ok( $c->{_use_c}, 'C model uses the C backend' );

			cmp_ok( _max_abs_diff( $c->score_samples( \@test ), $sp ),
				'<', 1e-9, 'C and Perl nan-mode scores agree' );
		} ## end SKIP:
	}; ## end "nan mode ($mode): C and pure-Perl scores agree" => sub
} ## end for my $mode (qw(axis extended))