File Coverage

blib/lib/Algorithm/Classifier/IsolationForest.pm
Criterion Covered Total %
statement 724 774 93.5
branch 277 336 82.4
condition 156 214 72.9
subroutine 65 67 97.0
pod 19 19 100.0
total 1241 1410 88.0


line stmt bran cond sub pod time code
1             package Algorithm::Classifier::IsolationForest;
2              
3 57     57   2490334 use strict;
  57         104  
  57         1756  
4 57     57   229 use warnings;
  57         117  
  57         2454  
5 57     57   263 use Carp qw(croak);
  57         108  
  57         2783  
6 57     57   278 use Config ();
  57         192  
  57         1328  
7 57     57   285 use List::Util qw(min);
  57         109  
  57         4776  
8 57     57   25295 use POSIX qw(ceil);
  57         345705  
  57         284  
9 57     57   89311 use JSON::PP ();
  57         442297  
  57         1417  
10 57     57   27216 use File::Slurp qw(read_file write_file);
  57         1052072  
  57         4739  
11              
12             our $VERSION = '0.5.0';
13              
14 57     57   383 use constant EULER => 0.5772156649015329;
  57         113  
  57         3925  
15              
16             # Narrowed to C double precision so _randn() multiplies by the exact
17             # constant _c_randn() uses. A no-op on nvsize == 8 perls.
18 57     57   250 use constant TWO_PI => unpack( 'd', pack 'd', 6.283185307179586 );
  57         97  
  57         2505  
19              
20             # Node-type tags stored in index 0 of every tree node arrayref.
21             # 0 is falsy, so while ($node->[0]) acts as while (!leaf).
22 57     57   235 use constant _NODE_LEAF => 0;
  57         89  
  57         1815  
23 57     57   238 use constant _NODE_AXIS => 1;
  57         79  
  57         1662  
24 57     57   201 use constant _NODE_OBLIQUE => 2;
  57         93  
  57         2667  
25              
26             # The Inline::C tree builder computes everything in C doubles. On a perl
27             # whose NV is wider than a double (-Duselongdouble / -Dusequadmath) the
28             # pure-Perl builder keeps extra low bits at every step, so the two
29             # backends would stop producing bit-identical trees for the same seed
30             # (the parity t/03-fit-determinism.t checks). _NV_IS_DOUBLE guards
31             # narrowing statements wherever the pure-Perl builder computes a value
32             # that gets STORED in a tree (split points, hyperplane coefficients and
33             # offsets, impute fills), rounding at the same points the C builder
34             # rounds. It is compile-time true on nvsize == 8 perls, so there the
35             # guarded statements are optimised away and cost nothing.
36             #
37             # The row-partition loops (v < split, dot <= b) are deliberately NOT
38             # narrowed: with both operands already double-exact an axis comparison
39             # is identical anyway, and an oblique dot product accumulated in a wider
40             # NV flips a comparison only when |dot - b| falls inside the NV-vs-double
41             # rounding gap (~1e-19 relative) -- negligible, and those are the hot
42             # loops.
43 57     57   257 use constant _NV_IS_DOUBLE => $Config::Config{nvsize} == 8;
  57         118  
  57         614342  
