view release on metacpan or  search on metacpan

t/37-majority-voting.t  view on Meta::CPAN

#!perl
# 37-majority-voting.t
#
# Exercises voting => 'majority' (Majority Voting Isolation Forest,
# MVIForest -- Chabchoub, Togbe, Boly & Chiky 2022):
#
#   * constructor validation of the voting knob
#   * score_samples returns the anomaly vote fraction: [0, 1], discrete
#     in steps of 1/n_trees, higher for obvious outliers
#   * predict labels are the majority of the per-tree votes, consistent
#     with the vote fractions, in both axis and extended mode
#   * score_predict_samples / score_predict_split agree with
#     score_samples + predict
#   * C-backed and pure-Perl paths produce identical votes and labels
#   * persistence: voting survives a to_json/from_json round trip, and
#     models saved before the knob existed load as 'mean'
#   * contamination learns a per-tree cutoff that flags roughly the
#     requested fraction of the training set (majority pivots are
#     quantized, so ties can shift the count to the nearest gap)
#   * a higher per-tree threshold never flags more points
#   * set_voting switches an existing model and recalibrates the
#     contamination threshold for the mode it was set to
#   * the tagged single-row helpers work under majority voting
#   * the CLI accepts --voting and stores it on the model

use strict;
use warnings;
use Test::More;
use File::Spec;

use Algorithm::Classifier::IsolationForest;

my $CLASS = 'Algorithm::Classifier::IsolationForest';
my $HAS_C = $Algorithm::Classifier::IsolationForest::HAS_C ? 1 : 0;

# Uniform cluster plus unmistakable outliers, as in 02-accel-selection.t.
srand(11);
my @data;
push @data, [ rand(), rand(), rand() ] for 1 .. 60;
push @data, [ 12, 12, 12 ], [ -11, -11, -11 ], [ 10, -10, 9 ];
my @outlier_idx = ( 60, 61, 62 );

subtest 'constructor validation' => sub {
	my $f = $CLASS->new( n_trees => 10, sample_size => 16 );
	is( $f->{voting}, 'mean', 'voting defaults to mean' );

	$f = $CLASS->new( n_trees => 10, sample_size => 16, voting => 'majority' );
	is( $f->{voting}, 'majority', 'voting => majority accepted' );

	eval { $CLASS->new( voting => 'plurality' ) };
	like( $@, qr/voting must be 'mean' or 'majority'/, 'invalid voting croaks' );
}; ## end 'constructor validation' => sub

for my $mode (qw(axis extended)) {
	subtest "majority scoring and prediction ($mode mode)" => sub {
		my $t = 50;
		my $f = $CLASS->new(
			n_trees     => $t,
			sample_size => 32,
			seed        => 7,
			mode        => $mode,
			voting      => 'majority',
		)->fit( \@data );

		my $scores = $f->score_samples( \@data );
		is( scalar @$scores, scalar @data, 'one score per sample' );

		my $bad = grep { !defined $_ || $_ < 0 || $_ > 1 } @$scores;
		is( $bad, 0, 'every vote fraction is in [0, 1]' );

		# Vote fractions are counts over $t trees; votes/t scaled back up
		# must land on an integer.
		my $offgrid = grep {
			my $v = $_ * $t;
			abs( $v - int( $v + 0.5 ) ) > 1e-9
		} @$scores;
		is( $offgrid, 0, "every score is a multiple of 1/$t" );

		my $labels = $f->predict( \@data );
		is( scalar @$labels, scalar @data, 'one label per sample' );

		# Labels must be the majority relation applied to the fractions:
		# anomalous iff votes >= int(t/2) + 1, i.e. fraction > 0.5.
		my $maj        = int( $t / 2 ) + 1;
		my $mismatches = grep {
			my $votes = int( $scores->[$_] * $t + 0.5 );
			( $votes >= $maj ? 1 : 0 ) != $labels->[$_]
		} 0 .. $#$labels;
		is( $mismatches, 0, 'labels equal the majority of the votes' );

		ok( ( grep { $labels->[$_] == 1 } @outlier_idx ) == @outlier_idx, 'all planted outliers are flagged' );

		# 0.5 is a weak per-tree bar (the paper recommends 0.6 as the
		# decision threshold), so allow some inlier false alarms at the
		# default and check the sharper separation at 0.6.
		my $inlier_flags = grep { $labels->[$_] } 0 .. 59;