view release on metacpan or  search on metacpan

lib/Algorithm/Classifier/IsolationForest.pm  view on Meta::CPAN

# afterwards.
#
# Example:
#   _heap_replace_root( \@heap, 0.9 ) if $score > $heap[0];
sub _heap_replace_root {
	my ( $h, $x ) = @_;
	$h->[0] = $x;
	my $n = scalar @$h;
	my $i = 0;
	while (1) {
		my $l = 2 * $i + 1;
		my $r = 2 * $i + 2;
		my $s = $i;
		$s = $l if $l < $n && $h->[$l] < $h->[$s];
		$s = $r if $r < $n && $h->[$r] < $h->[$s];
		last if $s == $i;
		@{$h}[ $s, $i ] = @{$h}[ $i, $s ];
		$i = $s;
	} ## end while (1)
	return;
} ## end sub _heap_replace_root

#-------------------------------------------------------------------------------
# Draw $k samples without replacement via a partial Fisher-Yates shuffle of the
# index array.
#
# Args:
#   $data :: the training set, an arrayref of feature-value arrayrefs.
#            Never modified.
#   $k :: how many samples to draw, an integer in [1, scalar @$data].
#
# Returns: an arrayref of $k row references.  The rows are SHARED with
# $data, not copied, so nothing downstream may mutate them -- _build_tree
# only ever reads.
#
# Example:
#   srand(42);
#   my $sample = _subsample( \@training_rows, 256 );
#   my $tree   = $self->_build_tree( $sample, 0, 8 );
#-------------------------------------------------------------------------------
sub _subsample {
	my ( $data, $k ) = @_;
	my $n   = scalar @$data;
	my @idx = ( 0 .. $n - 1 );
	for my $i ( 0 .. $k - 1 ) {
		my $j = $i + int( rand( $n - $i ) );
		@idx[ $i, $j ] = @idx[ $j, $i ];
	}
	my @chosen = @idx[ 0 .. $k - 1 ];
	return [ @{$data}[@chosen] ];
} ## end sub _subsample

#-------------------------------------------------------------------------------
# Recursively build one isolation tree.
#
# A node is one of:
#   leaf     { leaf => 1, size => N }
#   axis     { attr => A, split => S,            left => ..., right => ... }
#   oblique  { idx => [..], coef => [..], b => B, left => ..., right => ... }
#
# In both split styles the choice is restricted to features that actually vary
# across the points reaching the node: this avoids wasted levels on constant
# columns and lets a node leaf out exactly when its points are indistinguishable.
#
# Args:
#   $X :: the points reaching this node, an arrayref of feature-value
#         arrayrefs.  Read-only; undef cells only appear under
#         missing => 'nan'.
#   $depth :: this node's depth, 0 at the root.
#   $limit :: the height limit from _resolve_geometry.  At or past it the
#             node leafs out and c(size) covers the rest.
#
# Returns: the node as an arrayref in the layout above, with children
# already recursed into -- so calling it on the root returns the whole tree.
#
# Example:
#   my $tree = $self->_build_tree( _subsample( \@rows, 256 ), 0, 8 );
#   # [ 1, 2, 0.37, [ ... ], [ ... ] ] -- an axis split on feature 2
#-------------------------------------------------------------------------------
sub _build_tree {
	my ( $self, $X, $depth, $limit ) = @_;

	my $size = scalar @$X;
	return [ _NODE_LEAF, $size ]
		if $depth >= $limit || $size <= 1;

	my $nf  = $self->{n_features};
	my $nan = $self->{missing} eq 'nan';

	# Per-feature min and max within this node, in a single pass.  Missing
	# (undef) cells never reach here under die/zero/impute -- those fill the
	# data before fit -- so the "next unless defined" guard is only needed
	# in nan mode, where missing values must not constrain a feature's
	# range; every other strategy skips it since every cell is defined and
	# the check would never fire.
	my ( @lo, @hi );
	if ($nan) {
		for my $row (@$X) {
			for my $f ( 0 .. $nf - 1 ) {
				my $v = $row->[$f];
				next unless defined $v;
				$lo[$f] = $v if !defined $lo[$f] || $v < $lo[$f];
				$hi[$f] = $v if !defined $hi[$f] || $v > $hi[$f];
			}
		}
	} else {
		for my $row (@$X) {
			for my $f ( 0 .. $nf - 1 ) {
				my $v = $row->[$f];
				$lo[$f] = $v if !defined $lo[$f] || $v < $lo[$f];
				$hi[$f] = $v if !defined $hi[$f] || $v > $hi[$f];
			}
		}
	}

	# Features with spread are the only ones that can split the data.  A
	# feature whose values are all missing within this node has an undef
	# range and is excluded.
	my @varying = grep { defined $lo[$_] && $lo[$_] < $hi[$_] } 0 .. $nf - 1;

	# No spread on any feature => all points identical => cannot isolate.