44              
45             # Round an NV to C double precision. Only ever reached on wide-NV
46             # perls -- see _NV_IS_DOUBLE.
47 0     0   0 sub _to_double { unpack 'd', pack 'd', $_[0] }
48              
49             # ---------------------------------------------------------------------------
50             # Optional Inline::C accelerator for the scoring hot path.
51             #
52             # pack_input_xs(data_sv, out_sv, n_pts, n_feats, miss_mode, fill_sv)
53             # Walks the Perl arrayref-of-arrayrefs and writes a packed double buffer
54             # into out_sv. Replaces the dominant per-call Perl map-pack loop.
55             # miss_mode selects how an undef cell is packed: 0 => 0.0, 1 => the
56             # per-feature fill from fill_sv (impute), 2 => NaN (nan strategy).
57             #
58             # score_all_xs(nodes_av, idx_av, val_av, x_sv, sm_sv,
59             # n_pts, n_feats, n_trees, use_openmp)
60             # Sums path lengths for all n_pts query points across all n_trees trees
61             # in one call. Outer loop over points is OpenMP-parallel when the
62             # module was built with OpenMP (each iteration writes to a unique sm[i],
63             # so no synchronisation is needed). Tree pointers are extracted from
64             # the AVs before the parallel region; the parallel region touches only
65             # raw int / double buffers.
66             #
67             # vote_all_xs(nodes_av, idx_av, val_av, x_sv, sm_sv,
68             # n_pts, n_feats, n_trees, depth_cut, min_votes, use_openmp)
69             # Majority-voting (voting => 'majority') counterpart of score_all_xs:
70             # instead of summing path lengths it counts, per point, how many trees
71             # "vote anomalous" (path length <= depth_cut). min_votes == 0 writes
72             # the full vote count into sm[i]; min_votes > 0 writes a 0.0/1.0 label
73             # with per-point early exit once the majority outcome is decided --
74             # the MVIForest scoring loop. See the function's own comment.
75             #
76             # Node layout (6 doubles per node, "IF_NZ = 6"):
77             # leaf: [0, size, c(size), 0, 0, 0]
78             # axis: [1, attr, split, li, ri, 0]
79             # oblique: [2, coff, nf, li, ri, b]
80             #
81             # c(size) is the expected-path-length adjustment for a leaf holding
82             # `size` points, precomputed by _pack_tree (it involves a log(); doing
83             # it at pack time keeps transcendentals out of the per-point per-tree
84             # scoring loop). The fit-time TreeBuf writer leaves that slot 0 --
85             # its buffers are unpacked into Perl trees and re-packed by
86             # _pack_tree before score_all_xs ever sees them.
87             #
88             # Coefficient storage uses a Structure-of-Arrays layout: one int32 array
89             # per tree (feature indices, packed with 'l*') and one double array per
90             # tree (coefficients, packed with 'd*'). Both are indexed by `coff` --
91             # the same offset addresses paired entries in the two arrays. Splitting
92             # them this way halves index bandwidth, removes the per-element
93             # (int) cast inside the SIMD loop, and lets the value loads be
94             # contiguous so the compiler emits a clean FMA chain over val[k] with
95             # the feature gather on xi[idx[k]] kept separate.
96             #
97             # Dense-pack fast path: when an oblique node uses every feature (the
98             # common case in extended mode with extension_level == n_features - 1),
99             # _pack_tree writes its coefficients in feature order so val[k] is the
100             # coefficient for feature k. score_all_xs detects this via `nf ==
101             # n_feats` and uses a no-gather dot product (dot += val[k] * xi[k])
102             # that vectorizes cleanly with FMA -- substantially faster than the
103             # sparse gather path on high-feature-count models.
104             # x: row-major doubles, n_pts rows of n_feats each.
105             # sums: out double array of length n_pts; score_all_xs writes once per i.
106             #
107             # OpenMP is enabled at module load when the toolchain accepts -fopenmp and
108             # libgomp is linkable; otherwise the same C code compiles to a serial loop
109             # (the #pragma is silently ignored without _OPENMP defined).
110             # ---------------------------------------------------------------------------
111             our $HAS_C = 0;
112             our $HAS_OPENMP = 0;
113             our $HAS_SIMD = 0;
114             our $OPT_LEVEL = ''; # the actual -O.../-march=... flags used to build, if any
115             our $C_SOURCE = ''; # 'prebuilt' (object installed at `make` time) or
116             # 'runtime' (compiled at first load into _Inline/);
117             # '' when $HAS_C is 0
118             {
119             my $C_CODE = <<'__INLINE_C__';
120             #include
121             #include
122             #include
123             #ifdef _OPENMP
124             #include
125             #endif
126             #define IF_NZ 6
127              
128             /* Data prefetch hint; a no-op on compilers without __builtin_prefetch.
129             * Purely a performance hint -- never affects results. */
130             #if defined(__GNUC__) || defined(__clang__)
131             #define IF_PREFETCH(p) __builtin_prefetch(p)
132             #else
133             #define IF_PREFETCH(p)
134             #endif
135              
136             int has_openmp_xs(){
137             #ifdef _OPENMP
138             return 1;
139             #else
140             return 0;
141             #endif
142             }
143              
144             /* SIMD on the extended-mode oblique dot product is enabled via
145             * `#pragma omp simd`, which OpenMP 4.0 (_OPENMP == 201307) introduced.
146             * Anything older silently ignores the pragma -- the loop still runs,
147             * just not auto-vectorised. So "simd available" really means the
148             * compiler is going to honour the pragma we put on that loop. */
149             int has_simd_xs(){
150             #if defined(_OPENMP) && _OPENMP >= 201307
151             return 1;
152             #else
153             return 0;
154             #endif
155             }
156              
157             /* pack_input_xs(data_sv, out_sv, n_pts, n_feats, miss_mode, fill_sv)
158             *
159             * Walks a Perl arrayref-of-arrayrefs (n_pts rows of n_feats doubles each)
160             * directly in C and writes the packed double buffer into out_sv (which the
161             * caller pre-allocates with "\0" x (n_pts*n_feats*8)). Replaces
162             *
163             * pack('d*', map { my $r=$_; map { $r->[$_] // 0 } 0..$nf-1 } @$data)
164             *
165             * which was the dominant per-call overhead for high feature counts.
166             *
167             * miss_mode selects what an undef cell (or missing row) becomes:
168             * 0 => 0.0 (the 'die'/'zero' missing strategies)
169             * 1 => fill[k] (the 'impute' strategy; fill_sv is a packed
170             * double buffer of n_feats per-feature fill values)
171             * 2 => NaN (the 'nan' strategy; the C scorer's `<` / `<=`
172             * comparisons are both false for NaN, so a point
173             * missing the split feature falls to the right
174             * child -- matching how fit() routes it)
175             * fill_sv is only dereferenced when miss_mode == 1. */
176             void pack_input_xs(SV* data_sv, SV* out_sv, int n_pts, int n_feats,
177             int miss_mode, SV* fill_sv){
178             STRLEN tl;
179             double* out;
180             const double* fill = NULL;
181             double missval;
182             AV* outer;
183             int i, k;
184              
185             if (!SvROK(data_sv) || SvTYPE(SvRV(data_sv)) != SVt_PVAV) {
186             croak("pack_input_xs: data must be an arrayref");
187             }
188             outer = (AV*)SvRV(data_sv);
189             out = (double*)SvPVbyte_force(out_sv, tl);
190              
191             if (miss_mode == 1) {
192             STRLEN fl;
193             fill = (const double*)SvPVbyte(fill_sv, fl);
194             }
195             missval = (miss_mode == 2) ? NAN : 0.0;
196              
197             for (i = 0; i < n_pts; i++) {
198             SV** row_pp = av_fetch(outer, i, 0);
199             double* dst = out + (size_t)i * (size_t)n_feats;
200             if (!row_pp || !*row_pp || !SvROK(*row_pp) ||
201             SvTYPE(SvRV(*row_pp)) != SVt_PVAV) {
202             for (k = 0; k < n_feats; k++)
203             dst[k] = (miss_mode == 1) ? fill[k] : missval;
204             continue;
205             }
206             {
207             AV* row = (AV*)SvRV(*row_pp);
208             for (k = 0; k < n_feats; k++) {
209             SV** v = av_fetch(row, k, 0);
210             if (v && *v && SvOK(*v)) {
211             dst[k] = SvNV(*v);
212             } else {
213             dst[k] = (miss_mode == 1) ? fill[k] : missval;
214             }
215             }
216             }
217             }
218             }
219              
220             /* finalize_scores_xs(sm_sv, n_pts, inv, out_rv)
221             *
222             * Fills the pre-allocated arrayref out_rv with exp(-sm[i] * inv) for
223             * i in 0..n_pts-1. Replaces the trailing
224             *
225             * my @sums = unpack('d*', $sums_packed);
226             * return [ map { exp(-$_ * $inv) } @sums ];
227             *
228             * which allocated ~2*n_pts intermediate Perl SVs per scoring call. */
229             void finalize_scores_xs(SV* sm_sv, int n_pts, double inv, SV* out_rv){
230             STRLEN tl;
231             const double* sm;
232             AV* out;
233             int i;
234              
235             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
236             croak("finalize_scores_xs: out must be an arrayref");
237             }
238             sm = (const double*)SvPVbyte(sm_sv, tl);
239             out = (AV*)SvRV(out_rv);
240             av_clear(out);
241             if (n_pts > 0) av_extend(out, n_pts - 1);
242             for (i = 0; i < n_pts; i++) {
243             av_store(out, i, newSVnv(exp(-sm[i] * inv)));
244             }
245             }
246              
247             /* finalize_path_lengths_xs(sm_sv, n_pts, t, out_rv)
248             *
249             * Same idea as finalize_scores_xs but writes sm[i] / t (the average path
250             * length across n_trees=t trees) instead of the exp normalisation. */
251             void finalize_path_lengths_xs(SV* sm_sv, int n_pts, double t, SV* out_rv){
252             STRLEN tl;
253             const double* sm;
254             AV* out;
255             int i;
256              
257             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
258             croak("finalize_path_lengths_xs: out must be an arrayref");
259             }
260             sm = (const double*)SvPVbyte(sm_sv, tl);
261             out = (AV*)SvRV(out_rv);
262             av_clear(out);
263             if (n_pts > 0) av_extend(out, n_pts - 1);
264             for (i = 0; i < n_pts; i++) {
265             av_store(out, i, newSVnv(sm[i] / t));
266             }
267             }
268              
269             /* predict_sums_xs(sm_sv, n_pts, sum_threshold, out_rv)
270             *
271             * Fills out_rv with 0/1 IVs based on sm[i] <= sum_threshold. The caller
272             * pre-computes sum_threshold = -log(score_threshold) * c * n_trees / log(2),
273             * so this skips both the per-point exp() and the intermediate scores
274             * arrayref that the old "score_samples + map threshold" path created. */
275             void predict_sums_xs(SV* sm_sv, int n_pts, double sum_threshold, SV* out_rv){
276             STRLEN tl;
277             const double* sm;
278             AV* out;
279             int i;
280              
281             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
282             croak("predict_sums_xs: out must be an arrayref");
283             }
284             sm = (const double*)SvPVbyte(sm_sv, tl);
285             out = (AV*)SvRV(out_rv);
286             av_clear(out);
287             if (n_pts > 0) av_extend(out, n_pts - 1);
288             for (i = 0; i < n_pts; i++) {
289             av_store(out, i, newSViv(sm[i] <= sum_threshold ? 1 : 0));
290             }
291             }
292              
293             /* score_predict_xs(sm_sv, n_pts, inv, sum_threshold, out_rv)
294             *
295             * Combines finalize_scores_xs + predict_sums_xs: fills the pre-allocated
296             * out_rv with [score, label] pairs in one pass over sm_sv. Replaces the
297             * trailing Perl loop in score_predict_samples that built ~3*n_pts SVs
298             * (n_pts scores + n_pts labels + n_pts inner arrayrefs) via a Perl
299             * foreach -- here the same SVs are allocated directly inside C.
300             *
301             * Refcount note: newRV_noinc takes ownership of the inner AV without
302             * incrementing it, and av_store takes ownership of the RV. When the
303             * outer AV is destroyed it frees the RVs, which free the inner AVs,
304             * which free the score/label SVs. No leak. */
305             void score_predict_xs(SV* sm_sv, int n_pts, double inv,
306             double sum_threshold, SV* out_rv){
307             STRLEN tl;
308             const double* sm;
309             AV* out;
310             int i;
311              
312             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
313             croak("score_predict_xs: out must be an arrayref");
314             }
315             sm = (const double*)SvPVbyte(sm_sv, tl);
316             out = (AV*)SvRV(out_rv);
317             av_clear(out);
318             if (n_pts > 0) av_extend(out, n_pts - 1);
319             for (i = 0; i < n_pts; i++) {
320             AV* row = newAV();
321             av_extend(row, 1);
322             /* av_extend filled both slots with &PL_sv_undef. Since that
323             * sentinel is immortal (its refcount is never freed) we can
324             * overwrite the slots directly and bump AvFILLp, skipping the
325             * per-element bounds/magic checks av_store would do. */
326             AvARRAY(row)[0] = newSVnv(exp(-sm[i] * inv));
327             AvARRAY(row)[1] = newSViv(sm[i] <= sum_threshold ? 1 : 0);
328             AvFILLp(row) = 1;
329             av_store(out, i, newRV_noinc((SV*)row));
330             }
331             }
332              
333             /* score_predict_split_xs(sm_sv, n_pts, inv, sum_threshold,
334             * scores_rv, labels_rv)
335             *
336             * Parallel-arrays variant of score_predict_xs: fills two pre-allocated
337             * arrayrefs (scores: NV, labels: IV) instead of an AV-of-[score, label]
338             * pairs. Allocates ~2*n_pts SVs instead of ~4*n_pts -- no inner AV and
339             * no RV per point -- so it's about twice as cheap for callers that
340             * don't need the paired shape. */
341             void score_predict_split_xs(SV* sm_sv, int n_pts, double inv,
342             double sum_threshold,
343             SV* scores_rv, SV* labels_rv){
344             STRLEN tl;
345             const double* sm;
346             AV* scores;
347             AV* labels;
348             int i;
349              
350             if (!SvROK(scores_rv) || SvTYPE(SvRV(scores_rv)) != SVt_PVAV ||
351             !SvROK(labels_rv) || SvTYPE(SvRV(labels_rv)) != SVt_PVAV) {
352             croak("score_predict_split_xs: scores/labels must be arrayrefs");
353             }
354             sm = (const double*)SvPVbyte(sm_sv, tl);
355             scores = (AV*)SvRV(scores_rv);
356             labels = (AV*)SvRV(labels_rv);
357             av_clear(scores);
358             av_clear(labels);
359             if (n_pts > 0) {
360             av_extend(scores, n_pts - 1);
361             av_extend(labels, n_pts - 1);
362             }
363             for (i = 0; i < n_pts; i++) {
364             av_store(scores, i, newSVnv(exp(-sm[i] * inv)));
365             av_store(labels, i, newSViv(sm[i] <= sum_threshold ? 1 : 0));
366             }
367             }
368              
369             /* Walk one point through one tree; returns the path length (depth plus
370             * the precomputed c(leaf size) adjustment from the leaf record).
371             *
372             * Invariant: every feature index stored in a tree node is in
373             * [0, n_feats). fit() builds trees against n_features columns and
374             * pack_input_xs writes exactly that many doubles per row, and
375             * _resolve_input rejects PackedData with a mismatched feature count.
376             * So the loop can omit per-iteration bounds checks on attr / fi --
377             * this is what lets the oblique dot product vectorize cleanly under
378             * the omp-simd reductions below. */
379             #if defined(__GNUC__) || defined(__clang__)
380             __attribute__((always_inline))
381             #endif
382             static inline double if_walk_tree(const double *nd, const int *ico,
383             const double *vco, const double *xi,
384             int n_feats) {
385             int ni = 0, depth = 0;
386             for (;;) {
387             const double *node = nd + (size_t)ni * IF_NZ;
388             int type = (int)node[0];
389             if (type == 0) {
390             /* node[2] is c(leaf size), precomputed by _pack_tree; a
391             * log() here would otherwise run once per point per tree. */
392             return depth + node[2];
393             }
394             if (type == 1) {
395             double fv = xi[(int)node[1]];
396             ni = (fv < node[2]) ? (int)node[3] : (int)node[4];
397             } else {
398             int coff = (int)node[1], nf = (int)node[2];
399             double b = node[5], dot = 0.0;
400             const double *val_p = vco + (size_t)coff;
401              
402             /* Both children are known before the dot product resolves
403             * which one gets taken, so start pulling their records in
404             * now and let the FMA loop below hide the latency. One of
405             * the two prefetches is always wasted -- affordable here
406             * on the oblique path, where there is real work to hide it
407             * under, but not on the axis path, whose single compare
408             * resolves immediately. */
409             const int li = (int)node[3], ri = (int)node[4];
410             IF_PREFETCH(nd + (size_t)li * IF_NZ);
411             IF_PREFETCH(nd + (size_t)ri * IF_NZ);
412             if (nf == n_feats) {
413             /* Dense oblique split: this node uses every feature,
414             * so _pack_tree laid the coefficients out in feature
415             * order. No gather -- the inner loop is a textbook
416             * FMA-vectorizable dot product over two contiguous
417             * double streams. Common case in extended mode at
418             * the default extension_level (== n_feats-1). */
419             #ifdef _OPENMP
420             #pragma omp simd reduction(+:dot)
421             #endif
422             for (int k = 0; k < n_feats; k++) {
423             dot += val_p[k] * xi[k];
424             }
425             } else {
426             /* Sparse oblique split: only nf < n_feats features
427             * participate, so we still need the gather on
428             * xi[idx_p[k]]. Storing idx as contiguous int32
429             * (rather than interleaved doubles) keeps the gather
430             * pattern clean and the val[] load contiguous. */
431             const int *idx_p = ico + (size_t)coff;
432             #ifdef _OPENMP
433             #pragma omp simd reduction(+:dot)
434             #endif
435             for (int k = 0; k < nf; k++) {
436             dot += val_p[k] * xi[idx_p[k]];
437             }
438             }
439             ni = (dot <= b) ? li : ri;
440             }
441             depth++;
442             }
443             }
444              
445             /* score_all_xs(nodes_av, idx_av, val_av, x_sv, sm_sv,
446             * n_pts, n_feats, n_trees, use_openmp)
447             *
448             * Scores all points across all trees in one C call. See header comment
449             * above for the bigger picture. Writes sm[i] = sum_over_trees(path_len);
450             * the caller need not zero-init sm.
451             *
452             * idx_av holds per-tree packed int32 buffers of feature indices and
453             * val_av holds per-tree packed double buffers of coefficients (the SoA
454             * counterpart of the old interleaved layout). See the file-top
455             * comment for the rationale.
456             *
457             * Thread-safety: the parallel region only reads node/idx/val/x pointers
458             * (extracted before the region) and writes sm[i] for a unique i per
459             * iteration. No Perl API is called from inside the parallel region. */
460             void score_all_xs(SV* nodes_av_sv, SV* idx_av_sv, SV* val_av_sv,
461             SV* x_sv, SV* sm_sv,
462             int n_pts, int n_feats, int n_trees,
463             int use_openmp){
464             STRLEN tl;
465             AV *nodes_av, *idx_av, *val_av;
466             const double *xd;
467             double *sm;
468             int ti;
469              
470             if (!SvROK(nodes_av_sv) || SvTYPE(SvRV(nodes_av_sv)) != SVt_PVAV ||
471             !SvROK(idx_av_sv) || SvTYPE(SvRV(idx_av_sv)) != SVt_PVAV ||
472             !SvROK(val_av_sv) || SvTYPE(SvRV(val_av_sv)) != SVt_PVAV) {
473             croak("score_all_xs: nodes/idx/val must be arrayrefs");
474             }
475             nodes_av = (AV*)SvRV(nodes_av_sv);
476             idx_av = (AV*)SvRV(idx_av_sv);
477             val_av = (AV*)SvRV(val_av_sv);
478              
479             /* C99 VLAs -- n_trees is small (typ. 100) and fits on the stack. */
480             const double *node_ptrs[n_trees];
481             const int *idx_ptrs[n_trees];
482             const double *val_ptrs[n_trees];
483              
484             /* forest_bytes totals every buffer the tree walks touch; it decides
485             * between the two loop shapes below. */
486             size_t forest_bytes = 0;
487             for (ti = 0; ti < n_trees; ti++) {
488             SV** np = av_fetch(nodes_av, ti, 0);
489             SV** ip = av_fetch(idx_av, ti, 0);
490             SV** vp = av_fetch(val_av, ti, 0);
491             if (!np || !*np || !ip || !*ip || !vp || !*vp) {
492             croak("score_all_xs: missing tree %d", ti);
493             }
494             node_ptrs[ti] = (const double*)SvPVbyte(*np, tl); forest_bytes += tl;
495             idx_ptrs[ti] = (const int*) SvPVbyte(*ip, tl); forest_bytes += tl;
496             val_ptrs[ti] = (const double*)SvPVbyte(*vp, tl); forest_bytes += tl;
497             }
498              
499             xd = (const double*)SvPVbyte(x_sv, tl);
500             sm = (double*)SvPVbyte_force(sm_sv, tl);
501              
502             /* Two loop shapes over the same per-point ascending-t additions --
503             * bit-identical results either way, so the size heuristic choosing
504             * between them can never change scores.
505             *
506             * Point-major (small forests): each point walks all trees with its
507             * path-length sum held in a register. Cheapest per walk, and the
508             * whole forest stays cache-resident across points anyway.
509             *
510             * Tree-blocked (large forests): once the forest outgrows L3, the
511             * point-major loop re-streams every tree's nodes and coefficients
512             * from memory for every point -- an extended-mode tree is ~56 KB
513             * at 16 features (24 KB nodes + 32 KB dense coefficients), and its
514             * per-tree scoring cost measured 2.2x worse at 400 trees than at
515             * 100. Walking a block of points through ONE tree at a time keeps
516             * that tree hot in L1/L2 while the block's rows stream through it
517             * (measured 3.1x faster at 400 extended trees, 20k points). The
518             * blocked shape pays an sm[i] load+store per walk instead of a
519             * register add, which measurably hurts cheap axis walks while the
520             * forest still fits in cache -- hence the byte threshold rather
521             * than always tiling. */
522             if (forest_bytes <= (size_t)4 * 1024 * 1024) {
523             #ifdef _OPENMP
524             #pragma omp parallel for schedule(static) if(use_openmp)
525             #endif
526             for (int i = 0; i < n_pts; i++) {
527             const double *xi = xd + (size_t)i * (size_t)n_feats;
528             double sum = 0.0;
529             for (int t = 0; t < n_trees; t++) {
530             sum += if_walk_tree(node_ptrs[t], idx_ptrs[t],
531             val_ptrs[t], xi, n_feats);
532             }
533             sm[i] = sum;
534             }
535             }
536             else {
537             /* 256 rows x 16 features x 8 bytes = 32 KB of input per block
538             * -- comfortable in L2 next to one tree. Each OpenMP thread
539             * owns whole blocks and therefore a unique slice of sm[], so
540             * there is still no synchronisation. For small batches the
541             * tile shrinks to keep ~4 blocks per thread available; losing
542             * per-block tree reuse there is fine, since a small batch
543             * never re-streams much anyway. */
544             int tile = 256;
545             #ifdef _OPENMP
546             if (use_openmp) {
547             int min_blocks = omp_get_max_threads() * 4;
548             if (min_blocks > 0 && (n_pts + tile - 1) / tile < min_blocks) {
549             tile = (n_pts + min_blocks - 1) / min_blocks;
550             if (tile < 1) tile = 1;
551             }
552             }
553             #endif
554             int n_blocks = (n_pts + tile - 1) / tile;
555              
556             #ifdef _OPENMP
557             #pragma omp parallel for schedule(static) if(use_openmp)
558             #endif
559             for (int blk = 0; blk < n_blocks; blk++) {
560             const int i0 = blk * tile;
561             const int i1 = (i0 + tile < n_pts) ? i0 + tile : n_pts;
562             for (int i = i0; i < i1; i++) sm[i] = 0.0;
563             for (int t = 0; t < n_trees; t++) {
564             const double *nd = node_ptrs[t];
565             const int *ico = idx_ptrs[t];
566             const double *vco = val_ptrs[t];
567             for (int i = i0; i < i1; i++) {
568             sm[i] += if_walk_tree(nd, ico, vco,
569             xd + (size_t)i * (size_t)n_feats,
570             n_feats);
571             }
572             }
573             }
574             }
575             }
576              
577             /* vote_all_xs(nodes_av, idx_av, val_av, x_sv, sm_sv,
578             * n_pts, n_feats, n_trees, depth_cut, min_votes, use_openmp)
579             *
580             * Majority-voting (MVIForest) tree walk: a tree votes a point anomalous
581             * when the point's path length in that tree is <= depth_cut -- the
582             * depth-domain image of the per-tree score cutoff (the Perl side
583             * precomputes depth_cut = -c(psi) * log2(threshold), so no per-tree
584             * exp()/log() runs in here).
585             *
586             * min_votes == 0: sm[i] = the point's full vote count over all n_trees
587             * trees (a small integer stored as a double, so the existing
588             * finalize_* helpers work on the buffer unchanged).
589             * min_votes > 0: sm[i] = 1.0/0.0 anomaly label, with per-point early
590             * exit: the walk stops as soon as the point has min_votes votes (the
591             * remaining trees can't change the outcome) or can no longer reach
592             * min_votes. This is MVIForest's "stop at majority" scoring loop.
593             *
594             * Always point-major, unlike score_all_xs's two loop shapes: the vote
595             * count / early exit is per-point state, so a tree-blocked loop would
596             * have to re-load it per walk and could never exit a point early.
597             * Votes are integer counts, so there is no summation-order concern
598             * either way. Thread-safety matches score_all_xs: the parallel region
599             * reads extracted pointers and writes a unique sm[i] per iteration. */
600             void vote_all_xs(SV* nodes_av_sv, SV* idx_av_sv, SV* val_av_sv,
601             SV* x_sv, SV* sm_sv,
602             int n_pts, int n_feats, int n_trees,
603             double depth_cut, int min_votes, int use_openmp){
604             STRLEN tl;
605             AV *nodes_av, *idx_av, *val_av;
606             const double *xd;
607             double *sm;
608             int ti;
609              
610             if (!SvROK(nodes_av_sv) || SvTYPE(SvRV(nodes_av_sv)) != SVt_PVAV ||
611             !SvROK(idx_av_sv) || SvTYPE(SvRV(idx_av_sv)) != SVt_PVAV ||
612             !SvROK(val_av_sv) || SvTYPE(SvRV(val_av_sv)) != SVt_PVAV) {
613             croak("vote_all_xs: nodes/idx/val must be arrayrefs");
614             }
615             nodes_av = (AV*)SvRV(nodes_av_sv);
616             idx_av = (AV*)SvRV(idx_av_sv);
617             val_av = (AV*)SvRV(val_av_sv);
618              
619             const double *node_ptrs[n_trees];
620             const int *idx_ptrs[n_trees];
621             const double *val_ptrs[n_trees];
622              
623             for (ti = 0; ti < n_trees; ti++) {
624             SV** np = av_fetch(nodes_av, ti, 0);
625             SV** ip = av_fetch(idx_av, ti, 0);
626             SV** vp = av_fetch(val_av, ti, 0);
627             if (!np || !*np || !ip || !*ip || !vp || !*vp) {
628             croak("vote_all_xs: missing tree %d", ti);
629             }
630             node_ptrs[ti] = (const double*)SvPVbyte(*np, tl);
631             idx_ptrs[ti] = (const int*) SvPVbyte(*ip, tl);
632             val_ptrs[ti] = (const double*)SvPVbyte(*vp, tl);
633             }
634              
635             xd = (const double*)SvPVbyte(x_sv, tl);
636             sm = (double*)SvPVbyte_force(sm_sv, tl);
637              
638             #ifdef _OPENMP
639             #pragma omp parallel for schedule(static) if(use_openmp)
640             #endif
641             for (int i = 0; i < n_pts; i++) {
642             const double *xi = xd + (size_t)i * (size_t)n_feats;
643             int votes = 0;
644             if (min_votes > 0) {
645             double label = 0.0;
646             for (int t = 0; t < n_trees; t++) {
647             if (if_walk_tree(node_ptrs[t], idx_ptrs[t],
648             val_ptrs[t], xi, n_feats) <= depth_cut) {
649             votes++;
650             if (votes >= min_votes) { label = 1.0; break; }
651             }
652             if (votes + (n_trees - 1 - t) < min_votes) break;
653             }
654             sm[i] = label;
655             } else {
656             for (int t = 0; t < n_trees; t++) {
657             votes += (if_walk_tree(node_ptrs[t], idx_ptrs[t],
658             val_ptrs[t], xi, n_feats)
659             <= depth_cut) ? 1 : 0;
660             }
661             sm[i] = (double)votes;
662             }
663             }
664             }
665              
666             /* vote_labels_xs(sm_sv, n_pts, out_rv)
667             *
668             * Converts the 0.0/1.0 label buffer vote_all_xs writes in early-exit
669             * mode into an arrayref of 0/1 IVs -- the majority-voting counterpart
670             * of predict_sums_xs (whose <= comparison points the wrong way for
671             * vote counts, where HIGH means anomalous). */
672             void vote_labels_xs(SV* sm_sv, int n_pts, SV* out_rv){
673             STRLEN tl;
674             const double* sm;
675             AV* out;
676             int i;
677              
678             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
679             croak("vote_labels_xs: out must be an arrayref");
680             }
681             sm = (const double*)SvPVbyte(sm_sv, tl);
682             out = (AV*)SvRV(out_rv);
683             av_clear(out);
684             if (n_pts > 0) av_extend(out, n_pts - 1);
685             for (i = 0; i < n_pts; i++) {
686             av_store(out, i, newSViv(sm[i] != 0.0 ? 1 : 0));
687             }
688             }
689              
690             /* vote_score_predict_xs(sm_sv, n_pts, t, min_votes, out_rv)
691             *
692             * Fills out_rv with [vote_fraction, majority_label] pairs from a
693             * vote-count buffer (vote_all_xs with min_votes == 0): score is
694             * votes/t, label is votes >= min_votes. Same allocation pattern and
695             * refcount discipline as score_predict_xs. */
696             void vote_score_predict_xs(SV* sm_sv, int n_pts, double t,
697             double min_votes, SV* out_rv){
698             STRLEN tl;
699             const double* sm;
700             AV* out;
701             int i;
702              
703             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
704             croak("vote_score_predict_xs: out must be an arrayref");
705             }
706             sm = (const double*)SvPVbyte(sm_sv, tl);
707             out = (AV*)SvRV(out_rv);
708             av_clear(out);
709             if (n_pts > 0) av_extend(out, n_pts - 1);
710             for (i = 0; i < n_pts; i++) {
711             AV* row = newAV();
712             av_extend(row, 1);
713             AvARRAY(row)[0] = newSVnv(sm[i] / t);
714             AvARRAY(row)[1] = newSViv(sm[i] >= min_votes ? 1 : 0);
715             AvFILLp(row) = 1;
716             av_store(out, i, newRV_noinc((SV*)row));
717             }
718             }
719              
720             /* vote_score_predict_split_xs(sm_sv, n_pts, t, min_votes,
721             * scores_rv, labels_rv)
722             *
723             * Parallel-arrays variant of vote_score_predict_xs, mirroring
724             * score_predict_split_xs's shape for the majority-voting path. */
725             void vote_score_predict_split_xs(SV* sm_sv, int n_pts, double t,
726             double min_votes,
727             SV* scores_rv, SV* labels_rv){
728             STRLEN tl;
729             const double* sm;
730             AV* scores;
731             AV* labels;
732             int i;
733              
734             if (!SvROK(scores_rv) || SvTYPE(SvRV(scores_rv)) != SVt_PVAV ||
735             !SvROK(labels_rv) || SvTYPE(SvRV(labels_rv)) != SVt_PVAV) {
736             croak("vote_score_predict_split_xs: scores/labels must be arrayrefs");
737             }
738             sm = (const double*)SvPVbyte(sm_sv, tl);
739             scores = (AV*)SvRV(scores_rv);
740             labels = (AV*)SvRV(labels_rv);
741             av_clear(scores);
742             av_clear(labels);
743             if (n_pts > 0) {
744             av_extend(scores, n_pts - 1);
745             av_extend(labels, n_pts - 1);
746             }
747             for (i = 0; i < n_pts; i++) {
748             av_store(scores, i, newSVnv(sm[i] / t));
749             av_store(labels, i, newSViv(sm[i] >= min_votes ? 1 : 0));
750             }
751             }
752              
753             /* ---------------------------------------------------------------------
754             * build_forest_xs -- C-accelerated fit() tree builder.
755             *
756             * Replaces the pure-Perl _subsample + _build_tree + _axis_split /
757             * _oblique_split recursion with an equivalent C implementation that
758             * partitions plain `int` row-index arrays instead of copying arrayrefs
759             * of Perl SVs at every split. Random draws go through Drand01() --
760             * the exact generator Perl's own rand()/srand() use internally -- in
761             * the same call order the Perl code used, so a fit() with a given
762             * seed produces BIT-IDENTICAL trees whether use_c is on or off. This
763             * is what lets fit() reuse the existing `use_c` knob instead of a new
764             * one: switching backends never changes the model, only how fast it's
765             * built. (Verified by t/02-accel-selection.t's "identical seed =>
766             * identical trees" subtest, which exercises both backends.)
767             *
768             * Output trees are plain Perl arrayrefs in the same node shape
769             * _build_tree produces (leaf/axis/oblique -- see the file-top
770             * comment), so every downstream consumer (_pack_tree, to_json,
771             * from_json, the pure-Perl scorer) is unchanged.
772             *
773             * x_sv: packed row-major double buffer, n_pts rows of n_feats each
774             * (from pack_input_xs -- NaN marks a missing cell under the
775             * 'nan' missing-strategy).
776             * mode_flag: 0 => axis-parallel splits, 1 => oblique (extended).
777             * ext_level: extension_level_used (ignored when mode_flag == 0).
778             * out_rv: pre-existing arrayref; filled with n_trees tree roots.
779             * ------------------------------------------------------------------ */
780              
781             /* Box-Muller normal draw, in the same rand() call order as _randn(). */
782             static double _c_randn(pTHX) {
783             double u1 = Drand01();
784             double u2;
785             if (u1 == 0.0) u1 = 1e-12;
786             u2 = Drand01();
787             return sqrt(-2.0 * log(u1)) * cos(6.283185307179586 * u2);
788             }
789              
790             static SV* _mk_leaf(pTHX_ int size) {
791             AV* av = newAV();
792             av_extend(av, 1);
793             AvARRAY(av)[0] = newSVnv(0.0);
794             AvARRAY(av)[1] = newSViv(size);
795             AvFILLp(av) = 1;
796             return newRV_noinc((SV*)av);
797             }
798              
799             static SV* _mk_axis(pTHX_ int attr, double split, SV* left, SV* right) {
800             AV* av = newAV();
801             av_extend(av, 4);
802             AvARRAY(av)[0] = newSVnv(1.0);
803             AvARRAY(av)[1] = newSViv(attr);
804             AvARRAY(av)[2] = newSVnv(split);
805             AvARRAY(av)[3] = left;
806             AvARRAY(av)[4] = right;
807             AvFILLp(av) = 4;
808             return newRV_noinc((SV*)av);
809             }
810              
811             static SV* _mk_oblique(pTHX_ const int* idx, const double* coef, int n,
812             double b, SV* left, SV* right) {
813             AV *iav, *cav, *av;
814             int k;
815             iav = newAV();
816             cav = newAV();
817             if (n > 0) {
818             av_extend(iav, n - 1);
819             av_extend(cav, n - 1);
820             }
821             for (k = 0; k < n; k++) {
822             AvARRAY(iav)[k] = newSViv(idx[k]);
823             AvARRAY(cav)[k] = newSVnv(coef[k]);
824             }
825             AvFILLp(iav) = n - 1;
826             AvFILLp(cav) = n - 1;
827              
828             av = newAV();
829             av_extend(av, 5);
830             AvARRAY(av)[0] = newSVnv(2.0);
831             AvARRAY(av)[1] = newRV_noinc((SV*)iav);
832             AvARRAY(av)[2] = newRV_noinc((SV*)cav);
833             AvARRAY(av)[3] = newSVnv(b);
834             AvARRAY(av)[4] = left;
835             AvARRAY(av)[5] = right;
836             AvFILLp(av) = 5;
837             return newRV_noinc((SV*)av);
838             }
839              
840             /* Builds one node from the point set `idxs` (row indices into `x`,
841             * length `size`); recurses left-then-right, matching _build_tree's
842             * traversal order so nested splits draw random numbers in the same
843             * sequence the pure-Perl path would. Takes ownership of `idxs` --
844             * frees it before returning. */
845             static SV* _build_node_c(pTHX_ const double* x, int nf, int* idxs, int size,
846             int depth, int limit, int mode_flag,
847             int ext_active) {
848             double *lo, *hi;
849             int *varying, nv, f;
850             SV *result;
851              
852             if (depth >= limit || size <= 1) {
853             SV* leaf = _mk_leaf(aTHX_ size);
854             free(idxs);
855             return leaf;
856             }
857              
858             lo = (double*)malloc(nf * sizeof(double));
859             hi = (double*)malloc(nf * sizeof(double));
860             for (f = 0; f < nf; f++) {
861             lo[f] = HUGE_VAL;
862             hi[f] = -HUGE_VAL;
863             }
864             for (int i = 0; i < size; i++) {
865             const double* row = x + (size_t)idxs[i] * (size_t)nf;
866             /* No isnan() guard needed: NaN < x and NaN > x are always false
867             * under IEEE 754, so a NaN cell (the 'nan' missing strategy)
868             * already leaves lo/hi untouched without an explicit check --
869             * one less branch, and it's what lets this loop vectorize
870             * cleanly as a plain elementwise min/max scan. */
871             #ifdef _OPENMP
872             #pragma omp simd
873             #endif
874             for (int f2 = 0; f2 < nf; f2++) {
875             double v = row[f2];
876             if (v < lo[f2]) lo[f2] = v;
877             if (v > hi[f2]) hi[f2] = v;
878             }
879             }
880              
881             varying = (int*)malloc(nf * sizeof(int));
882             nv = 0;
883             for (f = 0; f < nf; f++) {
884             if (lo[f] < hi[f]) varying[nv++] = f;
885             }
886              
887             if (nv == 0) {
888             free(lo); free(hi); free(varying);
889             SV* leaf = _mk_leaf(aTHX_ size);
890             free(idxs);
891             return leaf;
892             }
893              
894             if (mode_flag == 0) {
895             /* Axis-parallel split: one varying feature, one threshold. */
896             int attr = varying[(int)(Drand01() * nv)];
897             double split = lo[attr] + Drand01() * (hi[attr] - lo[attr]);
898             int *lidx = (int*)malloc(size * sizeof(int));
899             int *ridx = (int*)malloc(size * sizeof(int));
900             int ln = 0, rn = 0, i;
901             SV *left, *right;
902              
903             for (i = 0; i < size; i++) {
904             int row = idxs[i];
905             double v = x[(size_t)row * (size_t)nf + attr];
906             if (v < split) lidx[ln++] = row; else ridx[rn++] = row;
907             }
908             free(idxs); free(lo); free(hi); free(varying);
909              
910             left = _build_node_c(aTHX_ x, nf, lidx, ln, depth + 1, limit,
911             mode_flag, ext_active);
912             right = _build_node_c(aTHX_ x, nf, ridx, rn, depth + 1, limit,
913             mode_flag, ext_active);
914             result = _mk_axis(aTHX_ attr, split, left, right);
915             } else {
916             /* Oblique split: a random hyperplane over `active` features. */
917             int active = ext_active + 1;
918             int *pool, *lidx, *ridx;
919             double *coef;
920             double b = 0.0;
921             int ln = 0, rn = 0, i, k;
922             SV *left, *right;
923              
924             if (active > nv) active = nv;
925             pool = (int*)malloc(nv * sizeof(int));
926             memcpy(pool, varying, nv * sizeof(int));
927             for (i = 0; i < active; i++) {
928             int j = i + (int)(Drand01() * (nv - i));
929             int tmp = pool[i]; pool[i] = pool[j]; pool[j] = tmp;
930             }
931              
932             coef = (double*)malloc(active * sizeof(double));
933             for (k = 0; k < active; k++) {
934             int ff = pool[k];
935             double c = _c_randn(aTHX);
936             double p = lo[ff] + Drand01() * (hi[ff] - lo[ff]);
937             coef[k] = c;
938             b += c * p;
939             }
940              
941             lidx = (int*)malloc(size * sizeof(int));
942             ridx = (int*)malloc(size * sizeof(int));
943             for (i = 0; i < size; i++) {
944             int row = idxs[i];
945             double dot = 0.0;
946             for (k = 0; k < active; k++) {
947             dot += coef[k] * x[(size_t)row * (size_t)nf + pool[k]];
948             }
949             if (dot <= b) lidx[ln++] = row; else ridx[rn++] = row;
950             }
951             free(idxs); free(lo); free(hi); free(varying);
952              
953             left = _build_node_c(aTHX_ x, nf, lidx, ln, depth + 1, limit,
954             mode_flag, ext_active);
955             right = _build_node_c(aTHX_ x, nf, ridx, rn, depth + 1, limit,
956             mode_flag, ext_active);
957             result = _mk_oblique(aTHX_ pool, coef, active, b, left, right);
958             free(pool); free(coef);
959             }
960             return result;
961             }
962              
963             void build_forest_xs(SV* x_sv, int n_pts, int n_feats, int n_trees,
964             int psi, int limit, int mode_flag, int ext_level,
965             SV* out_rv) {
966             dTHX;
967             STRLEN tl;
968             const double* x;
969             AV* out;
970             int* all;
971             int t, i;
972              
973             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
974             croak("build_forest_xs: out must be an arrayref");
975             }
976             x = (const double*)SvPVbyte(x_sv, tl);
977             out = (AV*)SvRV(out_rv);
978             av_clear(out);
979             if (n_trees > 0) av_extend(out, n_trees - 1);
980              
981             all = (int*)malloc(n_pts * sizeof(int));
982             for (t = 0; t < n_trees; t++) {
983             int* sample;
984              
985             for (i = 0; i < n_pts; i++) all[i] = i;
986             for (i = 0; i < psi; i++) {
987             int j = i + (int)(Drand01() * (n_pts - i));
988             int tmp = all[i]; all[i] = all[j]; all[j] = tmp;
989             }
990             sample = (int*)malloc(psi * sizeof(int));
991             memcpy(sample, all, psi * sizeof(int));
992              
993             av_store(out, t,
994             _build_node_c(aTHX_ x, n_feats, sample, psi, 0, limit,
995             mode_flag, ext_level));
996             }
997             free(all);
998             }
999              
1000             /* ---------------------------------------------------------------------
1001             * build_forest_openmp_xs -- OpenMP-parallel fit() tree builder.
1002             *
1003             * build_forest_xs (above) is bit-identical to the pure-Perl path
1004             * because every random draw goes through Drand01(), the same
1005             * generator Perl's rand()/srand() use -- but that generator is a
1006             * single mutable struct shared by the whole interpreter, so calling
1007             * it concurrently from multiple OpenMP threads would be a data race.
1008             * The same is true of any Perl API call (newAV, newSViv, ...): Perl's
1009             * SV allocator isn't safe to call from multiple OS threads sharing one
1010             * interpreter without a lock that would just serialise everything
1011             * anyway.
1012             *
1013             * So this builder trades the bit-identical guarantee for real thread
1014             * parallelism: each tree gets its own splitmix64 PRNG stream, seeded
1015             * from a tree index (not thread id or scheduling order), so results
1016             * are still reproducible for a fixed seed and n_trees regardless of
1017             * OMP_NUM_THREADS -- just different from what build_forest_xs or the
1018             * pure-Perl path would produce for the same seed. The one Drand01()
1019             * call in this function happens before the parallel region starts
1020             * (single-threaded), so the result still varies with the model's
1021             * `seed` the way every other code path does; it isn't used inside the
1022             * parallel loop.
1023             *
1024             * Each tree is built entirely with plain C data (row-index int arrays,
1025             * a growable TreeBuf of packed doubles/ints) -- no Perl API call
1026             * happens anywhere inside the parallel region. Each node record in
1027             * TreeBuf uses _pack_tree's 6-double SoA layout (see the file-top
1028             * comment), but the node ORDER differs: records are appended
1029             * post-order (a node is pushed after both its children, since child
1030             * indices must be known first), so the root is the last record --
1031             * _pack_tree's pre-order puts it at 0. _unpack_forest accounts for
1032             * this. Oblique coefficients are also always stored sparse (in the
1033             * random pool's order) -- the dense-pack fast path is skipped because
1034             * its only purpose is speeding up score_all_xs, and _rebuild_c_trees
1035             * reapplies it anyway once the caller unpacks these buffers back into
1036             * the standard Perl tree shape and re-derives the scoring buffers.
1037             *
1038             * After the parallel region, each tree's TreeBuf is copied into a Perl
1039             * string SV (one memcpy each, serially) and stored into nodes_rv /
1040             * idx_rv / val_rv -- the caller unpacks these into ordinary nested
1041             * Perl trees for $self->{trees} (so to_json/persistence/_rebuild_c_trees
1042             * are unaffected). ------------------------------------------------ */
1043              
1044             typedef struct {
1045             double *nodes; size_t n_nodes, cap_nodes;
1046             int *idx; size_t n_idx, cap_idx;
1047             double *val; size_t n_val, cap_val;
1048             } TreeBuf;
1049              
1050             static void tb_init(TreeBuf *b) {
1051             b->nodes = NULL; b->n_nodes = 0; b->cap_nodes = 0;
1052             b->idx = NULL; b->n_idx = 0; b->cap_idx = 0;
1053             b->val = NULL; b->n_val = 0; b->cap_val = 0;
1054             }
1055              
1056             static void tb_free(TreeBuf *b) {
1057             free(b->nodes); free(b->idx); free(b->val);
1058             }
1059              
1060             static int tb_push_node(TreeBuf *b, double f0, double f1, double f2,
1061             double f3, double f4, double f5) {
1062             double *slot;
1063             if (b->n_nodes == b->cap_nodes) {
1064             size_t newcap = b->cap_nodes ? b->cap_nodes * 2 : 64;
1065             b->nodes = (double*)realloc(b->nodes, newcap * 6 * sizeof(double));
1066             b->cap_nodes = newcap;
1067             }
1068             slot = b->nodes + b->n_nodes * 6;
1069             slot[0] = f0; slot[1] = f1; slot[2] = f2;
1070             slot[3] = f3; slot[4] = f4; slot[5] = f5;
1071             return (int)(b->n_nodes++);
1072             }
1073              
1074             /* Appends n (idx[k], val[k]) pairs and returns the offset they start
1075             * at -- the `coff` an oblique node record stores. */
1076             static int tb_push_coef(TreeBuf *b, const int *idx, const double *val,
1077             int n) {
1078             int off = (int)b->n_idx;
1079             if (b->n_idx + (size_t)n > b->cap_idx) {
1080             size_t newcap = b->cap_idx ? b->cap_idx * 2 : 64;
1081             if (newcap < b->n_idx + (size_t)n) newcap = b->n_idx + (size_t)n;
1082             b->idx = (int*)realloc(b->idx, newcap * sizeof(int));
1083             b->cap_idx = newcap;
1084             }
1085             if (b->n_val + (size_t)n > b->cap_val) {
1086             size_t newcap = b->cap_val ? b->cap_val * 2 : 64;
1087             if (newcap < b->n_val + (size_t)n) newcap = b->n_val + (size_t)n;
1088             b->val = (double*)realloc(b->val, newcap * sizeof(double));
1089             b->cap_val = newcap;
1090             }
1091             memcpy(b->idx + b->n_idx, idx, (size_t)n * sizeof(int));
1092             memcpy(b->val + b->n_val, val, (size_t)n * sizeof(double));
1093             b->n_idx += n;
1094             b->n_val += n;
1095             return off;
1096             }
1097              
1098             /* splitmix64 -- fast, well-mixed, and per-stream state fits in one
1099             * uint64_t, which is all a thread-private PRNG needs here. Not
1100             * cryptographic; doesn't need to be. */
1101             static uint64_t sm64_next(uint64_t *s) {
1102             uint64_t z = (*s += 0x9E3779B97F4A7C15ULL);
1103             z = (z ^ (z >> 30)) * 0xBF58476D1CE4E5B9ULL;
1104             z = (z ^ (z >> 27)) * 0x94D049BB133111EBULL;
1105             return z ^ (z >> 31);
1106             }
1107              
1108             static double sm64_drand(uint64_t *s) {
1109             return (double)(sm64_next(s) >> 11) * (1.0 / 9007199254740992.0);
1110             }
1111              
1112             static double _ts_randn(uint64_t *s) {
1113             double u1 = sm64_drand(s);
1114             double u2;
1115             if (u1 == 0.0) u1 = 1e-12;
1116             u2 = sm64_drand(s);
1117             return sqrt(-2.0 * log(u1)) * cos(6.283185307179586 * u2);
1118             }
1119              
1120             /* Thread-safe twin of _build_node_c: same split algorithm, but reads
1121             * randomness from a thread-private splitmix64 stream instead of
1122             * Drand01(), and writes into a TreeBuf instead of allocating Perl AVs
1123             * -- so it touches no interpreter-global state and is safe to call
1124             * concurrently from an OpenMP parallel region, one tree per thread. */
1125             static int _build_node_packed(const double* x, int nf, int* idxs, int size,
1126             int depth, int limit, int mode_flag,
1127             int ext_active, TreeBuf *buf, uint64_t *rng) {
1128             double *lo, *hi;
1129             int *varying, nv, f, my_idx;
1130              
1131             if (depth >= limit || size <= 1) {
1132             my_idx = tb_push_node(buf, 0.0, (double)size, 0.0, 0.0, 0.0, 0.0);
1133             free(idxs);
1134             return my_idx;
1135             }
1136              
1137             lo = (double*)malloc(nf * sizeof(double));
1138             hi = (double*)malloc(nf * sizeof(double));
1139             for (f = 0; f < nf; f++) {
1140             lo[f] = HUGE_VAL;
1141             hi[f] = -HUGE_VAL;
1142             }
1143             for (int i = 0; i < size; i++) {
1144             const double* row = x + (size_t)idxs[i] * (size_t)nf;
1145             /* See the matching comment in _build_node_c: no isnan() guard
1146             * needed, since NaN < x / NaN > x are always false already --
1147             * that's what lets this vectorize as a plain min/max scan.
1148             * omp simd here is thread-safe to call from inside the caller's
1149             * omp parallel region: it's a per-thread vectorization hint,
1150             * not a team construct, so it doesn't nest into anything. */
1151             #ifdef _OPENMP
1152             #pragma omp simd
1153             #endif
1154             for (int f2 = 0; f2 < nf; f2++) {
1155             double v = row[f2];
1156             if (v < lo[f2]) lo[f2] = v;
1157             if (v > hi[f2]) hi[f2] = v;
1158             }
1159             }
1160              
1161             varying = (int*)malloc(nf * sizeof(int));
1162             nv = 0;
1163             for (f = 0; f < nf; f++) {
1164             if (lo[f] < hi[f]) varying[nv++] = f;
1165             }
1166              
1167             if (nv == 0) {
1168             free(lo); free(hi); free(varying);
1169             my_idx = tb_push_node(buf, 0.0, (double)size, 0.0, 0.0, 0.0, 0.0);
1170             free(idxs);
1171             return my_idx;
1172             }
1173              
1174             if (mode_flag == 0) {
1175             int attr = varying[(int)(sm64_drand(rng) * nv)];
1176             double split = lo[attr] + sm64_drand(rng) * (hi[attr] - lo[attr]);
1177             int *lidx = (int*)malloc(size * sizeof(int));
1178             int *ridx = (int*)malloc(size * sizeof(int));
1179             int ln = 0, rn = 0, i, li, ri;
1180              
1181             for (i = 0; i < size; i++) {
1182             int row = idxs[i];
1183             double v = x[(size_t)row * (size_t)nf + attr];
1184             if (v < split) lidx[ln++] = row; else ridx[rn++] = row;
1185             }
1186             free(idxs); free(lo); free(hi); free(varying);
1187              
1188             li = _build_node_packed(x, nf, lidx, ln, depth + 1, limit,
1189             mode_flag, ext_active, buf, rng);
1190             ri = _build_node_packed(x, nf, ridx, rn, depth + 1, limit,
1191             mode_flag, ext_active, buf, rng);
1192             my_idx = tb_push_node(buf, 1.0, (double)attr, split,
1193             (double)li, (double)ri, 0.0);
1194             } else {
1195             int active = ext_active + 1;
1196             int *pool, *lidx, *ridx;
1197             double *coef;
1198             double b = 0.0;
1199             int ln = 0, rn = 0, i, k, li, ri, coff;
1200              
1201             if (active > nv) active = nv;
1202             pool = (int*)malloc(nv * sizeof(int));
1203             memcpy(pool, varying, nv * sizeof(int));
1204             for (i = 0; i < active; i++) {
1205             int j = i + (int)(sm64_drand(rng) * (nv - i));
1206             int tmp = pool[i]; pool[i] = pool[j]; pool[j] = tmp;
1207             }
1208              
1209             coef = (double*)malloc(active * sizeof(double));
1210             for (k = 0; k < active; k++) {
1211             int ff = pool[k];
1212             double c = _ts_randn(rng);
1213             double p = lo[ff] + sm64_drand(rng) * (hi[ff] - lo[ff]);
1214             coef[k] = c;
1215             b += c * p;
1216             }
1217              
1218             lidx = (int*)malloc(size * sizeof(int));
1219             ridx = (int*)malloc(size * sizeof(int));
1220             for (i = 0; i < size; i++) {
1221             int row = idxs[i];
1222             double dot = 0.0;
1223             for (k = 0; k < active; k++) {
1224             dot += coef[k] * x[(size_t)row * (size_t)nf + pool[k]];
1225             }
1226             if (dot <= b) lidx[ln++] = row; else ridx[rn++] = row;
1227             }
1228             free(idxs); free(lo); free(hi); free(varying);
1229              
1230             li = _build_node_packed(x, nf, lidx, ln, depth + 1, limit,
1231             mode_flag, ext_active, buf, rng);
1232             ri = _build_node_packed(x, nf, ridx, rn, depth + 1, limit,
1233             mode_flag, ext_active, buf, rng);
1234             coff = tb_push_coef(buf, pool, coef, active);
1235             my_idx = tb_push_node(buf, 2.0, (double)coff, (double)active,
1236             (double)li, (double)ri, b);
1237             free(pool); free(coef);
1238             }
1239             return my_idx;
1240             }
1241              
1242             void build_forest_openmp_xs(SV* x_sv, int n_pts, int n_feats, int n_trees,
1243             int psi, int limit, int mode_flag,
1244             int ext_level, SV* nodes_rv, SV* idx_rv,
1245             SV* val_rv, int use_openmp) {
1246             dTHX;
1247             STRLEN tl;
1248             const double* x;
1249             AV *nodes_av, *idx_av, *val_av;
1250             TreeBuf *bufs;
1251             uint64_t base_seed;
1252             int t;
1253              
1254             if (!SvROK(nodes_rv) || SvTYPE(SvRV(nodes_rv)) != SVt_PVAV ||
1255             !SvROK(idx_rv) || SvTYPE(SvRV(idx_rv)) != SVt_PVAV ||
1256             !SvROK(val_rv) || SvTYPE(SvRV(val_rv)) != SVt_PVAV) {
1257             croak("build_forest_openmp_xs: nodes/idx/val must be arrayrefs");
1258             }
1259             x = (const double*)SvPVbyte(x_sv, tl);
1260             nodes_av = (AV*)SvRV(nodes_rv);
1261             idx_av = (AV*)SvRV(idx_rv);
1262             val_av = (AV*)SvRV(val_rv);
1263             av_clear(nodes_av); av_clear(idx_av); av_clear(val_av);
1264             if (n_trees > 0) {
1265             av_extend(nodes_av, n_trees - 1);
1266             av_extend(idx_av, n_trees - 1);
1267             av_extend(val_av, n_trees - 1);
1268             }
1269              
1270             /* Single Drand01() call, before the parallel region starts, so it's
1271             * still a plain serial call into the interpreter's RNG state. */
1272             base_seed = (uint64_t)(Drand01() * 18446744073709551615.0);
1273              
1274             bufs = (TreeBuf*)malloc((size_t)n_trees * sizeof(TreeBuf));
1275             for (t = 0; t < n_trees; t++) tb_init(&bufs[t]);
1276              
1277             #ifdef _OPENMP
1278             #pragma omp parallel for schedule(dynamic) if(use_openmp)
1279             #endif
1280             for (int t = 0; t < n_trees; t++) {
1281             /* Seeded from the tree index, not thread id or iteration order,
1282             * so the mapping from tree -> RNG stream is independent of
1283             * OMP_NUM_THREADS / scheduling. sm64_next() mixes once more so
1284             * adjacent tree indices (which differ by one golden-ratio step)
1285             * don't start from too-similar states. */
1286             uint64_t rng = base_seed + (uint64_t)t * 0x9E3779B97F4A7C15ULL;
1287             rng = sm64_next(&rng);
1288             int *all = (int*)malloc((size_t)n_pts * sizeof(int));
1289             int *sample;
1290             int i;
1291              
1292             for (i = 0; i < n_pts; i++) all[i] = i;
1293             for (i = 0; i < psi; i++) {
1294             int j = i + (int)(sm64_drand(&rng) * (n_pts - i));
1295             int tmp = all[i]; all[i] = all[j]; all[j] = tmp;
1296             }
1297             sample = (int*)malloc((size_t)psi * sizeof(int));
1298             memcpy(sample, all, (size_t)psi * sizeof(int));
1299             free(all);
1300              
1301             _build_node_packed(x, n_feats, sample, psi, 0, limit, mode_flag,
1302             ext_level, &bufs[t], &rng);
1303             }
1304              
1305             for (t = 0; t < n_trees; t++) {
1306             /* newSVpvn(NULL, 0) makes an undef SV, not an empty-string one --
1307             * axis-mode trees never call tb_push_coef, so idx/val stay NULL.
1308             * Pass "" instead so the Perl side's unpack('...', $sv) always
1309             * gets a defined (if empty) string, never undef. */
1310             av_store(nodes_av, t, newSVpvn((char*)bufs[t].nodes,
1311             bufs[t].n_nodes * 6 * sizeof(double)));
1312             av_store(idx_av, t, bufs[t].n_idx
1313             ? newSVpvn((char*)bufs[t].idx, bufs[t].n_idx * sizeof(int))
1314             : newSVpvn("", 0));
1315             av_store(val_av, t, bufs[t].n_val
1316             ? newSVpvn((char*)bufs[t].val, bufs[t].n_val * sizeof(double))
1317             : newSVpvn("", 0));
1318             tb_free(&bufs[t]);
1319             }
1320             free(bufs);
1321             }
1322              
1323             /* ---------------------------------------------------------------------
1324             * impute_fill_xs(data_sv, n_pts, n_feats, how, out_rv)
1325             *
1326             * C replacement for _compute_impute_fill's Perl loop: walks the raw
1327             * arrayref-of-arrayrefs directly (like pack_input_xs), collecting each
1328             * feature's present (defined) values, then reduces them to one fill
1329             * value per feature -- mean (how == 0) or median (how == 1) -- and
1330             * writes n_feats doubles into out_rv.
1331             *
1332             * Values are collected in row order (i = 0..n_pts-1), the same order
1333             * the Perl version's `grep { defined } map { $_->[$f] } @data` walks
1334             * them in, so the mean's left-to-right summation lands on the exact
1335             * same float as the Perl path -- use_c toggles speed here, not the
1336             * computed fill, matching the rest of the module.
1337             *
1338             * The median is an exact order statistic (not summation-dependent), so
1339             * it matches the Perl path's sort-based median by definition regardless
1340             * of which selection algorithm finds it. Croaks with the same message
1341             * as the Perl fallback if a feature has no present values anywhere in
1342             * the dataset. */
1343             typedef struct { double *v; size_t n, cap; } DVec;
1344              
1345             static void dvec_push(DVec *d, double x) {
1346             if (d->n == d->cap) {
1347             size_t newcap = d->cap ? d->cap * 2 : 64;
1348             d->v = (double*)realloc(d->v, newcap * sizeof(double));
1349             d->cap = newcap;
1350             }
1351             d->v[d->n++] = x;
1352             }
1353              
1354             static void _dswap(double *a, double *b) { double t = *a; *a = *b; *b = t; }
1355              
1356             /* Lomuto partition with a median-of-three pivot (avoids the O(n^2)
1357             * worst case a fixed pivot hits on already-sorted or reverse-sorted
1358             * input, which real feature columns -- timestamps, counters -- often
1359             * are). Returns the pivot's final index. */
1360             static int _partition_lomuto(double *a, int lo, int hi) {
1361             int mid = lo + (hi - lo) / 2;
1362             double pivot;
1363             int i, j;
1364             if (a[mid] < a[lo]) _dswap(&a[lo], &a[mid]);
1365             if (a[hi] < a[lo]) _dswap(&a[lo], &a[hi]);
1366             if (a[hi] < a[mid]) _dswap(&a[mid], &a[hi]);
1367             _dswap(&a[mid], &a[hi]);
1368             pivot = a[hi];
1369             i = lo;
1370             for (j = lo; j < hi; j++) {
1371             if (a[j] < pivot) { _dswap(&a[i], &a[j]); i++; }
1372             }
1373             _dswap(&a[i], &a[hi]);
1374             return i;
1375             }
1376              
1377             /* Quickselect: returns the k-th smallest (0-indexed) of a[0..n-1],
1378             * reordering a[] in the process (fine -- it's a private scratch copy).
1379             * O(n) average case vs. a full O(n log n) sort. */
1380             static double _kth_smallest(double *a, int n, int k) {
1381             int lo = 0, hi = n - 1;
1382             while (lo < hi) {
1383             int p = _partition_lomuto(a, lo, hi);
1384             if (p == k) return a[p];
1385             if (p < k) lo = p + 1; else hi = p - 1;
1386             }
1387             return a[lo];
1388             }
1389              
1390             /* Median of a[0..n-1] (reorders a[]). Odd n: the single middle order
1391             * statistic. Even n: quickselect finds the lower-median at k = n/2-1,
1392             * which leaves every a[i > k] >= a[k] (the standard quickselect
1393             * post-condition) -- so the upper-median is just the min of that
1394             * remaining slice, one more linear scan instead of a second full
1395             * selection pass. */
1396             static double _median_select(double *a, int n) {
1397             if (n % 2 == 1) {
1398             return _kth_smallest(a, n, n / 2);
1399             } else {
1400             int k = n / 2 - 1;
1401             double lower = _kth_smallest(a, n, k);
1402             double upper = a[k + 1];
1403             int i;
1404             for (i = k + 2; i < n; i++) {
1405             if (a[i] < upper) upper = a[i];
1406             }
1407             return (lower + upper) / 2.0;
1408             }
1409             }
1410              
1411             void impute_fill_xs(SV* data_sv, int n_pts, int n_feats, int how,
1412             SV* out_rv) {
1413             dTHX;
1414             AV *outer, *out;
1415             DVec *cols;
1416             int i, f;
1417              
1418             if (!SvROK(data_sv) || SvTYPE(SvRV(data_sv)) != SVt_PVAV) {
1419             croak("impute_fill_xs: data must be an arrayref");
1420             }
1421             if (!SvROK(out_rv) || SvTYPE(SvRV(out_rv)) != SVt_PVAV) {
1422             croak("impute_fill_xs: out must be an arrayref");
1423             }
1424             outer = (AV*)SvRV(data_sv);
1425             out = (AV*)SvRV(out_rv);
1426              
1427             cols = (DVec*)calloc((size_t)n_feats, sizeof(DVec));
1428              
1429             for (i = 0; i < n_pts; i++) {
1430             SV** row_pp = av_fetch(outer, i, 0);
1431             AV* row;
1432             if (!row_pp || !*row_pp || !SvROK(*row_pp) ||
1433             SvTYPE(SvRV(*row_pp)) != SVt_PVAV) {
1434             continue;
1435             }
1436             row = (AV*)SvRV(*row_pp);
1437             for (f = 0; f < n_feats; f++) {
1438             SV** v = av_fetch(row, f, 0);
1439             if (v && *v && SvOK(*v)) {
1440             dvec_push(&cols[f], SvNV(*v));
1441             }
1442             }
1443             }
1444              
1445             /* Validate every column before freeing anything: croak() longjmps
1446             * out of this function, so any cleanup loop reachable after a
1447             * partial computation has already started (and already freed some
1448             * cols[i].v) risks a double free on those same pointers. Checking
1449             * all columns up front, before the computation loop below frees
1450             * anything, avoids that entirely. Matches the Perl fallback's
1451             * behaviour of reporting the first empty column in feature order. */
1452             for (f = 0; f < n_feats; f++) {
1453             if (cols[f].n == 0) {
1454             int col = f;
1455             for (i = 0; i < n_feats; i++) free(cols[i].v);
1456             free(cols);
1457             croak("impute: feature column %d has no present values", col);
1458             }
1459             }
1460              
1461             av_clear(out);
1462             if (n_feats > 0) av_extend(out, n_feats - 1);
1463              
1464             for (f = 0; f < n_feats; f++) {
1465             double result;
1466             if (how == 0) {
1467             double sum = 0.0;
1468             for (i = 0; i < (int)cols[f].n; i++) sum += cols[f].v[i];
1469             result = sum / (double)cols[f].n;
1470             } else {
1471             result = _median_select(cols[f].v, (int)cols[f].n);
1472             }
1473             av_store(out, f, newSVnv(result));
1474             free(cols[f].v);
1475             }
1476             free(cols);
1477             }
1478             __INLINE_C__
1479              
1480             # IF_NO_C=1 skips even attempting to set up the C backend -- useful for
1481             # forcing the pure-Perl path without touching every constructor call
1482             # (use_c => 0), e.g. to get a clean timing baseline or to avoid the
1483             # compile attempt's overhead/noise in a container known to lack a
1484             # compiler. Everything below is skipped and $HAS_C stays 0.
1485             unless ( $ENV{IF_NO_C} ) {
1486              
1487             # Defaults recorded when `perl Makefile.PL` ran. Makefile.PL generates
1488             # Algorithm::Classifier::IsolationForest::BuildFlags, capturing the
1489             # IF_* values active at configure time plus whether a prebuilt object
1490             # was scheduled for install (see "Compile at install time" in the POD
1491             # below). From a plain source checkout the generated file is absent,
1492             # the hard defaults here apply, and no prebuilt object is looked for.
1493             my ( $def_opt, $def_arch, $def_no_omp, $prebuilt ) = ( '-O3', '', 0, 0 );
1494             {
1495             local $@;
1496             my $rec = eval {
1497             require Algorithm::Classifier::IsolationForest::BuildFlags;
1498             Algorithm::Classifier::IsolationForest::BuildFlags::flags();
1499             };
1500             if ( ref $rec eq 'HASH' ) {
1501             $def_opt = $rec->{opt} if defined $rec->{opt};
1502             $def_arch = $rec->{arch} if defined $rec->{arch};
1503             $def_no_omp = $rec->{no_openmp} ? 1 : 0;
1504             $prebuilt = $rec->{prebuilt} ? 1 : 0;
1505             }
1506             }
1507              
1508             # -O3 is the usual default: it's safe to enable unconditionally and
1509             # matters here -- the extended-mode oblique dot product is wrapped in
1510             # `#pragma omp simd`, but without aggressive optimization the compiler
1511             # may still emit scalar code. Use OPTIMIZE (not CCFLAGS) -- CCFLAGS is
1512             # prepended to the cc line and would be shadowed by Perl's own `-O2 -g`
1513             # that ExtUtils::MakeMaker appends afterward (last `-O` wins in gcc).
1514             # IF_OPT overrides the level itself (e.g. IF_OPT=-O2 to work around a
1515             # miscompile, or to shorten build time while developing); it's
1516             # validated against a fixed set of GCC/Clang -O flags rather than
1517             # interpolated as-is, since this string eventually reaches a shell
1518             # command line via ExtUtils::MakeMaker.
1519             my $opt = $def_opt;
1520             if ( defined $ENV{IF_OPT} ) {
1521             if ( $ENV{IF_OPT} =~ /\A-O[0123sgz]\z/ ) {
1522             $opt = $ENV{IF_OPT};
1523             } else {
1524             warn "Algorithm::Classifier::IsolationForest: ignoring invalid "
1525             . "IF_OPT value '$ENV{IF_OPT}' (expected one of -O0 -O1 -O2 "
1526             . "-O3 -Os -Og -Oz); using $opt\n";
1527             }
1528             }
1529              
1530             # -march= lets the compiler target specific instruction-set
1531             # extensions (AVX2 gather + FMA, etc.) for the oblique dot product
1532             # and the fit-time min/max scan's `#pragma omp simd` loops.
1533             #
1534             # IF_ARCH= sets it explicitly (e.g. "x86-64-v3", "skylake",
1535             # "znver3") -- validated against a conservative identifier charset
1536             # since, like IF_OPT, it flows into a compiler command line.
1537             # IF_NATIVE=1 remains as shorthand for IF_ARCH=native and is used
1538             # when IF_ARCH isn't set. Prefer a specific IF_ARCH value over
1539             # IF_NATIVE on a machine you don't control exclusively: blanket
1540             # -march=native pulls in whatever the build host has, including
1541             # AVX-512 on some Intel CPUs, which is known to trigger clock
1542             # throttling under sustained heavy use and can make throughput
1543             # *worse* than a conservative target like x86-64-v3 (AVX2, no
1544             # AVX-512). Either way, the cached artefact under _Inline/ is then
1545             # pinned to that instruction set, so leave both unset if the
1546             # directory is shared across machines with different CPUs.
1547             my $arch = $def_arch;
1548             if ( defined $ENV{IF_ARCH} ) {
1549             if ( $ENV{IF_ARCH} eq '' or $ENV{IF_ARCH} eq 'none' ) {
1550              
1551             # Explicit opt-out: overrides an arch recorded at configure
1552             # time (there is no other way to request a plain build on
1553             # an install configured with IF_ARCH).
1554             $arch = '';
1555             } elsif ( $ENV{IF_ARCH} =~ /\A[A-Za-z0-9_.+=-]+\z/ ) {
1556             $arch = $ENV{IF_ARCH};
1557             } else {
1558             warn "Algorithm::Classifier::IsolationForest: ignoring invalid " . "IF_ARCH value '$ENV{IF_ARCH}'\n";
1559             }
1560             } elsif ( $ENV{IF_NATIVE} ) {
1561             $arch = 'native';
1562             }
1563             # -ffp-contract=off rides along with any -march: once the target
1564             # has FMA (x86-64-v3, most -march=native hosts), the compiler may
1565             # otherwise contract a*b+c expressions into fused multiply-adds
1566             # whose different rounding breaks the documented guarantee that
1567             # use_c => 1 and use_c => 0 build bit-identical trees (one ulp in a
1568             # split value cascades into a structurally different tree). The
1569             # -march speedup comes from AVX2 vectorization, not contraction,
1570             # so this costs little (verified against the fit-determinism and
1571             # scoring-parity tests).
1572             my $opt_level = $opt;
1573             $opt_level .= " -march=$arch -ffp-contract=off" if length $arch;
1574              
1575             # IF_NO_OPENMP=1 forces the serial C build: the OpenMP compile attempt
1576             # is skipped, so the object has no libgomp linkage and never starts an
1577             # OpenMP runtime in the process. Distinct from OMP_NUM_THREADS=1,
1578             # which runs the parallel code on a single thread but still loads
1579             # libgomp. An explicit IF_NO_OPENMP=0 re-enables OpenMP over a
1580             # no-openmp configure-time default.
1581             my $no_omp
1582             = defined $ENV{IF_NO_OPENMP}
1583             ? ( $ENV{IF_NO_OPENMP} ? 1 : 0 )
1584             : $def_no_omp;
1585              
1586             # The prebuilt object is only trusted when the effective flags match
1587             # what it was compiled with; any difference -- or an explicit
1588             # IF_RUNTIME_BUILD=1 -- falls through to the classic runtime Inline::C
1589             # build below, which honours the requested flags via the MD5-keyed
1590             # _Inline/ cache exactly as before prebuilt support existed.
1591             # IF_INSTALL_BUILD is the `make` rule driving the install-time compile
1592             # (see Makefile.PL); it must never short-circuit into loading an
1593             # older object.
1594             my $use_prebuilt
1595             = $prebuilt
1596             && !$ENV{IF_RUNTIME_BUILD}
1597             && !$ENV{IF_INSTALL_BUILD}
1598             && $opt eq $def_opt
1599             && $arch eq $def_arch
1600             && $no_omp == $def_no_omp;
1601              
1602             # Inline::C hashes the C source to decide whether to rebuild but
1603             # does NOT include CCFLAGS / OPTIMIZE in that hash. Without the
1604             # tag below, toggling IF_NATIVE/IF_ARCH/IF_OPT (or editing the
1605             # optimisation flags here) would silently reuse a cached binary
1606             # built with stale flags. Embedding the active flags as a leading
1607             # comment forces the hash to differ when they change. The OpenMP
1608             # and serial builds get distinct tags so they cache to separate
1609             # artefacts.
1610             my $omp_tag = "/* if_build: openmp $opt_level */\n";
1611             my $serial_tag = "/* if_build: serial $opt_level */\n";
1612              
1613             if ( $ENV{IF_INSTALL_BUILD} ) {
1614              
1615             # `make` is driving: the rule Makefile.PL appended runs this load
1616             # with IF_INSTALL_BUILD=1 and @ARGV = (version, INST_ARCHLIB),
1617             # which is where Inline's install mode reads them from. _INSTALL_
1618             # makes Inline compile the backend and place the shared object
1619             # under blib/arch so `make install` ships it; NAME/VERSION give
1620             # the object a fixed identity XSLoader can find at run time
1621             # (Inline's install mode also requires both and checks VERSION
1622             # against $ARGV[0]). Same OpenMP-then-serial fallback as the
1623             # runtime build below.
1624             my @install = (
1625             NAME => __PACKAGE__,
1626             VERSION => $VERSION,
1627             _INSTALL_ => 1,
1628             );
1629             unless ($no_omp) {
1630             local $@;
1631             eval {
1632             require Inline;
1633             Inline->import(
1634             C => $omp_tag . $C_CODE,
1635             CCFLAGS => '-fopenmp',
1636             OPTIMIZE => $opt_level,
1637             LIBS => '-lm -lgomp',
1638             @install,
1639             );
1640             $HAS_C = 1;
1641             };
1642             } ## end unless ($no_omp)
1643             unless ($HAS_C) {
1644             local $@;
1645             eval {
1646             require Inline;
1647             Inline->import(
1648             C => $serial_tag . $C_CODE,
1649             OPTIMIZE => $opt_level,
1650             LIBS => '-lm',
1651             @install,
1652             );
1653             $HAS_C = 1;
1654             };
1655             } ## end unless ($HAS_C)
1656             $C_SOURCE = 'prebuilt' if $HAS_C;
1657             } else {
1658              
1659             # Fast path: the object compiled at `make` time was installed
1660             # under auto/ like any XS module, so plain XSLoader digs it out of
1661             # @INC with no Inline involvement -- no compiler, no _Inline/
1662             # directory, and a few ms instead of a first-run compile. Any
1663             # failure (object deleted, different perl, version mismatch after
1664             # an upgrade, libgomp since removed) just falls through to the
1665             # runtime build.
1666             if ($use_prebuilt) {
1667             local $@;
1668             eval {
1669             require XSLoader;
1670             XSLoader::load( __PACKAGE__, $VERSION );
1671             $HAS_C = 1;
1672             $C_SOURCE = 'prebuilt';
1673             };
1674             }
1675              
1676             # Classic runtime Inline::C build, MD5-cached under _Inline/.
1677             # Reached when there is no matching prebuilt object: a source
1678             # checkout, IF_RUNTIME_BUILD=1, or IF_* values differing from the
1679             # ones recorded at configure time. Try compiling with OpenMP
1680             # first; on any failure (compiler doesn't accept -fopenmp, libgomp
1681             # missing, etc.) fall back to a serial build.
1682             unless ( $HAS_C or $no_omp ) {
1683             local $@;
1684             eval {
1685             require Inline;
1686             Inline->import(
1687             C => $omp_tag . $C_CODE,
1688             CCFLAGS => '-fopenmp',
1689             OPTIMIZE => $opt_level,
1690             LIBS => '-lm -lgomp',
1691             );
1692             $HAS_C = 1;
1693             $C_SOURCE = 'runtime';
1694             };
1695             } ## end unless ( $HAS_C or $no_omp )
1696             unless ($HAS_C) {
1697             local $@;
1698             eval {
1699             require Inline;
1700             Inline->import(
1701             C => $serial_tag . $C_CODE,
1702             OPTIMIZE => $opt_level,
1703             LIBS => '-lm',
1704             );
1705             $HAS_C = 1;
1706             $C_SOURCE = 'runtime';
1707             };
1708             } ## end unless ($HAS_C)
1709             } ## end else [ if ( $ENV{IF_INSTALL_BUILD} ) ]
1710             $OPT_LEVEL = $opt_level if $HAS_C;
1711              
1712             } ## end unless ( $ENV{IF_NO_C} )
1713             $HAS_OPENMP = ( $HAS_C && defined &has_openmp_xs && has_openmp_xs() ) ? 1 : 0;
1714             $HAS_SIMD = ( $HAS_C && defined &has_simd_xs && has_simd_xs() ) ? 1 : 0;
1715             }
1716              
1717             =encoding UTF-8
1718              
1719             =head1 NAME
1720              
1721             Algorithm::Classifier::IsolationForest - unsupervised anomaly detection via Isolation Forest or Extended Isolation Forest
1722              
1723             =head1 SYNOPSIS
1724              
1725             use Algorithm::Classifier::IsolationForest;
1726              
1727             my @data = ([0.1, -0.2], [0.0, 0.1], [5.0, 6.0], ...);
1728              
1729             # Classic, axis-parallel Isolation Forest
1730             my $iforest = Algorithm::Classifier::IsolationForest->new(
1731             n_trees => 100,
1732             sample_size => 256,
1733             seed => 42,
1734             );
1735             $iforest->fit(\@data);
1736              
1737             my $scores = $iforest->score_samples(\@data); # arrayref, each in (0,1]
1738             my $flags = $iforest->predict(\@data, 0.6); # arrayref of 0/1
1739              
1740             # Save and reload
1741             $iforest->save('model.json');
1742             my $reloaded = Algorithm::Classifier::IsolationForest->load('model.json');
1743              
1744             # Extended Isolation Forest (oblique hyperplane splits)
1745             my $eif = Algorithm::Classifier::IsolationForest->new(
1746             mode => 'extended',
1747             seed => 42,
1748             );
1749             $eif->fit(\@data);
1750              
1751             # Parallel training (fork-based, Unix-like platforms): build the
1752             # n_trees across several worker processes.
1753             my $iforest = Algorithm::Classifier::IsolationForest->new(
1754             n_trees => 200,
1755             sample_size => 256,
1756             seed => 42,
1757             parallel_fit => 4, # 4 forked workers
1758             );
1759             $iforest->fit(\@data);
1760              
1761             # Pre-pack a dataset to skip the per-call input-walk cost when the
1762             # same data gets scored many times (interactive tuning, dashboards).
1763             my $packed = $iforest->pack_data(\@data);
1764             my $scores = $iforest->score_samples($packed);
1765             my $flags = $iforest->predict($packed, 0.6);
1766              
1767             # Get scores and labels as two flat arrayrefs in one call -- cheaper
1768             # than score_predict_samples when you don't need the paired shape.
1769             my ($s, $l) = $iforest->score_predict_split(\@data, 0.6);
1770              
1771             =head1 DESCRIPTION
1772              
1773             Isolation Forest (Liu, Fei Tony & Ting, Kai & Zhou, Zhi-Hua, 2008) detects anomalies by random
1774             partitioning rather than by modelling normal points. Each tree repeatedly
1775             splits the data. Points that get isolated after only a few splits are likely
1776             anomalies. The score is the average isolation depth across many trees,
1777             normalised so values approach 1 for anomalies and stay below 0.5 for normal
1778             points.
1779              
1780             In extended mode the module implements the Extended Isolation Forest
1781             variant. Each split is a random hyperplane instead of an axis-aligned cut,
1782             which removes the rectangular, axis-aligned bias in the score field and
1783             tends to help on elongated or multi-modal data.
1784              
1785             With C<< voting => 'majority' >> the module implements the Majority Voting
1786             Isolation Forest (MVIForest) aggregation: each tree votes a sample
1787             anomalous or normal against the decision threshold and the label is the
1788             majority of the votes, with prediction stopping early once the majority is
1789             reached. Trees are built identically either way, so this composes with
1790             both axis and extended mode, and an existing model can be flipped between
1791             the two modes with L without refitting; see C under
1792             L.
1793              
1794             psi referenced below is ψ or the pitchfork math symbol referenced in the paper,
1795             Liu, Fei Tony & Ting, Kai & Zhou, Zhi-Hua. (2008). Isolation Forest. 413 - 422. 10.1109/ICDM.2008.17.
1796              
1797             ... or max samples.
1798              
1799             L
1800              
1801             =head1 NATIVE ACCELERATION (Inline::C and OpenMP)
1802              
1803             Both the scoring hot path (C, C, C,
1804             C, and C) and the C
1805             tree builder are automatically accelerated through
1806             L when it is installed and a working C compiler is reachable.
1807             If the toolchain also accepts C<-fopenmp> and can link against
1808             C, the per-point tree walk runs in parallel across all
1809             available CPU cores using OpenMP, and the extended-mode oblique dot
1810             product is vectorised via C<#pragma omp simd> -- which on modern x86
1811             compilers translates to an unrolled FMA / AVX gather chain that's
1812             substantially faster for high-feature-count extended models.
1813              
1814             C's tree builder (subsampling plus the recursive axis/oblique
1815             split search) runs in C the same way when C is on, replacing the
1816             per-node Perl arrayref copying with plain int-array partitioning --
1817             typically an order of magnitude faster, and dramatically more so at
1818             higher feature counts where the pure-Perl per-cell loop dominates. Its
1819             random draws go through the same generator C/C use
1820             internally, in the same call order the pure-Perl builder uses, so a
1821             given C produces bit-identical trees whether C is on or
1822             off -- switching backends changes only how fast the model is built, not
1823             the model itself. On perls whose NV is wider than a C double
1824             (C<-Duselongdouble> / C<-Dusequadmath>) the pure-Perl builder rounds
1825             each stored value to double precision to preserve this parity; axis
1826             mode matches exactly, while extended mode can still differ on rare
1827             libm rounding ties (double vs long-double transcendentals).
1828              
1829             By default this C builder is single-threaded per call, because Perl's
1830             RNG state isn't safe to share across OpenMP threads. Two ways to scale
1831             fit() across cores are available (see below for why they don't compose):
1832              
1833             =over 4
1834              
1835             =item * C forks N worker processes, each building its
1836             share of the trees with the (still single-threaded) C builder. Fixed
1837             IPC/serialisation overhead per worker means this can cost more than it
1838             saves once a fit already completes in milliseconds; it's most useful
1839             once a single-process fit is large enough that the fork/Storable
1840             overhead is small relative to the work being split.
1841              
1842             =item * C builds trees across OpenMP threads within a
1843             single process (one tree per thread), using a separate, thread-safe
1844             PRNG seeded per tree index instead of Perl's C. This means
1845             trees built with C are I bit-identical to the
1846             default C path for the same seed -- but a fixed seed and
1847             C still reproduce the same trees regardless of
1848             C or how OpenMP schedules the work. It's off by
1849             default (unlike C/C, which only ever change speed,
1850             this changes which trees get built) and only takes effect when C
1851             is also on and OpenMP is linked in.
1852              
1853             =back
1854              
1855             These two do NOT compose, despite both existing to parallelise fit().
1856             A process that has run any OpenMP region -- including plain
1857             C/C with the default C -- and
1858             then Cs (as C does) hands each child a copy of
1859             libgomp's thread pool whose worker threads did not survive the fork. A
1860             child that then starts its own C<#pragma omp parallel> region (as
1861             C would) tries to reuse that now-invalid pool and
1862             hangs. This is a general limitation of combining C with OpenMP,
1863             not something fixable from Perl, so C's forked workers
1864             always use the single-threaded C builder regardless of
1865             C -- setting both just means C wins and
1866             C has no effect for that call.
1867              
1868             Detection happens once when the module is loaded. When the
1869             distribution was installed with C available, the C backend
1870             was already compiled during C and the installed object is loaded
1871             directly (see L below);
1872             otherwise the backend is compiled on first load and the artefact is
1873             cached under C<_Inline/> and reused on subsequent runs. Five package
1874             variables report what the load picked up:
1875              
1876             $Algorithm::Classifier::IsolationForest::HAS_C # 0/1
1877             $Algorithm::Classifier::IsolationForest::HAS_OPENMP # 0/1
1878             $Algorithm::Classifier::IsolationForest::HAS_SIMD # 0/1 (OpenMP 4.0+)
1879             $Algorithm::Classifier::IsolationForest::OPT_LEVEL # e.g. "-O3 -march=native", '' if HAS_C is 0
1880             $Algorithm::Classifier::IsolationForest::C_SOURCE # 'prebuilt' / 'runtime', '' if HAS_C is 0
1881              
1882             Neither dependency is required. Without C the module falls
1883             back to a pure-Perl implementation that produces identical results, just
1884             slower; without OpenMP the C backend runs single-threaded.
1885              
1886             The bundled C subcommand performs a tiny fit + score and
1887             prints which backend is active (including the build flags below), which
1888             is the recommended way to verify the build picked up the optional
1889             dependencies on a given machine.
1890              
1891             =head2 Compile at install time (the prebuilt object)
1892              
1893             When C is usable while the distribution itself is being
1894             built, C arranges for the C backend to be compiled
1895             once during C and installed alongside the module like any XS
1896             object. At run time that object is loaded directly through
1897             L: no C compiler, no C modules, and no C<_Inline/>
1898             cache directory are needed on the machine the module ends up running
1899             on, and the first-load compile pause disappears entirely.
1900              
1901             On x86-64 hardware from roughly the last decade,
1902             C is a reasonable configure line:
1903             it bakes AVX2 + FMA (without AVX-512) into the prebuilt object, which
1904             can speed up extended-mode scoring (how much is hardware-dependent --
1905             benchmark with C before assuming) while avoiding the
1906             C<-march=native> caveats described under L.
1907             Bit-for-bit result parity with the pure-Perl backend is preserved
1908             either way (see C below).
1909              
1910             The C build flags described below are captured when
1911             C runs -- set them in the environment of I
1912             command, not of C -- and recorded in the generated
1913             C module, which
1914             thereby also fixes what the prebuilt object was compiled with. At run
1915             time the recorded values serve as the defaults, so a process started
1916             with no C variables set uses the prebuilt object as-is.
1917              
1918             Setting C variables at run time keeps working exactly as in
1919             releases without prebuilt support: if the requested flags differ from
1920             the recorded ones, the prebuilt object (compiled with the wrong flags
1921             for the request) is skipped and the module compiles at first load into
1922             C<_Inline/> -- which does need C and a compiler on that
1923             machine. Two related knobs exist:
1924              
1925             =over 4
1926              
1927             =item * C -- ignore the prebuilt object
1928             unconditionally and compile at first load even though the requested
1929             flags match the recorded ones. Useful when the installed object is
1930             suspect (built on a different CPU than it now runs on, linked against a
1931             libgomp that has since changed) or to A/B a fresh local build against
1932             the shipped one.
1933              
1934             =item * C -- internal; set by the generated
1935             Makefile rule that performs the install-time compile. Not meant for
1936             manual use.
1937              
1938             =back
1939              
1940             If the prebuilt object cannot be loaded for any reason (deleted, built
1941             against a different perl, version mismatch after an upgrade), the
1942             module quietly falls through the same chain as always: runtime
1943             Inline::C build first, pure Perl last.
1944              
1945             =head2 Tuning the C build
1946              
1947             These environment variables are read once, the first time the module is
1948             loaded, so they must be set before that -- e.g. in the shell before
1949             running a script, not via C<%ENV> inside the script itself. They are
1950             also read by C to pick the flags baked into the
1951             prebuilt object (see above); at run time they override the recorded
1952             configure-time values, at the price of a runtime compile.
1953              
1954             =over 4
1955              
1956             =item * C -- skip attempting to build the C backend entirely.
1957             Equivalent to constructing every instance with C 0>, but
1958             without needing to touch every call site; useful for a clean pure-Perl
1959             timing baseline, or to avoid the compile attempt's overhead/noise on a
1960             host known to lack a C compiler (the attempt already fails gracefully
1961             without this, so it's a convenience, not a correctness fix).
1962              
1963             =item * C (or C<-O0>/C<-O1>/C<-Os>/C<-Og>/C<-Oz>) -- override
1964             the default C<-O3>, e.g. to shorten build time while iterating, or work
1965             around a miscompile on an unusual toolchain. Invalid values are ignored
1966             with a warning rather than passed through, since this string reaches a
1967             compiler command line.
1968              
1969             =item * CvalueE> -- adds C<-march=EvalueE> so the
1970             compiler can target specific instruction-set extensions (AVX2 gather +
1971             FMA, etc.) for the extended-mode oblique dot product and the fit-time
1972             min/max scan's C<#pragma omp simd> loops. Accepts values like
1973             C, C, or C -- whatever your compiler's
1974             C<-march=> accepts. Also validated (a restricted character set, not
1975             passed through as-is) for the same reason as C. The special
1976             value C (or an empty string) opts out of any arch recorded at
1977             configure time, yielding a plain build. Whenever a C<-march> is in
1978             effect the build also adds C<-ffp-contract=off>: with FMA available
1979             the compiler would otherwise contract C into fused
1980             multiply-adds whose different rounding breaks the guarantee that
1981             C 1> and C 0> build bit-identical trees (the
1982             C<-march> speedup comes from vectorization, not contraction, so this
1983             costs essentially nothing).
1984              
1985             =item * C -- shorthand for C; ignored if
1986             C is also set. Prefer a specific C value over this on
1987             a machine you don't control exclusively (a shared build host, a
1988             container base image): blanket C<-march=native> pulls in whatever
1989             instruction sets the build host happens to have, including AVX-512 on
1990             some Intel CPUs -- which is known to trigger clock throttling under
1991             sustained heavy use and can make throughput I than a
1992             conservative target like C (AVX2, no AVX-512). If in doubt,
1993             benchmark both before committing to one.
1994              
1995             =item * C -- build (or select) the serial C backend: the
1996             OpenMP compile attempt is skipped entirely, so the resulting object has
1997             no libgomp linkage and never starts an OpenMP runtime inside the
1998             process. This differs from C, which merely runs the
1999             parallel code on one thread but still loads libgomp. Set at
2000             C time it yields a serial prebuilt object; set at run
2001             time against an OpenMP prebuilt install it triggers a runtime serial
2002             build (needing a compiler). An explicit C re-enables
2003             OpenMP over a serial configure-time default.
2004              
2005             =back
2006              
2007             Whichever of these are used, the cached artefact under C<_Inline/> is
2008             pinned to that build's instruction set -- delete C<_Inline/> (or use a
2009             separate one per host) if the directory is shared across machines with
2010             different CPUs, or a stale binary built for a narrower instruction set
2011             than the current host will simply keep being reused.
2012              
2013             =head2 Tuning the OpenMP runtime
2014              
2015             These are standard OpenMP environment variables libgomp already reads
2016             at run time (set before running your script, no module-specific
2017             handling needed) -- listed here because they matter most for exactly
2018             the workloads this module has: C's per-point parallel
2019             loop and C's per-tree parallel loop.
2020              
2021             =over 4
2022              
2023             =item * C -- caps how many threads a parallel region
2024             uses. Useful to leave headroom for other work sharing the machine, or
2025             to pin down C reproducibility checks (see its docs
2026             above: results don't depend on this, but it's a natural thing to vary
2027             when confirming that).
2028              
2029             =item * C / C -- on multi-socket
2030             or otherwise NUMA machines, pins each thread to a core near where its
2031             data already lives instead of letting the OS scheduler migrate threads
2032             across sockets mid-run. Both C (each thread scans its own
2033             slice of the packed query buffer) and C (each thread
2034             builds one tree from packed training data) benefit from this when the
2035             input is large enough to not fit comfortably in one socket's cache.
2036              
2037             =back
2038              
2039             These cost nothing to try -- unlike C/C, they're
2040             read fresh every run, not baked into a cached binary, so there's no
2041             downside to experimenting per invocation.
2042              
2043             =head1 GENERAL METHODS
2044              
2045             =head2 new(%args)
2046              
2047             Inits the object.
2048              
2049             - n_trees :: number of isolation trees in the ensemble
2050             default :: 100
2051              
2052             - sample_size :: sub-sample size used to build each tree... max samples
2053             default :: 256
2054              
2055             - max_depth :: per-tree height limit... if not defined is set to ceil(log2(psi))
2056             default :: undef
2057              
2058             - seed :: optional integer to seed srand with for reproducible trees...
2059             see perldoc -f srand for more info. This number is processed via abs(int()).
2060             default :: undef
2061              
2062             - mode :: if it should be IF or EIF
2063             axis :: classic axis-parallel splits (IF)
2064             extended :: oblique hyperplane splits (EIF)
2065             default :: axis
2066              
2067             - extension_level :: extended mode only... how many features take partin each
2068             split. 0 behaves like a single-feature (axis) cut; the
2069             maximum (n_features - 1) uses every varying feature. undef
2070             => maximum. Clamped to [0, n_features - 1] at fit time.
2071              
2072             - contamination :: expected fraction of anomalies, in (0, 0.5]. When given,
2073             fit() learns a score threshold that flags this fraction of
2074             the training set, and predict() uses it by default. undef
2075             => no learned threshold (predict() falls back to 0.5).
2076             default :: undef
2077              
2078             - missing :: how fit() treats undef (missing) feature cells. Scoring always
2079             tolerates undef regardless of this setting; it governs fit().
2080             die :: croak from fit() if the training data contains any
2081             undef cell. Scoring still maps undef to 0 (the
2082             long-standing behaviour), so a model fitted on clean
2083             data can still score rows with missing features.
2084             zero :: treat a missing cell as the value 0, at fit and score.
2085             impute :: replace a missing cell with the per-feature mean (or
2086             median, see impute_with) learned from the present
2087             values at fit time. The fill vector is stored on the
2088             model and reused for scoring and persistence.
2089             nan :: build feature ranges from present values only and route
2090             a point missing the split feature to the right child,
2091             consistently at fit and score time. Missingness is
2092             preserved as signal rather than filled.
2093             default :: die
2094              
2095             - impute_with :: 'mean' or 'median'; the statistic used to compute the
2096             per-feature fill under missing => 'impute'. Ignored otherwise.
2097             default :: mean
2098              
2099             - voting :: how the per-tree results are aggregated at scoring time.
2100             Trees are built identically in both settings -- only aggregation
2101             changes -- so the knob composes with either mode (axis or
2102             extended) and an existing model may switch it after the fact with
2103             set_voting() (which relearns a contamination threshold for the
2104             new mode).
2105             mean :: classic Isolation Forest: a sample's path lengths
2106             across all trees are averaged and normalised into
2107             one anomaly score; predict() thresholds that score.
2108             majority :: Majority Voting Isolation Forest (MVIForest;
2109             Chabchoub, Togbe, Boly & Chiky 2022 -- see
2110             REFERENCES). Each tree scores the sample on its own
2111             (s_i = 2**(-h_i / c(psi))) and votes it anomalous
2112             when s_i >= the decision threshold; predict() flags
2113             the sample when more than half of the trees
2114             (int(n_trees/2) + 1) vote anomalous, and stops
2115             walking trees per sample as soon as the outcome is
2116             decided. The threshold argument/default of the
2117             predict methods is therefore the PER-TREE cutoff
2118             here, not a forest-level score cutoff.
2119             score_samples() returns the fraction of trees
2120             voting anomalous -- still in [0, 1], but discrete
2121             in steps of 1/n_trees. contamination composes: fit()
2122             learns the per-tree cutoff that flags the requested
2123             fraction of the training set.
2124             default :: mean
2125              
2126             - parallel_fit :: positive integer N => build the trees across N forked
2127             worker processes during fit(). Each worker gets a derived seed
2128             (parent seed + worker_id * 1009) so the parallel fit is
2129             reproducible across runs at fixed worker count -- but the trees
2130             produced are NOT bit-identical to a serial fit with the same
2131             seed, because the RNG draws happen in a different order.
2132             Inference is unaffected. Falls back silently to serial on
2133             platforms without a real fork() (e.g. Windows without Cygwin).
2134             default :: undef (serial)
2135              
2136             - use_c :: boolean, override whether the Inline::C backend is used for
2137             both scoring and fit()'s tree builder. When false the instance
2138             falls back to pure Perl for both even if the C backend compiled
2139             successfully. When true (or unset) the C backend is used if
2140             available ($HAS_C). fit() with use_c on produces bit-identical
2141             trees to use_c off for the same seed -- only build speed differs.
2142             default :: $HAS_C
2143              
2144             - use_openmp :: boolean, override whether OpenMP parallel scoring is
2145             used inside score_all_xs(). When false the C tree walk runs
2146             single-threaded even if OpenMP was linked in. Ignored when
2147             use_c is false (pure Perl has no OpenMP path).
2148             default :: $HAS_OPENMP
2149              
2150             - use_openmp_fit :: boolean, build fit()'s trees across OpenMP threads
2151             (one tree per thread) instead of the single-threaded C builder.
2152             Opt-in and off by default: unlike use_c/use_openmp, this changes
2153             which trees get built. Perl's RNG isn't safe to call from
2154             multiple OS threads sharing one interpreter, so this path seeds
2155             an independent PRNG per tree from the tree index rather than
2156             Drand01() -- trees differ from the use_c (single-threaded)
2157             and pure-Perl paths even with the same seed, though a fixed
2158             seed and n_trees still reproduce the same trees regardless of
2159             OMP_NUM_THREADS or scheduling. Does NOT compose with
2160             parallel_fit: a forked child starting its own OpenMP region
2161             after the parent process has used OpenMP for anything can
2162             hang (a general fork()+libgomp limitation), so parallel_fit's
2163             workers always use the single-threaded C builder regardless
2164             of this setting -- setting both just means parallel_fit wins.
2165             Ignored (clamped to 0) when use_c is false or OpenMP isn't
2166             linked in.
2167             default :: 0
2168              
2169             Note: log2 under Perl is as below...
2170              
2171             log($psi) / log(2)
2172              
2173             =cut
2174              
2175             sub new {
2176 190     190 1 21739672 my ( $class, %args ) = @_;
2177              
2178 190   100     1225 my $mode = $args{mode} // 'axis';
2179 190 100 100     1031 croak "mode must be 'axis' or 'extended'"
2180             unless $mode eq 'axis' || $mode eq 'extended';
2181              
2182             # How fit() treats undef (missing) feature cells. Scoring always
2183             # tolerates undef regardless of this setting -- it governs fit only.
2184             # die :: croak if the training data contains any undef cell (default)
2185             # zero :: treat a missing cell as the value 0
2186             # impute :: replace a missing cell with the per-feature mean/median
2187             # learned from the present values at fit time
2188             # nan :: build ranges over present values only and route a point
2189             # missing the split feature consistently to one branch, at
2190             # both fit and score time
2191 189   100     806 my $missing = $args{missing} // 'die';
2192 189 100       1621 croak "missing must be one of: die, zero, impute, nan"
2193             unless $missing =~ /\A(?:die|zero|impute|nan)\z/;
2194              
2195 188   100     771 my $impute_with = $args{impute_with} // 'mean';
2196 188 100       988 croak "impute_with must be 'mean' or 'median'"
2197             unless $impute_with =~ /\A(?:mean|median)\z/;
2198              
2199             # How per-tree results are aggregated at scoring time. Trees are
2200             # built identically either way -- this knob never touches fit()'s
2201             # forest, only how score/predict combine the per-tree path lengths.
2202             # mean :: classic IForest: average path length across trees,
2203             # normalised into one score (the default)
2204             # majority :: MVIForest (Chabchoub et al. 2022): each tree votes
2205             # anomalous/normal against the decision threshold and
2206             # the label is the majority of the tree votes
2207 187   100     712 my $voting = $args{voting} // 'mean';
2208 187 100       912 croak "voting must be 'mean' or 'majority'"
2209             unless $voting =~ /\A(?:mean|majority)\z/;
2210              
2211 186 100       488 if ( defined( $args{seed} ) ) {
2212 154         437 $args{seed} = abs( int( $args{seed} ) );
2213             }
2214              
2215             # Clamp the accel knobs against what the build actually has. Passing
2216             # use_c => 1 on a machine where Inline::C never compiled would otherwise
2217             # leave score_samples() calling an undefined XS sub at first use.
2218             # OpenMP is meaningless without the C tree walk, so force it off
2219             # whenever the C backend is off -- matches the documented
2220             # "Ignored when use_c is false" semantics.
2221             my $use_c
2222             = defined $args{use_c}
2223 186 100 100     870 ? ( $args{use_c} && $HAS_C ? 1 : 0 )
    100          
2224             : $HAS_C;
2225             my $use_openmp
2226             = defined $args{use_openmp}
2227 186 100 100     450 ? ( $args{use_openmp} && $HAS_OPENMP ? 1 : 0 )
    100          
2228             : $HAS_OPENMP;
2229 186 100       412 $use_openmp = 0 unless $use_c;
2230              
2231             # Opt-in only (default 0, not $HAS_OPENMP): this path changes which
2232             # trees fit() builds (see docs above), unlike use_c/use_openmp which
2233             # only change speed. Clamped the same way use_openmp is.
2234 186 100 33     1106 my $use_openmp_fit = ( $args{use_openmp_fit} && $HAS_OPENMP && $use_c ) ? 1 : 0;
2235              
2236             my $self = {
2237             n_trees => $args{n_trees} // 100,
2238             sample_size => $args{sample_size} // 256,
2239             max_depth => $args{max_depth}, # undef => auto
2240             seed => $args{seed}, # undef => non-deterministic
2241             mode => $mode,
2242             extension_level => $args{extension_level}, # undef => max, resolved in fit()
2243             contamination => $args{contamination}, # undef => no learned threshold
2244             parallel_fit => $args{parallel_fit}, # undef/0/1 => serial; N>1 => fork
2245             missing => $missing, # die|zero|impute|nan
2246             impute_with => $impute_with, # mean|median (impute mode only)
2247             voting => $voting, # mean|majority (scoring-time aggregation)
2248             missing_fill => undef, # per-feature fill, learned in fit() if impute
2249             _use_c => $use_c,
2250             _use_openmp => $use_openmp,
2251             _use_openmp_fit => $use_openmp_fit,
2252             threshold => undef, # learned in fit() if contamination set
2253             trees => [],
2254             c_psi => undef, # c(psi), set during fit()
2255             n_features => undef,
2256             feature_names => $args{feature_names}, # optional arrayref of per-feature labels
2257 186   100     2845 };
      100        
2258              
2259 186 100       917 croak "n_trees must be >= 1" unless $self->{n_trees} >= 1;
2260 185 100       783 croak "sample_size must be >= 1" unless $self->{sample_size} >= 1;
2261             croak "extension_level must be >= 0"
2262 184 100 100     745 if defined $self->{extension_level} && $self->{extension_level} < 0;
2263             croak "contamination must be a number in (0, 0.5]"
2264             if defined $self->{contamination}
2265 183 100 100     1032 && !( $self->{contamination} > 0 && $self->{contamination} <= 0.5 );
      100        
2266             croak "parallel_fit must be a positive integer"
2267             if defined $self->{parallel_fit}
2268 180 100 66     922 && ( $self->{parallel_fit} !~ /^\d+$/ || $self->{parallel_fit} < 1 );
      66        
2269              
2270 178         906 return bless $self, $class;
2271             } ## end sub new
2272              
2273             =head2 decision_threshold
2274              
2275             The score cutoff C uses by default; undef unless C was
2276             set.
2277              
2278             =cut
2279              
2280 17     17 1 7243 sub decision_threshold { return $_[0]->{threshold} }
2281              
2282             =head2 set_voting
2283              
2284             Switches the scoring-time aggregation between C<'mean'> and C<'majority'> on an
2285             existing model and returns C<$self> (so it chains). The forest itself is
2286             identical in both modes -- only the way per-tree results are combined changes
2287             -- so this never rebuilds a single tree.
2288              
2289             $iforest->set_voting('majority');
2290             $iforest->set_voting('mean', \@training_data);
2291              
2292             The one thing that does not carry over is a C-learned
2293             L. That cutoff is a quantile of whichever per-point
2294             quantity the mode thresholds against -- the averaged anomaly score under
2295             C<'mean'>, the per-tree majority pivot under C<'majority'> -- and those live in
2296             different spaces, so a threshold learned in one mode flags the wrong fraction
2297             in the other. When the model was fitted with C, C
2298             therefore relearns the threshold for the target mode, which requires the
2299             original training data to be passed as the second argument (the model does not
2300             retain it). Switching a model that had no C needs no data:
2301             C falls back to C<0.5>, which is meaningful in both modes.
2302              
2303             Passing the current mode is a no-op (returns immediately, no data needed).
2304             Calling this before L just records the mode for the eventual fit.
2305              
2306             =cut
2307              
2308             sub set_voting {
2309 9     9 1 790 my ( $self, $voting, $data ) = @_;
2310              
2311 9 100 66     272 croak "set_voting: voting must be 'mean' or 'majority'"
2312             unless defined $voting && $voting =~ /\A(?:mean|majority)\z/;
2313              
2314 8 100       33 return $self if $self->{voting} eq $voting;
2315              
2316             # A learned threshold only exists once a contamination-fitted model has
2317             # been fit(); that value is mode-specific and must be relearned against
2318             # the same training set (see _learn_contamination_threshold). Everything
2319             # else -- pre-fit models, and fitted models without contamination -- just
2320             # flips the knob; predict()'s 0.5 fallback is valid in either mode.
2321 7   66     40 my $fitted = ref $self->{trees} eq 'ARRAY' && @{ $self->{trees} };
2322 7   100     29 my $recalibrate = $fitted && defined $self->{contamination};
2323 7 100       23 if ($recalibrate) {
2324 4 100 66     284 croak "set_voting: switching a contamination-fitted model requires "
2325             . "the original training data as the second argument to "
2326             . "recalibrate the decision threshold"
2327             unless ref $data eq 'ARRAY' && @$data;
2328             }
2329              
2330 6         13 $self->{voting} = $voting;
2331 6 100       43 $self->_learn_contamination_threshold($data) if $recalibrate;
2332              
2333 6         29 return $self;
2334             } ## end sub set_voting
2335              
2336             =head2 feature_names
2337              
2338             Returns the arrayref of feature name strings stored with the model, or undef
2339             if none were provided at fit time.
2340              
2341             my $names = $iforest->feature_names;
2342              
2343             =cut
2344              
2345 1     1 1 22 sub feature_names { return $_[0]->{feature_names} }
2346              
2347             =head2 fit
2348              
2349             Trains the model on the specified data.
2350              
2351             The data taken is an array of arrays. Each sub-array is one sample and must
2352             contain one or more numeric features. All samples must have the same number
2353             of features. There is no upper limit on dimensionality.
2354              
2355             @training_data = (
2356             [ 3, 5 ],
2357             [ 2.3, 1 ],
2358             [ 5, 9 ],
2359             ...
2360             );
2361              
2362             # Three-feature example
2363             @training_data = (
2364             [ 1.0, 2.0, 3.0 ],
2365             [ 1.1, 1.9, 3.1 ],
2366             ...
2367             );
2368              
2369             Below shows an example of building a gaussian cluster and using that for training.
2370              
2371             # so it is reproducible
2372             srand(7);
2373              
2374             # build a gaussian cluster and add a handful of outliers...
2375              
2376             use constant PI => 3.14159265358979;
2377             sub gaussian {
2378             my ($mu, $sigma) = @_;
2379             my $u1 = rand() || 1e-12;
2380             my $u2 = rand();
2381             my $z = sqrt(-2 * log($u1)) * cos(2 * PI * $u2);
2382             return $mu + $sigma * $z;
2383             }
2384              
2385             # add some normal items
2386             for (1 .. 500) {
2387             push @data, [ gaussian(0, 1), gaussian(0, 1) ];
2388             push @truth, 0;
2389             }
2390             # add some outliers
2391             for (1 .. 20) {
2392             my $angle = rand() * 2 * PI;
2393             my $radius = 5 + rand() * 3; # distance 5..8 from the origin
2394             push @data, [ $radius * cos($angle), $radius * sin($angle) ];
2395             push @truth, 1;
2396             }
2397              
2398             $iforest->fit(\@data);
2399              
2400             =cut
2401              
2402             sub fit {
2403 159     159 1 9679 my ( $self, $data ) = @_;
2404              
2405 159 100 100     1579 croak "fit() expects a non-empty arrayref of samples"
2406             unless ref $data eq 'ARRAY' && @$data;
2407             croak "each sample must be an arrayref of features"
2408 153 100 100     922 unless ref $data->[0] eq 'ARRAY' && @{ $data->[0] };
  151         1036  
2409              
2410 149         245 my $n_features = scalar @{ $data->[0] };
  149         330  
2411 149         500 $self->{n_features} = $n_features;
2412              
2413             # Apply the missing-value strategy before any tree is built. Depending
2414             # on the strategy this either croaks (die), returns a dense copy with
2415             # undef cells filled (zero/impute), or passes the data through with
2416             # undef preserved for the split logic to route (nan). Everything below
2417             # trains on $train, never the raw $data.
2418 149         755 my $train = $self->_prepare_fit_data($data);
2419              
2420 143         338 my $n = scalar @$train;
2421              
2422             # The sub-sample cannot be larger than the data set itself.
2423 143         760 my $psi = min( $self->{sample_size}, $n );
2424 143         555 $self->{c_psi} = _c($psi);
2425 143         368 $self->{psi_used} = $psi;
2426              
2427             # Resolve the extension level against the data's dimensionality.
2428 143 100       436 if ( $self->{mode} eq 'extended' ) {
2429 32         75 my $max_ext = $n_features - 1;
2430             my $ext
2431             = defined $self->{extension_level}
2432             ? $self->{extension_level}
2433 32 100       123 : $max_ext;
2434 32 50       117 $ext = 0 if $ext < 0;
2435 32 100       147 $ext = $max_ext if $ext > $max_ext;
2436 32         126 $self->{extension_level_used} = $ext;
2437             } else {
2438 111         324 $self->{extension_level_used} = undef;
2439             }
2440              
2441             # Height limit: the average tree height ceil(log2(psi)). Past this depth the
2442             # remaining points are scored using the c(size) adjustment instead.
2443             my $limit
2444             = defined $self->{max_depth}
2445             ? $self->{max_depth}
2446 143 50       952 : ceil( log($psi) / log(2) );
2447 143 50       446 $limit = 1 if $limit < 1;
2448 143         515 $self->{max_depth_used} = $limit;
2449              
2450 143 50       667 srand( $self->{seed} ) if defined $self->{seed};
2451              
2452 143         311 my $workers = $self->{parallel_fit};
2453 143 100 100     1149 if ( defined $workers
    100 66        
    100 66        
      66        
2454             && $workers > 1
2455             && $self->{n_trees} > 1
2456             && _fork_supported() )
2457             {
2458 8         42 $self->{trees} = $self->_fit_trees_parallel( $train, $psi, $limit, $workers );
2459             } elsif ( $self->{_use_c} && $self->{_use_openmp_fit} ) {
2460 7         39 $self->{trees} = $self->_build_forest_openmp( $train, $psi, $limit, $self->{n_trees} );
2461             } elsif ( $self->{_use_c} ) {
2462             $self->{trees}
2463 79         5123 = $self->_build_forest_c( $train, $psi, $limit, $self->{n_trees} );
2464             } else {
2465 49         78 my @trees;
2466 49         145 for ( 1 .. $self->{n_trees} ) {
2467 2249         6368 my $sample = _subsample( $train, $psi );
2468 2249         5930 push @trees, $self->_build_tree( $sample, 0, $limit );
2469             }
2470 49         236 $self->{trees} = \@trees;
2471             }
2472              
2473             # On a re-fit, packed scoring buffers from the previous fit are still
2474             # sitting on the object; score_samples() below would pick them up and
2475             # learn the contamination threshold against the OLD forest. Drop them
2476             # so the training-set scoring runs pure-Perl against the trees just
2477             # built; _rebuild_c_trees repacks from the new trees at the end.
2478 143         874 delete @$self{qw(_c_nodes _c_coef_idx _c_coef_val)};
2479              
2480             # If a contamination rate was requested, learn the score cutoff that flags
2481             # that fraction of the training set. The threshold lands midway inside a
2482             # real gap between flagged and unflagged training scores (ties at the
2483             # k-boundary shift the cut to the nearest gap -- see
2484             # _threshold_from_ranked), so it sits strictly between attainable values:
2485             # unambiguous and robust to the tiny float rounding introduced by JSON
2486             # serialisation.
2487             #
2488             # Under voting => 'majority' the value predict() thresholds against is
2489             # the PER-TREE score, so the quantity to rank is each training point's
2490             # majority pivot -- the per-tree cutoff at which that point loses its
2491             # majority (see _majority_pivot_scores). A point is flagged iff its
2492             # pivot >= threshold, exactly the relation the mean-mode score has, so
2493             # the midpoint selection below serves both modes unchanged.
2494             $self->_learn_contamination_threshold($train)
2495 143 100       656 if defined $self->{contamination};
2496              
2497 143 100       833 $self->_rebuild_c_trees() if $self->{_use_c};
2498 143         1492 return $self;
2499             } ## end sub fit
2500              
2501             =head2 pack_data(\@data)
2502              
2503             Returns an opaque, blessed wrapper around the input dataset that the
2504             scoring methods can use directly, skipping the per-call work of walking
2505             the arrayref-of-arrayrefs and converting each cell into a double. At
2506             high feature counts this is a meaningful win when the same dataset is
2507             scored repeatedly (e.g. interactive threshold tuning, dashboards,
2508             plotting that updates as parameters change).
2509              
2510             Requires the Inline::C backend; croaks if C is false.
2511              
2512             my $packed = $forest->pack_data(\@data);
2513              
2514             # Now any of these accept either an arrayref or the packed wrapper:
2515             my $scores = $forest->score_samples($packed);
2516             my $flags = $forest->predict($packed, 0.6);
2517             my ($s, $l) = $forest->score_predict_split($packed);
2518              
2519             The wrapper has C and C accessors for introspection.
2520             The feature count is matched against the model on every call; passing a
2521             packed dataset built for a different feature count is a fatal error.
2522              
2523             =cut
2524              
2525             =head2 path_lengths(\@data)
2526              
2527             Returns an arrayref of the mean isolation depth per sample, for inspection.
2528              
2529             my $lengths = $forest->path_lengths(\@data);
2530              
2531             print "x, y, length\n";
2532              
2533             my $int=0;
2534             while (defined($data[$int])) {
2535             print $data[$int][0].', '.$data[$int][1].', '.$lengths->[$int]."\n";
2536              
2537             $int++;
2538             }
2539              
2540             =cut
2541              
2542             sub path_lengths {
2543 6820     6820 1 24224 my ( $self, $data ) = @_;
2544 6820         16941 $self->_check_fitted;
2545 6818         11833 my $trees = $self->{trees};
2546 6818         10978 my $t = scalar @$trees;
2547              
2548 6818 50 66     22118 if ( $self->{_use_c} && $self->{_c_nodes} ) {
2549 6817         13551 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2550 6817         13022 my $sums_packed = "\0" x ( $n_pts * 8 );
2551             score_all_xs(
2552             $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2553             $x_packed, $sums_packed, $n_pts,
2554             $nf, $t, $self->{_use_openmp}
2555 6817         205978 );
2556 6817         12293 my $result = [];
2557 6817         22254 finalize_path_lengths_xs( $sums_packed, $n_pts, $t + 0.0, $result );
2558 6817         26651 return $result;
2559             } ## end if ( $self->{_use_c} && $self->{_c_nodes} )
2560              
2561 1         5 $data = $self->_prepare_perl_input($data);
2562 1 50       4 my $nan = $self->{missing} eq 'nan' ? 1 : 0;
2563              
2564             # Pure-Perl fallback (tree-outer, sample-inner for cache locality).
2565 1         6 my @sums = (0) x @$data;
2566 1         2 for my $tree (@$trees) {
2567 60         102 for my $i ( 0 .. $#$data ) {
2568 6000         8201 $sums[$i] += _path_length( $data->[$i], $tree, 0, $nan );
2569             }
2570             }
2571 1         15 return [ map { $_ / $t } @sums ];
  100         140  
2572             } ## end sub path_lengths
2573              
2574             =head2 predict(\@data, $threshold)
2575              
2576             Returns an arrayref of 0/1 labels for the specified data.
2577              
2578             If threshold is not specified it uses the contamination-learned cutoff (if
2579             C was called with C), otherwise 0.5.
2580              
2581             Under C<< voting => 'majority' >> the threshold is the per-tree score
2582             cutoff each tree votes against, and a sample is labelled 1 when more than
2583             half of the trees (C) vote it anomalous. Tree walking
2584             stops per sample as soon as the outcome is decided, so this is typically
2585             cheaper than scoring.
2586              
2587             my $results = $forest->predict(\@data, $threshold);
2588              
2589             print "x, y, result\n";
2590              
2591             my $int=0;
2592             while (defined($data[$int])) {
2593             print $data[$int][0].', '.$data[$int][1].', '.$results->[$int]."\n";
2594              
2595             $int++;
2596             }
2597              
2598             =cut
2599              
2600             sub predict {
2601 14230     14230 1 109961 my ( $self, $data, $threshold ) = @_;
2602             $threshold
2603             = defined $threshold ? $threshold
2604             : defined $self->{threshold} ? $self->{threshold}
2605 14230 100       26167 : 0.5;
    100          
2606 14230         34852 $self->_check_fitted;
2607              
2608             # Majority voting: $threshold is the PER-TREE score cutoff and the
2609             # label is the majority of the tree votes (int(t/2) + 1). Both the C
2610             # and the Perl loop stop walking a sample's remaining trees as soon
2611             # as the outcome is decided -- MVIForest's "stop at majority" saving.
2612 14228 100       31814 if ( $self->{voting} eq 'majority' ) {
2613 18         32 my $trees = $self->{trees};
2614 18         40 my $t = scalar @$trees;
2615 18         107 my $cut = _depth_cut( $threshold, $self->{c_psi} );
2616 18         50 my $maj = _min_votes($t);
2617              
2618 18 50 66     113 if ( $self->{_use_c} && $self->{_c_nodes} ) {
2619 16         57 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2620 16         54 my $labels_packed = "\0" x ( $n_pts * 8 );
2621             vote_all_xs( $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2622 16         8834 $x_packed, $labels_packed, $n_pts, $nf, $t, $cut, $maj, $self->{_use_openmp} );
2623 16         67 my $result = [];
2624 16         112 vote_labels_xs( $labels_packed, $n_pts, $result );
2625 16         82 return $result;
2626             }
2627              
2628 2         11 my $rows = $self->_prepare_perl_input($data);
2629 2 50       9 my $nan = $self->{missing} eq 'nan' ? 1 : 0;
2630 2         5 my @labels;
2631 2         8 for my $x (@$rows) {
2632 126         144 my $votes = 0;
2633 126         134 my $label = 0;
2634 126         197 for my $ti ( 0 .. $t - 1 ) {
2635 3397 100       4383 if ( _path_length( $x, $trees->[$ti], 0, $nan ) <= $cut ) {
2636 1003         1077 $votes++;
2637 1003 100       1303 if ( $votes >= $maj ) { $label = 1; last }
  9         10  
  9         12  
2638             }
2639 3388 100       5139 last if $votes + ( $t - 1 - $ti ) < $maj;
2640             }
2641 126         238 push @labels, $label;
2642             } ## end for my $x (@$rows)
2643 2         19 return \@labels;
2644             } ## end if ( $self->{voting} eq 'majority' )
2645              
2646             # Fast path: threshold the raw path-length sums directly, skipping the
2647             # per-point exp() and the intermediate scores arrayref.
2648             # Derivation: score = exp(-sum * log(2) / (c*t))
2649             # so score >= T iff sum <= -log(T) * c * t / log(2)
2650             # Only valid for a normal threshold in (0, 1) and a positive c.
2651 14210 100 66     94956 if ( $self->{_use_c}
      33        
      66        
      100        
2652             && $self->{_c_nodes}
2653             && $self->{c_psi} > 0
2654             && $threshold > 0
2655             && $threshold < 1 )
2656             {
2657 14193         24106 my $trees = $self->{trees};
2658 14193         23492 my $t = scalar @$trees;
2659 14193         23125 my $c = $self->{c_psi};
2660 14193         28598 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2661 14193         27507 my $sums_packed = "\0" x ( $n_pts * 8 );
2662             score_all_xs(
2663             $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2664             $x_packed, $sums_packed, $n_pts,
2665             $nf, $t, $self->{_use_openmp}
2666 14193         421399 );
2667 14193         33553 my $sum_threshold = -log($threshold) * $c * $t / log(2);
2668 14193         22786 my $result = [];
2669 14193         46547 predict_sums_xs( $sums_packed, $n_pts, $sum_threshold, $result );
2670 14193         55271 return $result;
2671             } ## end if ( $self->{_use_c} && $self->{_c_nodes} ...)
2672              
2673             # Fallback: edge thresholds, c==0, or no C backend.
2674 17         81 my $scores = $self->score_samples( $self->_to_arrayref($data) );
2675 17 100       66 return [ map { $_ >= $threshold ? 1 : 0 } @$scores ];
  1285         1917  
2676             } ## end sub predict
2677              
2678             =head2 predict_tagged(\%row, $threshold)
2679              
2680             Predicts whether a single sample is an anomaly using a hashref of named
2681             feature values. The model must have been fitted (or loaded from a model
2682             that was fitted) with feature names stored via C.
2683              
2684             C<$threshold> defaults the same way as in C.
2685              
2686             Returns a scalar 1 (anomaly) or 0 (normal).
2687              
2688             my $label = $forest->predict_tagged(
2689             { cpu => 0.9, mem => 0.4, disk => 0.1 },
2690             );
2691              
2692             Croaks if the model has no stored feature names, if the hashref contains a
2693             key that is not a known feature name, or if a feature name is absent from the
2694             hashref.
2695              
2696             =cut
2697              
2698             =head2 tagged_row_to_array(\%row, $caller)
2699              
2700             Validates a hashref of named feature values against the model's stored
2701             C and returns a positional arrayref ready to pass to any
2702             of the scoring or prediction methods.
2703              
2704             C<$caller> is a string used in error messages to identify which method
2705             triggered the validation (pass the calling method's name).
2706              
2707             my $vec = $forest->tagged_row_to_array(\%row, 'my_method');
2708             # returns e.g. [0.9, 0.4, 0.1] ordered by feature_names
2709              
2710             Croaks if:
2711              
2712             =over 4
2713              
2714             =item * C<$row> is not a hashref
2715              
2716             =item * the model has no stored C
2717              
2718             =item * the hashref contains a key that is not a known feature name
2719              
2720             =item * a feature name is absent from the hashref
2721              
2722             =back
2723              
2724             =cut
2725              
2726             sub tagged_row_to_array {
2727 53     53 1 15261 my ( $self, $row, $caller ) = @_;
2728 53 100       1314 croak "$caller requires a hashref"
2729             unless ref $row eq 'HASH';
2730             croak "this model has no stored feature_names; " . "refit with -t tags or pass feature_names to new()"
2731             unless defined $self->{feature_names}
2732             && ref $self->{feature_names} eq 'ARRAY'
2733 48 50 66     1026 && @{ $self->{feature_names} };
  44   66     138  
2734              
2735 44         77 my @names = @{ $self->{feature_names} };
  44         169  
2736              
2737             my @unknown = grep {
2738 44         147 my $k = $_;
  129         220  
2739 129         207 !grep { $_ eq $k } @names
  387         778  
2740             } keys %$row;
2741 44 100       899 croak "unknown feature name(s) in hashref: " . join( ', ', sort @unknown )
2742             if @unknown;
2743              
2744 40         68 my @missing = grep { !exists $row->{$_} } @names;
  120         232  
2745 40 100       816 croak "missing feature name(s) in hashref: " . join( ', ', @missing )
2746             if @missing;
2747              
2748 36         65 return [ map { $row->{$_} } @names ];
  108         299  
2749             } ## end sub tagged_row_to_array
2750              
2751             sub predict_tagged {
2752 12     12 1 21244 my ( $self, $row, $threshold ) = @_;
2753 12         40 my $vec = $self->tagged_row_to_array( $row, 'predict_tagged' );
2754 8         29 my $result = $self->predict( [$vec], $threshold );
2755 8         47 return $result->[0];
2756             }
2757              
2758             =head2 score_samples(\@data)
2759              
2760             Returns an arrayref of anomaly scores, between 0 and 1.
2761              
2762             Scores near 1 are strong anomalies (isolated quickly).
2763              
2764             Scores well below 0.5 are normal.
2765              
2766             Scores ~0.5 means the points are hard to tell apart.
2767              
2768             Under C<< voting => 'majority' >> the returned value is instead the
2769             fraction of trees voting the sample anomalous at the model's decision
2770             threshold (the contamination-learned cutoff if present, otherwise 0.5) --
2771             still in [0, 1], but discrete in steps of C<1/n_trees>, with a majority
2772             label corresponding to a fraction strictly above 0.5.
2773              
2774             my $scores = $forest->score_samples(\@data);
2775              
2776             print "x, y, score\n";
2777              
2778             my $int=0;
2779             while (defined($data[$int])) {
2780             print $data[$int][0].', '.$data[$int][1].', '.$scores->[$int]."\n";
2781              
2782             $int++;
2783             }
2784              
2785             =cut
2786              
2787             sub score_samples {
2788 15795     15795 1 100321 my ( $self, $data ) = @_;
2789 15795         36800 $self->_check_fitted;
2790 15793         26938 my $c = $self->{c_psi};
2791 15793         24060 my $trees = $self->{trees};
2792 15793         24971 my $t = scalar @$trees;
2793              
2794             # Majority voting: the "score" is the fraction of trees voting the
2795             # sample anomalous at the model's decision threshold (contamination-
2796             # learned if present, else 0.5) -- discrete in steps of 1/t.
2797 15793 100       31718 if ( $self->{voting} eq 'majority' ) {
2798 9 50       27 my $theta = defined $self->{threshold} ? $self->{threshold} : 0.5;
2799 9         29 my $cut = _depth_cut( $theta, $c );
2800              
2801 9 50 66     42 if ( $self->{_use_c} && $self->{_c_nodes} ) {
2802 7         32 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2803 7         21 my $votes_packed = "\0" x ( $n_pts * 8 );
2804             vote_all_xs( $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2805 7         7794 $x_packed, $votes_packed, $n_pts, $nf, $t, $cut, 0, $self->{_use_openmp} );
2806              
2807             # votes/t is exactly the "divide the sum buffer by t" shape
2808             # finalize_path_lengths_xs implements, so reuse it.
2809 7         42 my $result = [];
2810 7         88 finalize_path_lengths_xs( $votes_packed, $n_pts, $t + 0.0, $result );
2811 7         53 return $result;
2812             } ## end if ( $self->{_use_c} && $self->{_c_nodes} )
2813              
2814 2         12 my $votes = $self->_vote_counts_perl( $self->_prepare_perl_input($data), $cut );
2815 2         11 return [ map { $_ / $t } @$votes ] if _NV_IS_DOUBLE;
  126         202  
2816              
2817             # Wide-NV perls: the C finalizers divide in double, so narrow the
2818             # vote fraction to match -- see _NV_IS_DOUBLE.
2819 0         0 return [ map { _to_double( $_ / $t ) } @$votes ];
  0         0  
2820             } ## end if ( $self->{voting} eq 'majority' )
2821              
2822 15784 100 100     49989 if ( $self->{_use_c} && $self->{_c_nodes} ) {
2823 15723         30119 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2824 15722         28983 my $sums_packed = "\0" x ( $n_pts * 8 );
2825             score_all_xs(
2826             $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2827             $x_packed, $sums_packed, $n_pts,
2828             $nf, $t, $self->{_use_openmp}
2829 15722         622763 );
2830 15722 50       39648 if ( $c > 0 ) {
2831 15722         28085 my $inv = log(2) / ( $c * $t );
2832 15722         23953 my $result = [];
2833 15722         50000 finalize_scores_xs( $sums_packed, $n_pts, $inv, $result );
2834 15722         57154 return $result;
2835             }
2836 0         0 return [ (0.5) x $n_pts ];
2837             } ## end if ( $self->{_use_c} && $self->{_c_nodes} )
2838              
2839 61         303 $data = $self->_prepare_perl_input($data);
2840 61 100       229 my $nan = $self->{missing} eq 'nan' ? 1 : 0;
2841              
2842             # Pure-Perl fallback (tree-outer, sample-inner for cache locality).
2843 61         340 my @sums = (0) x @$data;
2844 61         155 for my $tree (@$trees) {
2845 4542         8016 for my $i ( 0 .. $#$data ) {
2846 357236         484985 $sums[$i] += _path_length( $data->[$i], $tree, 0, $nan );
2847             }
2848             }
2849              
2850             # Precompute the single normalising factor; exp() is a direct FPU
2851             # instruction and faster than Perl's general-purpose 2**x (pow).
2852             # Derivation: 2**(-avg/c) = 2**(-(sum/t)/c) = exp(-sum * log(2)/(c*t))
2853 61 50       283 if ( $c > 0 ) {
2854 61         153 my $inv = log(2) / ( $c * $t );
2855 61         279 return [ map { exp( -$_ * $inv ) } @sums ];
  4819         7248  
2856             }
2857 0         0 return [ (0.5) x @sums ];
2858             } ## end sub score_samples
2859              
2860             =head2 score_sample_tagged(\%row)
2861              
2862             Scores a single sample supplied as a hashref of named feature values.
2863             The model must have stored feature names (set via C in
2864             C or the C<-t> CLI flag at fit time).
2865              
2866             Returns a scalar anomaly score in (0, 1].
2867              
2868             my $score = $forest->score_sample_tagged({ cpu => 0.9, mem => 0.4 });
2869              
2870             Croaks if the model has no stored feature names, if the hashref contains a
2871             key that is not a known feature name, or if a feature name is absent from the
2872             hashref.
2873              
2874             =cut
2875              
2876             sub score_sample_tagged {
2877 12     12 1 23155 my ( $self, $row ) = @_;
2878 12         65 my $vec = $self->tagged_row_to_array( $row, 'score_sample_tagged' );
2879 8         31 my $result = $self->score_samples( [$vec] );
2880 8         52 return $result->[0];
2881             }
2882              
2883             =head2 score_predict_samples
2884              
2885             Returns an array ref of arrays. First value of each sub array is the score with the second being
2886             0/1 for if it is a anomaly or not.
2887              
2888             C<$threshold> defaults the same way as in C.
2889              
2890             Under C<< voting => 'majority' >> the score is the anomaly vote fraction at
2891             C<$threshold> (used as the per-tree cutoff) and the label is the majority
2892             vote, matching C/C semantics in that mode.
2893              
2894             my $results = $forest->score_predict_samples(\@data, $threshold);
2895              
2896             print "x, y, score, result\n";
2897              
2898             my $int=0;
2899             while (defined($data[$int])) {
2900             print $data[$int][0].', '.$data[$int][1].', '.$results->[$int][0].', '.$results->[$int][1]."\n";
2901              
2902             $int++;
2903             }
2904              
2905             =cut
2906              
2907             sub score_predict_samples {
2908 5347     5347 1 23297 my ( $self, $data, $threshold ) = @_;
2909             $threshold
2910             = defined $threshold ? $threshold
2911             : defined $self->{threshold} ? $self->{threshold}
2912 5347 100       10693 : 0.5;
    100          
2913 5347         13603 $self->_check_fitted;
2914              
2915             # Majority voting: [vote_fraction, majority_label] pairs. Needs the
2916             # full vote counts (the fraction is part of the return shape), so no
2917             # early exit here -- that saving is predict()-only.
2918 5347 100       12115 if ( $self->{voting} eq 'majority' ) {
2919 3         6 my $trees = $self->{trees};
2920 3         7 my $t = scalar @$trees;
2921 3         11 my $cut = _depth_cut( $threshold, $self->{c_psi} );
2922 3         10 my $maj = _min_votes($t);
2923              
2924 3 50 33     20 if ( $self->{_use_c} && $self->{_c_nodes} ) {
2925 3         15 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2926 3         10 my $votes_packed = "\0" x ( $n_pts * 8 );
2927             vote_all_xs( $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2928 3         157 $x_packed, $votes_packed, $n_pts, $nf, $t, $cut, 0, $self->{_use_openmp} );
2929 3         9 my $result = [];
2930 3         92 vote_score_predict_xs( $votes_packed, $n_pts, $t + 0.0, $maj + 0.0, $result );
2931 3         14 return $result;
2932             }
2933              
2934 0         0 my $votes = $self->_vote_counts_perl( $self->_prepare_perl_input($data), $cut );
2935 0 0       0 return [ map { [ $_ / $t, ( $_ >= $maj ? 1 : 0 ) ] } @$votes ] if _NV_IS_DOUBLE;
  0         0  
2936              
2937             # Wide-NV perls: match vote_score_predict_xs's double division --
2938             # see _NV_IS_DOUBLE.
2939 0 0       0 return [ map { [ _to_double( $_ / $t ), ( $_ >= $maj ? 1 : 0 ) ] } @$votes ];
  0         0  
2940             } ## end if ( $self->{voting} eq 'majority' )
2941              
2942             # Fast path: build [score, label] pairs straight from the sum buffer
2943             # in one C call. Avoids the intermediate scores arrayref + Perl
2944             # foreach that allocates ~3*n_pts SVs. Gated identically to predict()
2945             # so the threshold conversion is valid.
2946 5344 50 66     34992 if ( $self->{_use_c}
      33        
      33        
      33        
2947             && $self->{_c_nodes}
2948             && $self->{c_psi} > 0
2949             && $threshold > 0
2950             && $threshold < 1 )
2951             {
2952 5342         9045 my $trees = $self->{trees};
2953 5342         8771 my $t = scalar @$trees;
2954 5342         8817 my $c = $self->{c_psi};
2955 5342         11464 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
2956 5342         10707 my $sums_packed = "\0" x ( $n_pts * 8 );
2957             score_all_xs(
2958             $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
2959             $x_packed, $sums_packed, $n_pts,
2960             $nf, $t, $self->{_use_openmp}
2961 5342         242286 );
2962 5342         11615 my $inv = log(2) / ( $c * $t );
2963 5342         10370 my $sum_threshold = -log($threshold) * $c * $t / log(2);
2964 5342         8468 my $result = [];
2965 5342         22789 score_predict_xs( $sums_packed, $n_pts, $inv, $sum_threshold, $result );
2966 5342         25586 return $result;
2967             } ## end if ( $self->{_use_c} && $self->{_c_nodes} ...)
2968              
2969             # Fallback: edge thresholds, c==0, or no C backend.
2970 2         9 my $scores = $self->score_samples( $self->_to_arrayref($data) );
2971              
2972 2         4 my @to_return;
2973 2         5 foreach my $score ( @{$scores} ) {
  2         5  
2974 12 100       20 if ( $score >= $threshold ) {
2975 4         8 push @to_return, [ $score, 1 ];
2976             } else {
2977 8         15 push @to_return, [ $score, 0 ];
2978             }
2979             }
2980              
2981 2         12 return \@to_return;
2982             } ## end sub score_predict_samples
2983              
2984             =head2 score_predict_sample_tagged(\%row, $threshold)
2985              
2986             Scores and classifies a single sample supplied as a hashref of named
2987             feature values. The model must have stored feature names.
2988              
2989             C<$threshold> defaults the same way as in C.
2990              
2991             Returns a two-element arrayref C<[$score, $label]>, matching the per-row
2992             shape that C returns for each row.
2993              
2994             my $pair = $forest->score_predict_sample_tagged({ cpu => 0.9, mem => 0.4 });
2995             printf "score %.4f anomaly %d\n", $pair->[0], $pair->[1];
2996              
2997             Croaks if the model has no stored feature names, if the hashref contains a
2998             key that is not a known feature name, or if a feature name is absent from the
2999             hashref.
3000              
3001             =cut
3002              
3003             sub score_predict_sample_tagged {
3004 21     21 1 42744 my ( $self, $row, $threshold ) = @_;
3005 21         66 my $vec = $self->tagged_row_to_array( $row, 'score_predict_sample_tagged' );
3006 17         62 my $result = $self->score_predict_samples( [$vec], $threshold );
3007 17         103 return $result->[0];
3008             }
3009              
3010             =head2 score_predict_split(\@data, $threshold)
3011              
3012             Same data as L but returned as two flat arrayrefs
3013             instead of an arrayref-of-pairs. Allocates roughly half as many Perl
3014             SVs per point (no inner AV, no RV per row), so it is meaningfully faster
3015             when both scores and labels are wanted but the paired shape is not.
3016              
3017             In list context returns C<($scores_aref, $labels_aref)>.
3018              
3019             my ($scores, $labels) = $forest->score_predict_split(\@data);
3020              
3021             for my $i (0 .. $#$scores) {
3022             printf "%s -> score %.4f, label %d\n",
3023             join(',', @{ $data[$i] }), $scores->[$i], $labels->[$i];
3024             }
3025              
3026             C<$threshold> defaults to the contamination-learned cutoff (if C
3027             was called with C) or 0.5.
3028              
3029             =cut
3030              
3031             sub score_predict_split {
3032 13662     13662 1 37379 my ( $self, $data, $threshold ) = @_;
3033             $threshold
3034             = defined $threshold ? $threshold
3035             : defined $self->{threshold} ? $self->{threshold}
3036 13662 50       25370 : 0.5;
    100          
3037 13662         33360 $self->_check_fitted;
3038              
3039             # Majority voting: same values as the majority branch in
3040             # score_predict_samples, returned as two flat arrayrefs.
3041 13662 100       30142 if ( $self->{voting} eq 'majority' ) {
3042 6         12 my $trees = $self->{trees};
3043 6         16 my $t = scalar @$trees;
3044 6         22 my $cut = _depth_cut( $threshold, $self->{c_psi} );
3045 6         26 my $maj = _min_votes($t);
3046              
3047 6 50 66     33 if ( $self->{_use_c} && $self->{_c_nodes} ) {
3048 4         18 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
3049 4         19 my $votes_packed = "\0" x ( $n_pts * 8 );
3050             vote_all_xs( $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
3051 4         2938 $x_packed, $votes_packed, $n_pts, $nf, $t, $cut, 0, $self->{_use_openmp} );
3052 4         14 my $scores = [];
3053 4         9 my $labels = [];
3054 4         67 vote_score_predict_split_xs( $votes_packed, $n_pts, $t + 0.0, $maj + 0.0, $scores, $labels );
3055 4         24 return ( $scores, $labels );
3056             } ## end if ( $self->{_use_c} && $self->{_c_nodes} )
3057              
3058 2         11 my $votes = $self->_vote_counts_perl( $self->_prepare_perl_input($data), $cut );
3059             my @scores = _NV_IS_DOUBLE
3060 126         189 ? map { $_ / $t }
3061             @$votes
3062             # Wide-NV perls: match vote_score_predict_split_xs's double
3063             # division -- see _NV_IS_DOUBLE.
3064 2         16 : map { _to_double( $_ / $t ) } @$votes;
3065 2 100       6 my @labels = map { $_ >= $maj ? 1 : 0 } @$votes;
  126         182  
3066 2         21 return ( \@scores, \@labels );
3067             } ## end if ( $self->{voting} eq 'majority' )
3068              
3069             # Fast path: fill two flat arrayrefs (scores + labels) directly from
3070             # the sum buffer in one C call. Skips the inner AV + RV per point
3071             # that score_predict_samples has to allocate.
3072 13656 50 66     86362 if ( $self->{_use_c}
      33        
      33        
      33        
3073             && $self->{_c_nodes}
3074             && $self->{c_psi} > 0
3075             && $threshold > 0
3076             && $threshold < 1 )
3077             {
3078 13654         23607 my $trees = $self->{trees};
3079 13654         21594 my $t = scalar @$trees;
3080 13654         22062 my $c = $self->{c_psi};
3081 13654         27189 my ( $n_pts, $nf, $x_packed ) = $self->_resolve_input($data);
3082 13654         25965 my $sums_packed = "\0" x ( $n_pts * 8 );
3083             score_all_xs(
3084             $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val},
3085             $x_packed, $sums_packed, $n_pts,
3086             $nf, $t, $self->{_use_openmp}
3087 13654         326530 );
3088 13654         28317 my $inv = log(2) / ( $c * $t );
3089 13654         26265 my $sum_threshold = -log($threshold) * $c * $t / log(2);
3090 13654         21215 my $scores = [];
3091 13654         20785 my $labels = [];
3092 13654         50452 score_predict_split_xs( $sums_packed, $n_pts, $inv, $sum_threshold, $scores, $labels );
3093 13654         65703 return ( $scores, $labels );
3094             } ## end if ( $self->{_use_c} && $self->{_c_nodes} ...)
3095              
3096             # Fallback: derive from score_samples.
3097 2         10 my $scores = $self->score_samples( $self->_to_arrayref($data) );
3098 2 100       6 my @labels = map { $_ >= $threshold ? 1 : 0 } @$scores;
  12         24  
3099 2         15 return ( $scores, \@labels );
3100             } ## end sub score_predict_split
3101              
3102             =head1 MODEL SAVE/LOAD METHODS
3103              
3104             =head2 to_json
3105              
3106             Returns a JSON representation of the model.
3107              
3108             Requires fit to have been called.
3109              
3110             my $json = $iforest->to_json;
3111              
3112             =cut
3113              
3114             sub to_json {
3115 24     24 1 172406 my ($self) = @_;
3116 24         161 $self->_check_fitted;
3117             my $payload = {
3118             format => 'Algorithm::Classifier::IsolationForest',
3119             version => 1,
3120             params => {
3121             n_trees => $self->{n_trees},
3122             sample_size => $self->{sample_size},
3123             mode => $self->{mode},
3124             extension_level => $self->{extension_level_used},
3125             contamination => $self->{contamination},
3126             threshold => $self->{threshold},
3127             n_features => $self->{n_features},
3128             psi_used => $self->{psi_used},
3129             c_psi => $self->{c_psi},
3130             max_depth_used => $self->{max_depth_used},
3131             missing => $self->{missing},
3132             impute_with => $self->{impute_with},
3133             missing_fill => $self->{missing_fill},
3134             feature_names => $self->{feature_names},
3135             voting => $self->{voting},
3136             },
3137             trees => $self->{trees},
3138 22         589 };
3139 22         345 return JSON::PP->new->canonical(1)->encode($payload);
3140             } ## end sub to_json
3141              
3142             =head2 from_json($json)
3143              
3144             Init the object from the model in the specified JSON string.
3145              
3146             my $iforest = Algorithm::Classifier::IsolationForest->from_json($json);
3147              
3148             =cut
3149              
3150             sub from_json {
3151 33     33 1 4414324 my ( $class, $text ) = @_;
3152 33         359 my $payload = JSON::PP->new->decode($text);
3153             croak "not an IsolationForest model"
3154             unless ref $payload eq 'HASH'
3155             && defined $payload->{format}
3156 33 100 100     18333616 && $payload->{format} eq 'Algorithm::Classifier::IsolationForest';
      66        
3157              
3158 31   100     177 my $p = $payload->{params} || {};
3159              
3160             # version 0 used hash-based nodes; version 1+ uses array-based nodes.
3161             # Convert old models on load so the rest of the code only sees arrays.
3162 31   50     142 my $trees = $payload->{trees} || [];
3163 31 100 100     228 if ( ( $payload->{version} // 0 ) < 1 ) {
3164 1         3 $trees = [ map { _hash_node_to_array($_) } @$trees ];
  0         0  
3165             }
3166              
3167             my $self = {
3168             n_trees => $p->{n_trees},
3169             sample_size => $p->{sample_size},
3170             max_depth => undef,
3171             seed => undef,
3172             mode => $p->{mode} // 'axis',
3173             extension_level => $p->{extension_level},
3174             extension_level_used => $p->{extension_level},
3175             contamination => $p->{contamination},
3176             threshold => $p->{threshold},
3177             n_features => $p->{n_features},
3178             psi_used => $p->{psi_used},
3179             c_psi => $p->{c_psi},
3180             max_depth_used => $p->{max_depth_used},
3181             # Models saved before missing-value support lack these keys; default
3182             # to 'zero', which reproduces the old undef -> 0 scoring behaviour.
3183             missing => $p->{missing} // 'zero',
3184             impute_with => $p->{impute_with} // 'mean',
3185             missing_fill => $p->{missing_fill},
3186             feature_names => $p->{feature_names},
3187             # Models saved before majority-voting support lack the key; 'mean'
3188             # reproduces their behaviour exactly.
3189 31   100     1100 voting => $p->{voting} // 'mean',
      100        
      100        
      100        
3190             trees => $trees,
3191             _use_c => $HAS_C,
3192             _use_openmp => $HAS_OPENMP,
3193             _use_openmp_fit => 0, # opt-in only; loaded models never re-fit implicitly
3194             };
3195 31 100       70 croak "model contains no trees" unless @{ $self->{trees} };
  31         296  
3196              
3197             # Recompute the normalising constant from the (integer, exact) sub-sample
3198             # size rather than trusting the stored float, so a reloaded model's scores
3199             # are bit-for-bit identical to the original's.
3200 30 50       340 $self->{c_psi} = _c( $self->{psi_used} ) if defined $self->{psi_used};
3201              
3202 30         149 my $model = bless $self, $class;
3203 30 50       488 $model->_rebuild_c_trees() if $self->{_use_c};
3204 30         530 return $model;
3205             } ## end sub from_json
3206              
3207             =head2 save($path)
3208              
3209             Saves the model to the specified path.
3210              
3211             $iforest->save($path);
3212              
3213             =cut
3214              
3215             sub save {
3216 1     1 1 4620 my ( $self, $path ) = @_;
3217 1         7 write_file( $path, { 'atomic' => 1 }, $self->to_json );
3218             }
3219              
3220             =head2 load($path)
3221              
3222             Init the object from the model in the specified file.
3223              
3224             my $iforest = Algorithm::Classifier::IsolationForest->load($path);
3225              
3226             =cut
3227              
3228             sub load {
3229 16     16 1 162310 my ( $class, $path ) = @_;
3230 16         102 my $raw_model = read_file($path);
3231 15         2126 return $class->from_json($raw_model);
3232             }
3233              
3234             =head1 REFERENCES
3235              
3236             Liu, Fei Tony & Ting, Kai & Zhou, Zhi-Hua. (2008). Isolation Forest. 413 - 422. 10.1109/ICDM.2008.17.
3237              
3238             L
3239              
3240             L
3241              
3242             Sahand Hariri, Matias Carrasco Kind, Robert J. Brunner (2020). Extended Isolation Forest. 1479 - 1489. 10.1109/TKDE.2019.2947676
3243              
3244             L
3245              
3246             Yousra Chabchoub, Maurras Ulbricht Togbe, Aliou Boly, Raja Chiky (2022). An In-Depth Study and Improvement of Isolation Forest. IEEE Access, vol. 10, 10219 - 10237. 10.1109/ACCESS.2022.3144425 (the Majority Voting Isolation Forest implemented by C<< voting => 'majority' >>)
3247              
3248             L
3249              
3250             =cut
3251              
3252             ###
3253             ###
3254             ### internal stuff below
3255             ###
3256             ###
3257              
3258             #-------------------------------------------------------------------------------
3259             # c(n): the expected path length of an unsuccessful search in a binary search
3260             # tree of n nodes. Isolation Forest uses it (a) to adjust the path length when a
3261             # leaf still holds more than one point (depth limit reached), and (b) to
3262             # normalise the average path length into a 0..1 anomaly score.
3263             #-------------------------------------------------------------------------------
3264             sub _c {
3265 691367     691367   825178 my ($n) = @_;
3266 691367 100       1130640 return 0.0 if $n <= 1;
3267 413657 100       605406 return 1.0 if $n == 2;
3268 345503         426925 my $harmonic = log( $n - 1 ) + EULER; # H(n-1) ~= ln(n-1) + gamma
3269 345503         641410 return 2.0 * $harmonic - ( 2.0 * ( $n - 1 ) / $n );
3270             }
3271              
3272             #-------------------------------------------------------------------------------
3273             # Majority-voting (voting => 'majority') helpers. MVIForest -- Chabchoub,
3274             # Togbe, Boly & Chiky 2022 (see REFERENCES) -- has each tree vote a point
3275             # anomalous when the tree's own score 2**(-h/c(psi)) clears the decision
3276             # threshold, and takes the majority of the votes as the label. Trees are
3277             # untouched; only these scoring-time aggregation helpers differ from the
3278             # classic mean-path-length pipeline.
3279             #-------------------------------------------------------------------------------
3280              
3281             # Depth-domain image of the per-tree score cutoff: a tree votes a point
3282             # anomalous when 2**(-h/c) >= theta, i.e. h <= -c * log2(theta). Doing the
3283             # log once here keeps exp/log out of the per-point per-tree loops (both C
3284             # and Perl compare raw path lengths against this cut). Degenerate inputs
3285             # pin the cut so `h <= cut` still behaves: theta <= 0 is cleared by every
3286             # per-tree score (all in (0, 1]), so +inf lets every tree vote; c <= 0 only
3287             # happens for psi <= 1 forests, whose score convention is a flat 0.5 (see
3288             # score_samples), so all trees vote iff theta is at or below that pivot.
3289             sub _depth_cut {
3290 36     36   73 my ( $theta, $c ) = @_;
3291 36 0       83 return ( $theta <= 0.5 ? 9**9**9 : -1.0 ) if $c <= 0;
    50          
3292 36 50       78 return 9**9**9 if $theta <= 0;
3293 36         141 return -$c * log($theta) / log(2);
3294             }
3295              
3296             # Smallest number of per-tree anomaly votes that constitutes a majority:
3297             # int(t/2) + 1, i.e. strictly more than half the trees for both odd and
3298             # even tree counts (the paper's "t/2 + 1").
3299 33     33   135 sub _min_votes { return int( $_[0] / 2 ) + 1 }
3300              
3301             #-------------------------------------------------------------------------------
3302             # Contamination threshold selection: given the training scores ranked
3303             # descending and the target flag count k, return a cutoff sitting midway
3304             # inside the gap between the last flagged and the first unflagged score.
3305             #
3306             # Tied scores at the k-boundary make an exact count of k unattainable (the
3307             # tie block can only go one way or the other) AND make the naive midpoint
3308             # degenerate -- it equals the tied value, leaving predict()'s >= comparison
3309             # balanced on exact float equality. Mean-mode scores are continuous enough
3310             # that this practically never happens, but majority-mode pivots are
3311             # structurally quantized (path lengths at the depth cap take few distinct
3312             # values -- see _majority_pivot_scores), so ties there are the norm, and
3313             # the score <-> depth-cut conversion adds an exp/log round trip that needs
3314             # real slack around the cutoff rather than exact-equality behaviour. The
3315             # whole tie block therefore goes to whichever side lands the flag count
3316             # closest to k, preferring the flagging side on a dead heat.
3317             #-------------------------------------------------------------------------------
3318             sub _threshold_from_ranked {
3319 13     13   51 my ( $desc, $k ) = @_;
3320 13         25 my $n = scalar @$desc;
3321 13 50       41 return $desc->[ $n - 1 ] - 1e-9 if $k >= $n; # flag everything
3322              
3323 13         40 my $v = $desc->[ $k - 1 ];
3324 13 50       78 return ( $v + $desc->[$k] ) / 2.0 if $desc->[$k] < $v; # clean gap at k
3325              
3326             # Tie block straddling the k-boundary: locate its edges.
3327 0         0 my $i = $k - 1;
3328 0   0     0 $i-- while $i > 0 && $desc->[ $i - 1 ] == $v; # first index holding $v
3329 0         0 my $j = $k;
3330 0   0     0 $j++ while $j < $n && $desc->[$j] == $v; # first index below $v
3331              
3332 0 0 0     0 if ( $i > 0 && ( $k - $i ) < ( $j - $k ) ) {
3333              
3334             # Excluding the block lands closer to k: flag the $i points above it.
3335 0         0 return ( $desc->[ $i - 1 ] + $v ) / 2.0;
3336             }
3337 0 0       0 return $j < $n
3338             ? ( $v + $desc->[$j] ) / 2.0 # include the block: flag $j
3339             : $desc->[ $n - 1 ] - 1e-9; # block runs to the end
3340             } ## end sub _threshold_from_ranked
3341              
3342             # Pure-Perl vote counter: votes[i] = how many trees give point i a path
3343             # length at or under the depth cut. Tree-outer / sample-inner for cache
3344             # locality, mirroring the mean-mode fallback loops. $data must already
3345             # be through _prepare_perl_input.
3346             sub _vote_counts_perl {
3347 4     4   13 my ( $self, $data, $cut ) = @_;
3348 4         8 my $trees = $self->{trees};
3349 4 50       19 my $nan = $self->{missing} eq 'nan' ? 1 : 0;
3350 4         45 my @votes = (0) x @$data;
3351 4         14 for my $tree (@$trees) {
3352 160         256 for my $i ( 0 .. $#$data ) {
3353 10080 100       13112 $votes[$i]++ if _path_length( $data->[$i], $tree, 0, $nan ) <= $cut;
3354             }
3355             }
3356 4         22 return \@votes;
3357             } ## end sub _vote_counts_perl
3358              
3359             #-------------------------------------------------------------------------------
3360             # Contamination support for majority voting: each training point's majority
3361             # pivot -- the per-tree score threshold at which the point loses its
3362             # majority. A point is flagged at cutoff theta iff at least min_votes of
3363             # its per-tree path lengths h satisfy h <= -c*log2(theta), which holds iff
3364             # its min_votes-th SMALLEST path length h_(maj) does, i.e. iff
3365             # 2**(-h_(maj)/c) >= theta. So the pivot m = 2**(-h_(maj)/c) relates to
3366             # the majority-mode threshold exactly as the mean-mode score relates to
3367             # its threshold, and fit()'s midpoint selection works on either unchanged.
3368             #
3369             # Pure Perl by necessity: the per-tree path lengths never cross the C
3370             # boundary individually (score_all_xs/vote_all_xs only return per-point
3371             # aggregates), and fit() has already dropped any stale packed buffers when
3372             # this runs -- the same situation as mean mode's training-set scoring pass.
3373             #-------------------------------------------------------------------------------
3374             # Learn the contamination cutoff for the CURRENT voting mode from a training
3375             # set. Ranks the per-point quantity the active aggregation thresholds against
3376             # -- the mean-mode anomaly score, or the majority pivot under
3377             # voting => 'majority' -- and lands the cutoff midway inside a real gap between
3378             # flagged and unflagged values (ties at the k-boundary shift it to the nearest
3379             # gap; see _threshold_from_ranked), so it sits strictly between attainable
3380             # values: unambiguous and robust to the float rounding JSON introduces. A
3381             # point is flagged iff its statistic >= threshold in either mode, so the
3382             # midpoint selection serves both unchanged. Shared by fit() (which passes the
3383             # prepared training set after dropping any stale packed buffers) and
3384             # set_voting() (which passes the caller-supplied training set against the
3385             # live, fully packed forest); $data may hold raw undef cells either way, since
3386             # the scorers below densify from missing_fill.
3387             sub _learn_contamination_threshold {
3388 13     13   37 my ( $self, $data ) = @_;
3389             my $scores
3390 13 100       83 = $self->{voting} eq 'majority'
3391             ? $self->_majority_pivot_scores($data)
3392             : $self->score_samples($data);
3393 13         95 my @desc = sort { $b <=> $a } @$scores;
  7643         8446  
3394 13         38 my $n_pts = scalar @desc;
3395 13         68 my $k = int( $self->{contamination} * $n_pts + 0.5 );
3396 13 50       64 $k = 1 if $k < 1;
3397 13 50       79 $k = $n_pts if $k > $n_pts;
3398 13         82 $self->{threshold} = _threshold_from_ranked( \@desc, $k );
3399 13         100 return;
3400             } ## end sub _learn_contamination_threshold
3401              
3402             sub _majority_pivot_scores {
3403 6     6   11 my ( $self, $data ) = @_;
3404 6         15 my $trees = $self->{trees};
3405 6         15 my $t = scalar @$trees;
3406 6         13 my $c = $self->{c_psi};
3407 6         34 my $maj = _min_votes($t);
3408 6         27 my $rows = $self->_prepare_perl_input($data);
3409 6 50       19 my $nan = $self->{missing} eq 'nan' ? 1 : 0;
3410              
3411             # psi <= 1 degenerate forest: every per-tree score is pinned at 0.5
3412             # (matching score_samples' convention), so every pivot is too.
3413 6 50       18 return [ (0.5) x @$rows ] unless $c > 0;
3414              
3415 6         9 my $inv = log(2) / $c;
3416 6         14 my @pivots;
3417 6         19 for my $x (@$rows) {
3418 378         772 my @paths = sort { $a <=> $b } map { _path_length( $x, $_, 0, $nan ) } @$trees;
  171964         184181  
  32760         40812  
3419 378         2516 push @pivots, exp( -$paths[ $maj - 1 ] * $inv );
3420             }
3421 6         32 return \@pivots;
3422             } ## end sub _majority_pivot_scores
3423              
3424             # One draw from the standard normal N(0,1) via Box-Muller. Used to pick the
3425             # random hyperplane orientations in Extended Isolation Forest mode.
3426             sub _randn {
3427 43954   50 43954   64753 my $u1 = rand() || 1e-12;
3428 43954         50271 my $u2 = rand();
3429 43954         77275 return sqrt( -2.0 * log($u1) ) * cos( TWO_PI * $u2 ) if _NV_IS_DOUBLE;
3430              
3431             # Wide-NV perls: round after every operation _c_randn() performs in
3432             # double, so both backends draw the same coefficient bit patterns
3433             # (up to libm's own double-vs-long-double disagreements on rare
3434             # rounding ties).
3435 0         0 my $s = _to_double( sqrt( -2.0 * _to_double( log($u1) ) ) );
3436 0         0 my $c = _to_double( cos( _to_double( TWO_PI * $u2 ) ) );
3437 0         0 return _to_double( $s * $c );
3438             } ## end sub _randn
3439              
3440             #-------------------------------------------------------------------------------
3441             # Draw $k samples without replacement via a partial Fisher-Yates shuffle of the
3442             # index array. Returns an arrayref of (shared, read-only) sample refs.
3443             #-------------------------------------------------------------------------------
3444             sub _subsample {
3445 2249     2249   4783 my ( $data, $k ) = @_;
3446 2249         3629 my $n = scalar @$data;
3447 2249         14671 my @idx = ( 0 .. $n - 1 );
3448 2249         5730 for my $i ( 0 .. $k - 1 ) {
3449 395208         459548 my $j = $i + int( rand( $n - $i ) );
3450 395208         524973 @idx[ $i, $j ] = @idx[ $j, $i ];
3451             }
3452 2249         33848 my @chosen = @idx[ 0 .. $k - 1 ];
3453 2249         9826 return [ @{$data}[@chosen] ];
  2249         43923  
3454             } ## end sub _subsample
3455              
3456             #-------------------------------------------------------------------------------
3457             # Recursively build one isolation tree.
3458             #
3459             # A node is one of:
3460             # leaf { leaf => 1, size => N }
3461             # axis { attr => A, split => S, left => ..., right => ... }
3462             # oblique { idx => [..], coef => [..], b => B, left => ..., right => ... }
3463             #
3464             # In both split styles the choice is restricted to features that actually vary
3465             # across the points reaching the node: this avoids wasted levels on constant
3466             # columns and lets a node leaf out exactly when its points are indistinguishable.
3467             #-------------------------------------------------------------------------------
3468             sub _build_tree {
3469 295267     295267   393699 my ( $self, $X, $depth, $limit ) = @_;
3470              
3471 295267         326164 my $size = scalar @$X;
3472 295267 100 100     663929 return [ _NODE_LEAF, $size ]
3473             if $depth >= $limit || $size <= 1;
3474              
3475 149304         190924 my $nf = $self->{n_features};
3476 149304         192678 my $nan = $self->{missing} eq 'nan';
3477              
3478             # Per-feature min and max within this node, in a single pass. Missing
3479             # (undef) cells never reach here under die/zero/impute -- those fill the
3480             # data before fit -- so the "next unless defined" guard is only needed
3481             # in nan mode, where missing values must not constrain a feature's
3482             # range; every other strategy skips it since every cell is defined and
3483             # the check would never fire.
3484 149304         171095 my ( @lo, @hi );
3485 149304 100       189781 if ($nan) {
3486 23338         29483 for my $row (@$X) {
3487 383160         462631 for my $f ( 0 .. $nf - 1 ) {
3488 770777         834671 my $v = $row->[$f];
3489 770777 100       1027601 next unless defined $v;
3490 698528 100 100     1375545 $lo[$f] = $v if !defined $lo[$f] || $v < $lo[$f];
3491 698528 100 100     1457017 $hi[$f] = $v if !defined $hi[$f] || $v > $hi[$f];
3492             }
3493             }
3494             } else {
3495 125966         156289 for my $row (@$X) {
3496 2601022         3182493 for my $f ( 0 .. $nf - 1 ) {
3497 7058414         7736768 my $v = $row->[$f];
3498 7058414 100 100     13481154 $lo[$f] = $v if !defined $lo[$f] || $v < $lo[$f];
3499 7058414 100 100     14519478 $hi[$f] = $v if !defined $hi[$f] || $v > $hi[$f];
3500             }
3501             }
3502             }
3503              
3504             # Features with spread are the only ones that can split the data. A
3505             # feature whose values are all missing within this node has an undef
3506             # range and is excluded.
3507 149304 100       225837 my @varying = grep { defined $lo[$_] && $lo[$_] < $hi[$_] } 0 .. $nf - 1;
  333736         742470  
3508              
3509             # No spread on any feature => all points identical => cannot isolate.
3510 149304 100       216980 return [ _NODE_LEAF, $size ] unless @varying;
3511              
3512             my $node
3513 146509 100       292365 = $self->{mode} eq 'extended'
3514             ? $self->_oblique_split( $X, \@varying, \@lo, \@hi, $nan )
3515             : _axis_split( $X, \@varying, \@lo, \@hi, $nan );
3516              
3517             # Split functions leave the raw point arrays at the child slots so that
3518             # _build_tree can recurse into them; the subtree refs replace them in-place.
3519             # Axis nodes: left at [3], right at [4]
3520             # Oblique nodes: left at [4], right at [5]
3521 146509 100       242252 my ( $li, $ri ) = $node->[0] == _NODE_AXIS ? ( 3, 4 ) : ( 4, 5 );
3522 146509         249987 $node->[$li] = $self->_build_tree( $node->[$li], $depth + 1, $limit );
3523 146509         215834 $node->[$ri] = $self->_build_tree( $node->[$ri], $depth + 1, $limit );
3524              
3525 146509         352241 return $node;
3526             } ## end sub _build_tree
3527              
3528             # Axis-parallel cut: random varying feature, random threshold in its range.
3529             # Returns [_NODE_AXIS, attr, split, \@left_pts, \@right_pts].
3530             # _build_tree overwrites slots 3 and 4 with the recursed subtrees.
3531             sub _axis_split {
3532 123727     123727   175887 my ( $X, $varying, $lo, $hi, $nan ) = @_;
3533              
3534 123727         180967 my $attr = $varying->[ int( rand( scalar @$varying ) ) ];
3535 123727         135482 my $split;
3536 123727         130368 if (_NV_IS_DOUBLE) {
3537 123727         167249 $split = $lo->[$attr] + rand() * ( $hi->[$attr] - $lo->[$attr] );
3538             } else {
3539             # Same value, but rounded to double after each of the three ops
3540             # exactly as the C builder computes it -- see _NV_IS_DOUBLE.
3541             $split = _to_double( $hi->[$attr] - $lo->[$attr] );
3542             $split = _to_double( rand() * $split );
3543             $split = _to_double( $lo->[$attr] + $split );
3544             }
3545              
3546             # A point missing the split feature (nan mode only) routes to the right
3547             # child -- the same side NaN reaches in the C scorer, where (NaN < split)
3548             # is false. Under die/zero/impute every cell is defined, so the
3549             # "defined($v)" guard is dead weight there and skipped entirely.
3550 123727         141201 my ( @left, @right );
3551 123727 100       153811 if ($nan) {
3552 15096         18527 for my $row (@$X) {
3553 239367         258376 my $v = $row->[$attr];
3554 239367 100 100     442823 if ( defined($v) && $v < $split ) { push @left, $row }
  111298         150998  
3555 128069         177415 else { push @right, $row }
3556             }
3557             } else {
3558 108631         130419 for my $row (@$X) {
3559 2196007 100       2662014 if ( $row->[$attr] < $split ) { push @left, $row }
  1096061         1383477  
3560 1099946         1412960 else { push @right, $row }
3561             }
3562             }
3563 123727         338423 return [ _NODE_AXIS, $attr, $split, \@left, \@right ];
3564             } ## end sub _axis_split
3565              
3566             # Oblique cut (Extended Isolation Forest): a random hyperplane. We activate
3567             # (extension_level + 1) of the varying features, give each a Gaussian
3568             # coefficient, and place the plane through a random point in the bounding box.
3569             # A point goes left when coef . x <= b, where b = coef . p.
3570             # Returns [_NODE_OBLIQUE, \@idx, \@coef, $b, \@left_pts, \@right_pts].
3571             # _build_tree overwrites slots 4 and 5 with the recursed subtrees.
3572             sub _oblique_split {
3573 22782     22782   36383 my ( $self, $X, $varying, $lo, $hi, $nan ) = @_;
3574              
3575 22782         29376 my $active = $self->{extension_level_used} + 1;
3576 22782 100       35635 $active = scalar @$varying if $active > scalar @$varying;
3577              
3578             # Pick which varying features take part (partial shuffle of their indices).
3579 22782         38497 my @pool = @$varying;
3580 22782         32741 for my $i ( 0 .. $active - 1 ) {
3581 43954         61762 my $j = $i + int( rand( scalar(@pool) - $i ) );
3582 43954         67596 @pool[ $i, $j ] = @pool[ $j, $i ];
3583             }
3584 22782         39342 my @idx = @pool[ 0 .. $active - 1 ];
3585              
3586 22782         29134 my ( @coef, $b );
3587 22782         26710 $b = 0.0;
3588 22782         28081 for my $f (@idx) {
3589 43954         55177 my $c = _randn();
3590 43954         49819 if (_NV_IS_DOUBLE) {
3591 43954         62034 my $p = $lo->[$f] + rand() * ( $hi->[$f] - $lo->[$f] ); # point in the box
3592 43954         54706 push @coef, $c;
3593 43954         56697 $b += $c * $p;
3594             } else {
3595             # Round each op to double in the same order as the C builder's
3596             # p = lo + rand() * (hi - lo); b += c * p;
3597             # -- see _NV_IS_DOUBLE.
3598             my $p = _to_double( rand() * _to_double( $hi->[$f] - $lo->[$f] ) );
3599             $p = _to_double( $lo->[$f] + $p );
3600             push @coef, $c;
3601             $b = _to_double( $b + _to_double( $c * $p ) );
3602             }
3603             } ## end for my $f (@idx)
3604              
3605             # A point missing any feature on the hyperplane (nan mode only) routes
3606             # to the right child: in the C scorer the dot product becomes NaN and
3607             # (NaN <= b) is false, so this keeps fit and score consistent. Under
3608             # die/zero/impute every cell is defined, so the per-feature "defined"
3609             # check and early-exit are dead weight there and skipped entirely.
3610 22782         26261 my ( @left, @right );
3611 22782 100       35528 if ($nan) {
3612 6947         10007 for my $row (@$X) {
3613 139686         148584 my $dot = 0.0;
3614 139686         142708 my $missing = 0;
3615 139686         183553 for ( 0 .. $#idx ) {
3616 262282         294241 my $v = $row->[ $idx[$_] ];
3617 262282 100       329836 if ( !defined $v ) { $missing = 1; last }
  26240         27595  
  26240         28592  
3618 236042         289284 $dot += $coef[$_] * $v;
3619             }
3620 139686 100 100     247069 if ( !$missing && $dot <= $b ) { push @left, $row }
  57761         76472  
3621 81925         111613 else { push @right, $row }
3622             } ## end for my $row (@$X)
3623             } else {
3624 15835         20019 for my $row (@$X) {
3625 400353         429770 my $dot = 0.0;
3626 400353         734297 $dot += $coef[$_] * $row->[ $idx[$_] ] for 0 .. $#idx;
3627 400353 100       498468 if ( $dot <= $b ) { push @left, $row }
  197051         246066  
3628 203302         254883 else { push @right, $row }
3629             }
3630             }
3631 22782         72696 return [ _NODE_OBLIQUE, \@idx, \@coef, $b, \@left, \@right ];
3632             } ## end sub _oblique_split
3633              
3634             #-------------------------------------------------------------------------------
3635             # Path length of a single point in a single tree: edges traversed until a leaf,
3636             # plus c(leaf size) when the leaf still holds several points.
3637             #
3638             # Node layout (arrayref, slot 0 = type):
3639             # _NODE_LEAF [0, size]
3640             # _NODE_AXIS [1, attr, split, left, right]
3641             # _NODE_OBLIQUE [2, \@idx, \@coef, b, left, right]
3642             #
3643             # The type tag is also used as a loop sentinel: 0 (_NODE_LEAF) is falsy.
3644             # No $self argument -- the node type encodes everything needed.
3645             #-------------------------------------------------------------------------------
3646             # The optional $nan flag selects the nan-strategy routing: a point missing
3647             # the split feature goes to the right child (matching the C scorer, where
3648             # the NaN comparison is false). Without it, undef is coerced to 0 -- the
3649             # behaviour the die/zero/impute strategies rely on (their data is dense by
3650             # the time it reaches here, so the "// 0" is normally a no-op).
3651             sub _path_length {
3652 409473     409473   537726 my ( $x, $node, $depth, $nan ) = @_;
3653 409473         556027 while ( $node->[0] ) { # false only for leaf (type 0)
3654 2879829 100       3430650 if ( $node->[0] == _NODE_AXIS ) { # [1, attr, split, left, right]
3655 2650147 100       3050194 if ($nan) {
3656 4852         5443 my $v = $x->[ $node->[1] ];
3657 4852 100 100     10762 $node = ( defined($v) && $v < $node->[2] ) ? $node->[3] : $node->[4];
3658             } else {
3659 2645295 100 100     4269414 $node = ( $x->[ $node->[1] ] // 0 ) < $node->[2] ? $node->[3] : $node->[4];
3660             }
3661             } else { # [2, \@idx, \@coef, b, left, right]
3662 229682         301517 my ( $idx, $coef, $b ) = ( $node->[1], $node->[2], $node->[3] );
3663 229682 100       272367 if ($nan) {
3664 3034         3167 my $dot = 0.0;
3665 3034         3133 my $missing = 0;
3666 3034         3945 for ( 0 .. $#$idx ) {
3667 4727         5892 my $v = $x->[ $idx->[$_] ];
3668 4727 100       6097 if ( !defined $v ) { $missing = 1; last }
  1920         2007  
  1920         2058  
3669 2807         4965 $dot += $coef->[$_] * $v;
3670             }
3671 3034 100 100     5653 $node = ( !$missing && $dot <= $b ) ? $node->[4] : $node->[5];
3672             } else {
3673 226648         233589 my $dot = 0.0;
3674 226648   100     542066 $dot += $coef->[$_] * ( $x->[ $idx->[$_] ] // 0 ) for 0 .. $#$idx;
3675 226648 100       317337 $node = $dot <= $b ? $node->[4] : $node->[5];
3676             }
3677             } ## end else [ if ( $node->[0] == _NODE_AXIS ) ]
3678 2879829         3846768 $depth++;
3679             } ## end while ( $node->[0] )
3680 409473         518776 return $depth + _c( $node->[1] ); # leaf size at slot 1
3681             } ## end sub _path_length
3682              
3683             # Recursively convert a version-0 hash-based tree node to the version-1
3684             # array format. Called by from_json when loading an old saved model.
3685             sub _hash_node_to_array {
3686 0     0   0 my ($node) = @_;
3687 0 0       0 if ( $node->{leaf} ) {
    0          
3688 0         0 return [ _NODE_LEAF, $node->{size} ];
3689             } elsif ( exists $node->{attr} ) {
3690             return [
3691             _NODE_AXIS, $node->{attr},
3692             $node->{split}, _hash_node_to_array( $node->{left} ),
3693 0         0 _hash_node_to_array( $node->{right} ),
3694             ];
3695             } else {
3696             return [
3697             _NODE_OBLIQUE, $node->{idx}, $node->{coef}, $node->{b},
3698             _hash_node_to_array( $node->{left} ),
3699 0         0 _hash_node_to_array( $node->{right} ),
3700             ];
3701             }
3702             } ## end sub _hash_node_to_array
3703              
3704             # ---------------------------------------------------------------------------
3705             # _pack_tree($root) -- flatten one tree into three packed buffers.
3706             #
3707             # Returns ($nodes_packed, $idx_packed, $val_packed) where:
3708             # nodes_packed: 6 doubles per node (see score_all_xs comment above)
3709             # idx_packed: int32 feature indices for every oblique-node coefficient
3710             # val_packed: double values matching idx_packed one-for-one
3711             #
3712             # Storing idx and val in separate buffers (SoA) instead of interleaved
3713             # doubles lets the oblique dot product's SIMD inner loop run over a
3714             # contiguous val[] stream without a per-iteration (int) cast, and
3715             # halves the index bandwidth (int32 vs double). The same `coff`
3716             # offset addresses paired entries in both buffers.
3717             #
3718             # Nodes are numbered in DFS pre-order: the root is always index 0 and
3719             # children always get indices larger than their parent's.
3720             # ---------------------------------------------------------------------------
3721             sub _pack_tree {
3722 6052     6052   9341 my ( $root, $n_features ) = @_;
3723 6052         11374 my ( @node_data, @coef_idx, @coef_val );
3724              
3725 6052         0 my $assign;
3726             $assign = sub {
3727 557390     557390   671993 my ($node) = @_;
3728 557390         606124 my $my_idx = scalar @node_data;
3729 557390         675473 push @node_data, undef; # reserve slot; filled in after children
3730              
3731 557390 100       854761 if ( $node->[0] == _NODE_LEAF ) {
    100          
3732              
3733             # Slot 2 carries c(size) precomputed, so the C scoring loop
3734             # adds it straight to the depth instead of paying a log()
3735             # per point per tree at every leaf hit. _c is the same
3736             # function the pure-Perl scorer uses, so both backends keep
3737             # producing bit-identical path lengths.
3738 281721         378889 $node_data[$my_idx] = [ 0.0, $node->[1] + 0.0, _c( $node->[1] ), 0.0, 0.0, 0.0 ];
3739             } elsif ( $node->[0] == _NODE_AXIS ) {
3740 245960         415007 my $li = $assign->( $node->[3] );
3741 245960         315673 my $ri = $assign->( $node->[4] );
3742 245960         478265 $node_data[$my_idx] = [
3743             1.0,
3744             $node->[1] + 0.0, # attr
3745             $node->[2] + 0.0, # split
3746             $li + 0.0,
3747             $ri + 0.0,
3748             0.0,
3749             ];
3750             } else { # _NODE_OBLIQUE
3751 29709         43864 my ( $idx_arr, $coef_arr, $b ) = ( $node->[1], $node->[2], $node->[3] );
3752 29709         33494 my $coef_off = scalar @coef_idx;
3753 29709         35235 my $num = scalar @$idx_arr;
3754              
3755             # Dense-pack opportunity: when this oblique split uses
3756             # every feature (extension_level == n_features - 1 and
3757             # all features vary), pack the coefficients in feature
3758             # order so val[k] is the coefficient for feature k. The
3759             # C scoring path then detects `nf == n_feats` and switches
3760             # to a no-gather inner loop (dot += val[k] * xi[k]) that
3761             # auto-vectorizes cleanly with FMA.
3762 29709 100 66     58160 if ( defined $n_features && $num == $n_features ) {
3763 25903         29378 my %coef_for;
3764 25903         58353 @coef_for{@$idx_arr} = @$coef_arr;
3765 25903         36834 for my $k ( 0 .. $n_features - 1 ) {
3766 60921         81824 push @coef_idx, $k;
3767 60921         101204 push @coef_val, $coef_for{$k} + 0.0;
3768             }
3769             } else {
3770 3806         5193 for my $i ( 0 .. $num - 1 ) {
3771 3811         5368 push @coef_idx, int( $idx_arr->[$i] );
3772 3811         5550 push @coef_val, $coef_arr->[$i] + 0.0;
3773             }
3774             }
3775              
3776 29709         54620 my $li = $assign->( $node->[4] );
3777 29709         38685 my $ri = $assign->( $node->[5] );
3778 29709         59752 $node_data[$my_idx] = [ 2.0, $coef_off + 0.0, $num + 0.0, $li + 0.0, $ri + 0.0, $b + 0.0, ];
3779             } ## end else [ if ( $node->[0] == _NODE_LEAF ) ]
3780 557390         703682 return $my_idx;
3781 6052         32291 }; ## end $assign = sub
3782 6052         12439 $assign->($root);
3783              
3784 6052         11929 my $nodes_packed = pack( 'd*', map { @$_ } @node_data );
  557390         1000167  
3785 6052 100       70038 my $idx_packed = @coef_idx ? pack( 'l*', @coef_idx ) : pack('l*');
3786 6052 100       11537 my $val_packed = @coef_val ? pack( 'd*', @coef_val ) : pack('d*');
3787 6052         17658 return ( $nodes_packed, $idx_packed, $val_packed );
3788             } ## end sub _pack_tree
3789              
3790             # Build packed C-ready representations for all trees and store them in
3791             # $self->{_c_nodes}, $self->{_c_coef_idx}, $self->{_c_coef_val}.
3792             # Called after fit() and from_json() when _use_c is true. n_features is
3793             # threaded through so _pack_tree can spot the dense-pack opportunity.
3794             sub _rebuild_c_trees {
3795 124     124   335 my ($self) = @_;
3796 124         258 my ( @c_nodes, @c_coef_idx, @c_coef_val );
3797 124         310 for my $tree ( @{ $self->{trees} } ) {
  124         482  
3798 6052         12366 my ( $np, $ip, $vp ) = _pack_tree( $tree, $self->{n_features} );
3799 6052         10998 push @c_nodes, $np;
3800 6052         9158 push @c_coef_idx, $ip;
3801 6052         13151 push @c_coef_val, $vp;
3802             }
3803 124         601 $self->{_c_nodes} = \@c_nodes;
3804 124         399 $self->{_c_coef_idx} = \@c_coef_idx;
3805 124         548 $self->{_c_coef_val} = \@c_coef_val;
3806             } ## end sub _rebuild_c_trees
3807              
3808             sub _check_fitted {
3809 55885     55885   96307 my ($self) = @_;
3810             croak "model is not fitted yet; call fit() first"
3811 55885 100 66     132438 unless ref $self->{trees} eq 'ARRAY' && @{ $self->{trees} };
  55885         163367  
3812             }
3813              
3814             # Memoised "does this perl have a real fork()?". False on Windows
3815             # without Cygwin; true on every Unix-like platform.
3816             {
3817             my $cached;
3818              
3819             sub _fork_supported {
3820 8 100   8   37 return $cached if defined $cached;
3821 2         27 require Config;
3822             $cached
3823 2 50 50     65 = ( ( $Config::Config{d_fork} || '' ) eq 'define' ) ? 1 : 0;
3824 2         10 return $cached;
3825             }
3826             }
3827              
3828             #-------------------------------------------------------------------------------
3829             # Fork-based parallel tree builder. Used by fit() when parallel_fit > 1
3830             # and the platform has a real fork(). Divides n_trees evenly among
3831             # workers; each child seeds its own RNG ($seed + worker_id * 1009 so
3832             # fixed-worker-count runs are reproducible), builds its share (via the
3833             # C builder when _use_c is on, same as the non-parallel path), and
3834             # returns the trees to the parent via Storable on a one-shot pipe.
3835             #
3836             # The trees that come back differ from a serial fit with the same seed
3837             # because the RNG draws happen in a different order -- this is documented
3838             # as part of the parallel_fit contract.
3839             #-------------------------------------------------------------------------------
3840             sub _fit_trees_parallel {
3841 8     8   26 my ( $self, $data, $psi, $limit, $workers ) = @_;
3842 8         77 require Storable;
3843 8         41 require POSIX;
3844              
3845 8         21 my $n_trees = $self->{n_trees};
3846 8 100       29 $workers = $n_trees if $workers > $n_trees;
3847              
3848             # Divide n_trees as evenly as possible across workers.
3849 8         16 my @shares;
3850             {
3851 8         17 my $base = int( $n_trees / $workers );
  8         26  
3852 8         17 my $extras = $n_trees - $base * $workers;
3853 8         49 for my $w ( 0 .. $workers - 1 ) {
3854 26 100       64 push @shares, $base + ( $w < $extras ? 1 : 0 );
3855             }
3856             }
3857              
3858 8         15 my @procs; # { pid, rh, share }
3859 8         37 for my $w ( 0 .. $workers - 1 ) {
3860 26         262 my $share = $shares[$w];
3861 26 50       250 next unless $share > 0;
3862              
3863 26 50       3303 pipe( my $rh, my $wh ) or croak "pipe failed: $!";
3864 26         58066 my $pid = fork();
3865 26 50       1560 croak "fork failed: $!" unless defined $pid;
3866              
3867 26 50       769 if ( $pid == 0 ) {
3868             # child
3869 0         0 close $rh;
3870 0         0 binmode $wh;
3871 0 0       0 if ( defined $self->{seed} ) {
3872 0         0 srand( $self->{seed} + $w * 1009 );
3873             }
3874             # Deliberately never _build_forest_openmp here, even when
3875             # use_openmp_fit is on: if this process (or the parent that
3876             # fork()ed us) already ran any OpenMP region before this
3877             # fork -- including plain score_samples()/predict() with
3878             # the default use_openmp -- libgomp's thread pool exists
3879             # but its worker threads didn't survive the fork. A child
3880             # starting its own #pragma omp parallel region then tries
3881             # to reuse that now-invalid pool and hangs. This is a
3882             # general fork()+libgomp limitation, not fixable from here,
3883             # so forked workers always use the single-threaded C
3884             # builder (or pure Perl) instead. See t/03-fit-determinism.t
3885             # and the NATIVE ACCELERATION docs for the observed hang and
3886             # why parallel_fit + use_openmp_fit isn't composed for real.
3887 0         0 my $trees;
3888 0 0       0 if ( $self->{_use_c} ) {
3889 0         0 $trees = $self->_build_forest_c( $data, $psi, $limit, $share );
3890             } else {
3891 0         0 my @t;
3892 0         0 for ( 1 .. $share ) {
3893 0         0 my $sample = _subsample( $data, $psi );
3894 0         0 push @t, $self->_build_tree( $sample, 0, $limit );
3895             }
3896 0         0 $trees = \@t;
3897             }
3898 0         0 print $wh Storable::freeze($trees);
3899 0         0 close $wh;
3900             # _exit so we don't run parent END/DESTROY in the child.
3901 0         0 POSIX::_exit(0);
3902             } ## end if ( $pid == 0 )
3903              
3904 26         1720 close $wh;
3905 26         557 binmode $rh;
3906 26         5920 push @procs, { pid => $pid, rh => $rh, share => $share };
3907             } ## end for my $w ( 0 .. $workers - 1 )
3908              
3909             # Collect from each pipe in worker order so the canonical tree
3910             # ordering is deterministic (worker 0's trees first, then 1's, ...).
3911 8         224 my @all_trees;
3912 8         133 for my $p (@procs) {
3913 26         77 my $buf;
3914             {
3915 26         74 local $/;
  26         828  
3916 26         46396 $buf = readline( $p->{rh} );
3917             }
3918 26         428 close $p->{rh};
3919 26         34622 waitpid( $p->{pid}, 0 );
3920 26         387 my $exit = $? >> 8;
3921 26 50       136 croak "parallel_fit worker $p->{pid} exited with status $exit"
3922             if $exit != 0;
3923 26         130 my $trees = eval { Storable::thaw($buf) };
  26         698  
3924 26 50 33     37421 croak "parallel_fit worker $p->{pid} returned unparseable trees: $@"
3925             if $@ || ref $trees ne 'ARRAY';
3926 26         239 push @all_trees, @$trees;
3927             } ## end for my $p (@procs)
3928              
3929 8         307 return \@all_trees;
3930             } ## end sub _fit_trees_parallel
3931              
3932             #-------------------------------------------------------------------------------
3933             # C-accelerated fit(): builds $n_trees trees against $data (a subset or
3934             # the full training set) via build_forest_xs, which does its own
3935             # per-tree subsampling internally. Random draws inside the C builder
3936             # go through Drand01() -- the same generator Perl's rand() uses -- in
3937             # the same call order _subsample/_build_tree used, so the returned
3938             # trees are bit-identical to what the pure-Perl path would build from
3939             # the same RNG state. That's what lets fit() switch backends on the
3940             # existing `use_c` knob instead of a new one.
3941             #-------------------------------------------------------------------------------
3942             sub _build_forest_c {
3943 79     79   286 my ( $self, $data, $psi, $limit, $n_trees ) = @_;
3944 79         180 my $n = scalar @$data;
3945 79         161 my $nf = $self->{n_features};
3946 79         4412 my $x_packed = "\0" x ( $n * $nf * 8 );
3947 79         1676 my ( $mode, $fill ) = $self->_pack_args;
3948 79         1660 pack_input_xs( $data, $x_packed, $n, $nf, $mode, $fill );
3949              
3950 79 100       265 my $mode_flag = $self->{mode} eq 'extended' ? 1 : 0;
3951 79   100     362 my $ext_level = $self->{extension_level_used} // 0;
3952              
3953 79         151 my $trees = [];
3954 79         265598 build_forest_xs( $x_packed, $n, $nf, $n_trees, $psi, $limit, $mode_flag, $ext_level, $trees );
3955 79         611 return $trees;
3956             } ## end sub _build_forest_c
3957              
3958             #-------------------------------------------------------------------------------
3959             # OpenMP-parallel fit(): builds $n_trees trees across OpenMP threads (one
3960             # tree per thread) via build_forest_openmp_xs. Unlike _build_forest_c,
3961             # random draws come from a thread-private PRNG seeded per tree index
3962             # rather than Drand01() -- Perl's RNG state can't be shared safely
3963             # across OpenMP threads -- so the resulting trees are NOT bit-identical
3964             # to the use_c (serial) or pure-Perl paths for the same seed, though a
3965             # fixed seed + n_trees still reproduce the same trees regardless of
3966             # OMP_NUM_THREADS. This is why it's gated by the separate, opt-in
3967             # use_openmp_fit knob rather than reusing use_c/use_openmp.
3968             #
3969             # Only called from fit()'s non-forked branch. _fit_trees_parallel's
3970             # workers never call this, even when use_openmp_fit is on: a forked
3971             # child starting its own OpenMP region after the parent process has
3972             # used OpenMP for anything (this includes plain score_samples()) can
3973             # hang -- see the comment above that branch for the fork()+libgomp
3974             # hazard this avoids.
3975             #
3976             # build_forest_openmp_xs hands back three arrayrefs of per-tree packed
3977             # buffers (the same SoA layout _pack_tree produces) instead of Perl tree
3978             # structures -- that's how it avoids any Perl API call inside its
3979             # parallel region. _unpack_forest converts them back into the ordinary
3980             # nested-arrayref tree shape so to_json/from_json/_rebuild_c_trees don't
3981             # need to know this path exists.
3982             #-------------------------------------------------------------------------------
3983             sub _build_forest_openmp {
3984 7     7   23 my ( $self, $data, $psi, $limit, $n_trees ) = @_;
3985 7         14 my $n = scalar @$data;
3986 7         13 my $nf = $self->{n_features};
3987 7         486 my $x_packed = "\0" x ( $n * $nf * 8 );
3988 7         31 my ( $mode, $fill ) = $self->_pack_args;
3989 7         107 pack_input_xs( $data, $x_packed, $n, $nf, $mode, $fill );
3990              
3991 7 100       23 my $mode_flag = $self->{mode} eq 'extended' ? 1 : 0;
3992 7   100     29 my $ext_level = $self->{extension_level_used} // 0;
3993              
3994 7         13 my ( @nodes, @idx, @val );
3995 7         17987 build_forest_openmp_xs( $x_packed, $n, $nf, $n_trees, $psi, $limit,
3996             $mode_flag, $ext_level, \@nodes, \@idx, \@val, 1 );
3997              
3998 7         53 return _unpack_forest( \@nodes, \@idx, \@val );
3999             } ## end sub _build_forest_openmp
4000              
4001             # Inverse of _pack_tree's SoA layout: given one tree's packed node
4002             # buffer plus the shared idx/val coefficient buffers, reconstructs the
4003             # ordinary nested-arrayref tree structure _build_tree/_build_node_c
4004             # produce. li/ri fields hold the child's absolute node index, so this
4005             # just follows them recursively from whatever index the caller says the
4006             # root lives at. NOTE: _pack_tree numbers nodes DFS pre-order (root at
4007             # 0), but build_forest_openmp_xs appends nodes post-order (children
4008             # before parent), putting the root LAST -- the caller must pass the
4009             # right root index for the buffer's origin.
4010             sub _unpack_node {
4011 12844     12844   17655 my ( $nodes, $idx, $val, $node_i ) = @_;
4012 12844         14822 my $off = $node_i * 6;
4013 12844         14438 my $type = $nodes->[$off];
4014              
4015 12844 100       18281 if ( $type == 0 ) {
    100          
4016 6582         23160 return [ _NODE_LEAF, int( $nodes->[ $off + 1 ] ) ];
4017             } elsif ( $type == 1 ) {
4018             my ( $attr, $split, $li, $ri )
4019 1604         2118 = @{$nodes}[ $off + 1 .. $off + 4 ];
  1604         2684  
4020             return [
4021 1604         2773 _NODE_AXIS, int($attr), $split,
4022             _unpack_node( $nodes, $idx, $val, int($li) ),
4023             _unpack_node( $nodes, $idx, $val, int($ri) ),
4024             ];
4025             } else {
4026 4658         6293 my ( $coff, $num, $li, $ri, $b ) = @{$nodes}[ $off + 1 .. $off + 5 ];
  4658         7259  
4027 4658         5835 $coff = int($coff);
4028 4658         5129 $num = int($num);
4029             return [
4030             _NODE_OBLIQUE,
4031 4658         7850 [ @{$idx}[ $coff .. $coff + $num - 1 ] ],
4032 4658         5813 [ @{$val}[ $coff .. $coff + $num - 1 ] ],
  4658         8972  
4033             $b,
4034             _unpack_node( $nodes, $idx, $val, int($li) ),
4035             _unpack_node( $nodes, $idx, $val, int($ri) ),
4036             ];
4037             } ## end else [ if ( $type == 0 ) ]
4038             } ## end sub _unpack_node
4039              
4040             # Unpacks every tree in the three per-tree packed-buffer arrayrefs
4041             # build_forest_openmp_xs returns into the ordinary nested tree shape.
4042             # The C builder pushes nodes post-order (a node is recorded after both
4043             # of its children), so each tree's root is the LAST node record, not
4044             # index 0 as in _pack_tree's pre-order layout.
4045             sub _unpack_forest {
4046 7     7   25 my ( $nodes_list, $idx_list, $val_list ) = @_;
4047 7         16 my @trees;
4048 7         30 for my $i ( 0 .. $#$nodes_list ) {
4049 320         2367 my @nodes = unpack( 'd*', $nodes_list->[$i] );
4050 320         1103 my @idx = unpack( 'l*', $idx_list->[$i] );
4051 320         968 my @val = unpack( 'd*', $val_list->[$i] );
4052 320         595 my $root = @nodes / 6 - 1;
4053 320         590 push @trees, _unpack_node( \@nodes, \@idx, \@val, $root );
4054             }
4055 7         50 return \@trees;
4056             } ## end sub _unpack_forest
4057              
4058             #-------------------------------------------------------------------------------
4059             # Packed input wrapper. pack_data() returns one of these so callers can
4060             # score the same dataset many times without re-walking the AV/AV refs on
4061             # every call -- a meaningful win at high feature counts where
4062             # pack_input_xs is a non-trivial slice of total scoring time.
4063             #
4064             # It's a minimal blessed hashref: { packed, n_pts, n_feats }. The C
4065             # scoring functions only need the packed bytes + dimensions.
4066             #-------------------------------------------------------------------------------
4067             sub pack_data {
4068 7     7 1 1956 my ( $self, $data ) = @_;
4069 7         24 $self->_check_fitted;
4070             croak "pack_data requires the Inline::C backend; install Inline::C"
4071 6 100       212 unless $self->{_use_c};
4072 5 100       242 croak "pack_data() expects an arrayref of samples"
4073             unless ref $data eq 'ARRAY';
4074 3         5 my $n_pts = scalar @$data;
4075 3         7 my $nf = $self->{n_features};
4076 3         11 my $x_packed = "\0" x ( $n_pts * $nf * 8 );
4077 3         18 my ( $mode, $fill ) = $self->_pack_args;
4078 3         46 pack_input_xs( $data, $x_packed, $n_pts, $nf, $mode, $fill );
4079 3         45 return bless {
4080             packed => $x_packed,
4081             n_pts => $n_pts,
4082             n_feats => $nf,
4083             },
4084             'Algorithm::Classifier::IsolationForest::PackedData';
4085             } ## end sub pack_data
4086              
4087             # Internal helper: given $data that may be a raw arrayref OR a PackedData
4088             # instance, return the (n_pts, n_feats, x_packed) triple ready for
4089             # score_all_xs. Called from every scoring fast path.
4090             sub _resolve_input {
4091 55759     55759   98406 my ( $self, $data ) = @_;
4092 55759 100       117856 if ( ref $data eq 'Algorithm::Classifier::IsolationForest::PackedData' ) {
4093             croak "PackedData has $data->{n_feats} features but model expects " . $self->{n_features}
4094 24189 100       52988 unless $data->{n_feats} == $self->{n_features};
4095 24188         62919 return ( $data->{n_pts}, $data->{n_feats}, $data->{packed} );
4096             }
4097 31570         53502 my $n_pts = scalar @$data;
4098 31570         54801 my $nf = $self->{n_features};
4099 31570         58983 my $x_packed = "\0" x ( $n_pts * $nf * 8 );
4100 31570         61353 my ( $mode, $fill ) = $self->_pack_args;
4101 31570         114896 pack_input_xs( $data, $x_packed, $n_pts, $nf, $mode, $fill );
4102 31570         73490 return ( $n_pts, $nf, $x_packed );
4103             } ## end sub _resolve_input
4104              
4105             # Helper used by the pure-Perl fallback paths: convert either form back
4106             # to an arrayref-of-arrayrefs. Slow on PackedData -- the whole point of
4107             # packing is to keep things in C -- but lets the fallback path be
4108             # uniformly arrayref-driven.
4109             sub _to_arrayref {
4110 95     95   194 my ( $self, $data ) = @_;
4111 95 50       357 return $data if ref $data eq 'ARRAY';
4112 0 0       0 if ( ref $data eq 'Algorithm::Classifier::IsolationForest::PackedData' ) {
4113 0         0 my $n_pts = $data->{n_pts};
4114 0         0 my $nf = $data->{n_feats};
4115 0         0 my @doubles = unpack( 'd*', $data->{packed} );
4116 0         0 my @rows;
4117 0         0 for my $i ( 0 .. $n_pts - 1 ) {
4118 0         0 push @rows, [ @doubles[ $i * $nf .. ( $i + 1 ) * $nf - 1 ] ];
4119             }
4120 0         0 return \@rows;
4121             } ## end if ( ref $data eq 'Algorithm::Classifier::IsolationForest::PackedData')
4122 0   0     0 croak "expected arrayref or PackedData, got " . ( ref($data) || 'scalar' );
4123             } ## end sub _to_arrayref
4124              
4125             # ---------------------------------------------------------------------------
4126             # Missing-value handling.
4127             #
4128             # The `missing` strategy chosen at new() decides how undef feature cells are
4129             # treated. Scoring always tolerates undef; the strategy governs fit() and
4130             # how undef is represented for the scorer:
4131             #
4132             # die -- croak from fit() if the training data holds any undef cell.
4133             # Scoring still maps undef -> 0 (the long-standing behaviour).
4134             # zero -- undef counts as the value 0, at fit and score time.
4135             # impute -- undef is replaced by a learned per-feature mean/median; the
4136             # fill vector is stored on the model and reused at score time.
4137             # nan -- ranges are built over present values only and a point missing
4138             # the split feature is routed to the right child, consistently
4139             # at fit (Perl) and score (C packs NaN; `<`/`<=` send it right).
4140             # ---------------------------------------------------------------------------
4141              
4142             # Returns the training data to actually build trees on, after applying the
4143             # missing-value strategy. May croak (die), return a dense filled copy
4144             # (zero/impute), or pass $data through unchanged (nan).
4145             sub _prepare_fit_data {
4146 149     149   322 my ( $self, $data ) = @_;
4147 149         309 my $m = $self->{missing};
4148 149         281 my $nf = $self->{n_features};
4149              
4150 149 100       410 if ( $m eq 'die' ) {
4151 123         454 for my $i ( 0 .. $#$data ) {
4152 16439         21334 my $row = $data->[$i];
4153 16439         21039 for my $f ( 0 .. $nf - 1 ) {
4154 45880 100       70045 next if defined $row->[$f];
4155 2         364 croak "fit(): undef feature value at sample $i, column $f; "
4156             . "construct with missing => 'zero', 'impute', or 'nan' "
4157             . "to train on data with missing values";
4158             }
4159             }
4160 121         372 return $data;
4161             } ## end if ( $m eq 'die' )
4162              
4163             # nan: leave undef in place -- _build_tree / the split routers handle it.
4164 26 100       101 return $data if $m eq 'nan';
4165              
4166             # zero / impute: undef has to become a real number somewhere before a
4167             # split can look at it. The fill vector is computed either way (it's
4168             # needed for persistence and for scoring later), but densifying $data
4169             # into a second, fully separate Perl array here is only necessary for
4170             # the pure-Perl tree builder (_build_tree assumes every cell is
4171             # defined once missing != 'nan' -- see its lo/hi scan). The C
4172             # tree-building path -- _build_forest_c/_build_forest_openmp, and
4173             # every parallel_fit worker, all of which go through pack_input_xs --
4174             # already fills undef cells itself from this same fill vector, so
4175             # skip the redundant whole-dataset copy when that's the path fit()
4176             # will actually take. Scoring the training set for a learned
4177             # contamination threshold (below, in fit()) is unaffected: it always
4178             # runs through the pure-Perl scorer regardless of use_c (fit() drops
4179             # any previous fit's packed buffers before that scoring, and
4180             # _rebuild_c_trees runs after), and that path already tolerates raw
4181             # undef cells
4182             # for both zero (_path_length's "// 0") and impute (_prepare_perl_input
4183             # densifies on demand from missing_fill).
4184 18 100       219 my $fill
4185             = $m eq 'impute'
4186             ? $self->_compute_impute_fill($data)
4187             : [ (0) x $nf ];
4188 14 100       49 $self->{missing_fill} = $fill if $m eq 'impute';
4189 14         61 delete $self->{_fill_packed};
4190              
4191 14 100       379 return $data if $self->{_use_c};
4192 7         26 return _densify( $data, $fill );
4193             } ## end sub _prepare_fit_data
4194              
4195             # Per-feature fill value (mean or median of the present values) for impute
4196             # mode. Croaks if a feature has no present value to learn from.
4197             sub _compute_impute_fill {
4198 12     12   28 my ( $self, $data ) = @_;
4199 12         24 my $nf = $self->{n_features};
4200 12         27 my $how = $self->{impute_with};
4201              
4202             # C fast path: walks the raw data directly and finds the median via
4203             # quickselect (O(n) average) instead of the Perl fallback's full sort
4204             # (O(n log n)). Produces the same fill values either way -- see
4205             # impute_fill_xs's file-top comment -- so use_c only changes speed
4206             # here, matching the rest of the module.
4207 12 100       38 if ( $self->{_use_c} ) {
4208 6         14 my $n = scalar @$data;
4209 6 100       18 my $how_flag = $how eq 'median' ? 1 : 0;
4210 6         13 my $fill = [];
4211 6         6437 impute_fill_xs( $data, $n, $nf, $how_flag, $fill );
4212 4         21 return $fill;
4213             }
4214              
4215 6         10 my @fill;
4216 6         22 for my $f ( 0 .. $nf - 1 ) {
4217 12         37 my @vals = grep { defined } map { $_->[$f] } @$data;
  2484         6881  
  2484         3351  
4218 12 100       504 croak "impute: feature column $f has no present values"
4219             unless @vals;
4220 10 100       27 if ( $how eq 'median' ) {
4221 4         1119 my @s = sort { $a <=> $b } @vals;
  2942         3192  
4222 4         8 my $k = scalar @s;
4223 4 100       37 $fill[$f]
4224             = $k % 2
4225             ? $s[ int( $k / 2 ) ]
4226             : ( $s[ $k / 2 - 1 ] + $s[ $k / 2 ] ) / 2.0;
4227             } else { # mean
4228 6         9 my $sum = 0;
4229 6         9 if (_NV_IS_DOUBLE) {
4230 6         130 $sum += $_ for @vals;
4231             } else {
4232             # impute_fill_xs accumulates the sum in double (over
4233             # SvNV-truncated cells); match its rounding step for step.
4234             $sum = _to_double( $sum + _to_double($_) ) for @vals;
4235             }
4236 6         16 $fill[$f] = $sum / scalar @vals;
4237             } ## end else [ if ( $how eq 'median' ) ]
4238              
4239             # The fill crosses into the C backend as a double (pack 'd' /
4240             # SvNV), so on wide-NV perls store it already narrowed and both
4241             # builders densify with the identical value.
4242 10         47 $fill[$f] = _to_double( $fill[$f] ) unless _NV_IS_DOUBLE;
4243             } ## end for my $f ( 0 .. $nf - 1 )
4244 4         13 return \@fill;
4245             } ## end sub _compute_impute_fill
4246              
4247             # Return a dense copy of $data with every undef cell replaced by the
4248             # matching per-feature fill value. Leaves present cells untouched.
4249             sub _densify {
4250 10     10   25 my ( $data, $fill ) = @_;
4251 10         20 my $nf = scalar @$fill;
4252             return [
4253             map {
4254 10         32 my $r = $_;
  1886         2017  
4255 1886 100       2174 [ map { defined $r->[$_] ? $r->[$_] : $fill->[$_] } 0 .. $nf - 1 ]
  4078         6873  
4256             } @$data
4257             ];
4258             } ## end sub _densify
4259              
4260             # (miss_mode, fill_packed) pair for pack_input_xs, per the active strategy.
4261             # die/zero -> 0 (undef becomes 0.0); impute -> 1 (undef becomes fill[k]);
4262             # nan -> 2 (undef becomes NaN, which the C scorer routes right).
4263             sub _pack_args {
4264 31659     31659   53821 my ($self) = @_;
4265 31659         54629 my $m = $self->{missing};
4266 31659 100       65985 return ( 2, '' ) if $m eq 'nan';
4267 31650 100       63531 if ( $m eq 'impute' ) {
4268 9         23 my $fill = $self->{missing_fill};
4269             croak "impute model is missing its fill vector"
4270 9 50 33     53 unless ref $fill eq 'ARRAY' && @$fill == $self->{n_features};
4271 9   66     76 $self->{_fill_packed} //= pack( 'd*', @$fill );
4272 9         28 return ( 1, $self->{_fill_packed} );
4273             }
4274 31641         66074 return ( 0, '' ); # die, zero
4275             } ## end sub _pack_args
4276              
4277             # Pure-Perl fallback input prep: arrayref-ify, then fill for impute so the
4278             # tree walk sees dense rows. zero/die rely on _path_length's "// 0"; nan
4279             # keeps undef in place for _path_length to route. Returns the rows; the
4280             # caller passes the nan flag to _path_length separately.
4281             sub _prepare_perl_input {
4282 74     74   169 my ( $self, $data ) = @_;
4283 74         340 my $rows = $self->_to_arrayref($data);
4284 74 100       239 if ( $self->{missing} eq 'impute' ) {
4285             croak "impute model is missing its fill vector"
4286 3 50       33 unless ref $self->{missing_fill} eq 'ARRAY';
4287 3         13 $rows = _densify( $rows, $self->{missing_fill} );
4288             }
4289 74         152 return $rows;
4290             } ## end sub _prepare_perl_input
4291              
4292             # Minimal PackedData package: opaque token returned by pack_data().
4293             # Exposes n_pts and n_feats accessors for users who want to introspect.
4294             {
4295              
4296             package Algorithm::Classifier::IsolationForest::PackedData;
4297 4     4   564 sub n_pts { $_[0]->{n_pts} }
4298 4     4   22 sub n_feats { $_[0]->{n_feats} }
4299             }
4300              
4301             1;