File Coverage

LikeR.xs
Criterion Covered Total %
statement 6003 6614 90.7
branch 4731 6706 70.5
condition n/a
subroutine n/a
pod n/a
total 10734 13320 80.5


line stmt bran cond sub pod time code
1             #ifndef _GNU_SOURCE
2             #define _GNU_SOURCE // glibc / Linux
3             #endif
4             #ifndef __EXTENSIONS__
5             #define __EXTENSIONS__ 1 // Solaris/illumos: expose off64_t, sigjmp_buf under -std=c99
6             #endif
7             #define PERL_NO_GET_CONTEXT
8             #include "EXTERN.h"
9             #include "perl.h"
10             #include "XSUB.h"
11             #include "ppport.h"
12             #include
13             #include
14             #include
15             #include
16             #include
17             #include
18             #include // uint64_t — harmless if perl.h already pulled it in
19             /*
20             XS words:
21             SvROK = scalar value reference is OK
22             */
23             /* sample(): private splitmix64 PRNG
24              
25             sample() gets its own PRNG state, completely separate from Drand01.
26             That means generate_binomial(), ruif(), rbinom(), and every other caller
27             of Drand01() are unaffected — their streams are never advanced or reseeded
28             by anything sample() does.
29              
30             Seeding is lazy (first call) and reads from /dev/urandom; falls back to
31             time()^PID on systems without it. No aTHX needed: all calls are plain C.
32             PERL_NO_GET_CONTEXT is therefore not a concern here. */
33             static uint64_t sample__state = 0;
34              
35             PERL_STATIC_INLINE uint64_t
36             sample__mix64(void)
37             {
38             uint64_t z = (sample__state += UINT64_C(0x9e3779b97f4a7c15));
39             z = (z ^ (z >> 30)) * UINT64_C(0xbf58476d1ce4e5b9);
40             z = (z ^ (z >> 27)) * UINT64_C(0x94d049bb133111eb);
41             return z ^ (z >> 31);
42             }
43              
44             /* * Helper function to increment the count for a given SV.
45             * Skips NULL or Undefined values as requested. */
46 26           static void increment_count(pTHX_ HV* counts_hv, SV* val) {
47             /* Skip null pointers or undef (non-OK) values */
48 26 50         if (!val || !SvOK(val)) return;
    50          
49             STRLEN len;
50             // SvPV forces stringification (so numbers become string keys)
51 26           char*restrict str = SvPV(val, len);
52             // hv_fetch with lval=1 creates the key if it doesn't exist
53 26           SV**restrict svp = hv_fetch(counts_hv, str, len, 1);
54 26 50         if (svp) {
55 26 100         if (!SvOK(*svp)) {
56 17           sv_setuv(*svp, 1);// Initialize count to 1 as an Unsigned Value (UV)
57             } else {
58 9           sv_setuv(*svp, SvUV(*svp) + 1);// Increment existing Unsigned Value
59             }
60             }
61             }
62              
63             // Uniform integer in [0, upper) — rejection loop, no modulo bias
64             PERL_STATIC_INLINE size_t
65             sample__rand(size_t upper) {
66             const uint64_t u = (uint64_t)upper;
67             const uint64_t t = (uint64_t)(-(uint64_t)u) % u;
68             uint64_t r;
69             do { r = sample__mix64(); } while (r < t);
70             return (size_t)(r % u);
71             }
72             // end sample() private PRNG
73              
74             // Ensure Perl's PRNG is seeded, matching the lazy-evaluation of Perl's rand()
75             #define AUTO_SEED_PRNG() \
76             do { \
77             if (!PL_srand_called) { \
78             (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); \
79             PL_srand_called = TRUE; \
80             } \
81             } while (0)
82              
83             // Helpers for Random Number Generation
84             #ifndef M_PI
85             #define M_PI 3.14159265358979323846
86             #endif
87             // C helper for EXACT Non-central T-distribution CDF via Numerical Integration.
88             // This perfectly replicates R's pt(..., ncp) exactness without requiring complex Beta functions.
89 229           static NV exact_pnt(NV t, NV df, NV ncp) {
90 229 50         if (df <= 0.0) return 0.0;
91 229           unsigned short int n_steps = 30000;
92 229           NV step = 1.0 / n_steps;
93 229           NV integral = 0.0, half_df = df / 2.0;
94 229           NV log_coef = log(2.0) + half_df * log(half_df) - lgamma(half_df);
95 229           NV root_half = 0.70710678118654752440; // 1 / sqrt(2)
96 6870000 100         for (unsigned short i = 1; i < n_steps; i++) {
97 6869771           NV u = i * step;
98 6869771           NV w = u / (1.0 - u);
99             // Scaled Chi-distribution log-density
100 6869771           NV log_M = log_coef + (df - 1.0) * log(w) - half_df * w * w;
101 6869771           NV M = exp(log_M);
102             // Exact Normal CDF using the C standard library's erfc function
103 6869771           NV z = t * w - ncp;
104 6869771           NV pnorm_val = 0.5 * erfc(-z * root_half);
105 6869771 100         NV weight = (i % 2 != 0) ? 4.0 : 2.0;
106 6869771           integral += weight * (pnorm_val * M / ((1.0 - u) * (1.0 - u)));
107             }
108 229           return integral * (step / 3.0);
109             }
110             // --- Math Helpers for P-values and Confidence Intervals ---
111              
112             // Ranking helper with tie adjustment (matches R's tie handling)
113             typedef struct { NV val; size_t idx; NV rank; } RankInfo;
114 75           static int compare_rank(const void *restrict a, const void *restrict b) {
115 75           NV diff = ((RankInfo*)a)->val - ((RankInfo*)b)->val;
116 75           return (diff > 0) - (diff < 0);
117             }
118              
119 75           static int compare_index(const void *restrict a, const void *restrict b) {
120 75           return ((RankInfo*)a)->idx - ((RankInfo*)b)->idx;
121             }
122              
123 6           static void compute_ranks(NV *restrict data, NV *restrict ranks, size_t n) {
124 6           RankInfo *restrict items = safemalloc(n * sizeof(RankInfo));
125 56 100         for (size_t i = 0; i < n; i++) {
126 50           items[i].val = data[i];
127 50           items[i].idx = i;
128             }
129 6           qsort(items, n, sizeof(RankInfo), compare_rank);
130             // Handle ties by averaging ranks
131 56 100         for (size_t i = 0; i < n; ) {
132 50           size_t j = i + 1;
133 50 100         while (j < n && items[j].val == items[i].val) j++;
    50          
134 50           NV avg_rank = (i + 1 + j) / 2.0;
135 100 100         for (size_t k = i; k < j; k++) items[k].rank = avg_rank;
136 50           i = j;
137             }
138 6           qsort(items, n, sizeof(RankInfo), compare_index);
139 56 100         for (size_t i = 0; i < n; i++) ranks[i] = items[i].rank;
140 6           Safefree(items);
141 6           }
142             // Generates a single binomial random variate.
143             //Uses the standard Bernoulli trial loop. Drand01() taps into Perl's PRNG.
144 20499           static size_t generate_binomial(pTHX_ const size_t size, const NV prob) {
145 20499 100         if (prob <= 0.0) return 0;
146 20399 100         if (prob >= 1.0) return size;
147              
148 20299           size_t successes = 0;
149 312290 100         for (size_t i = 0; i < size; i++) {
150 291991 100         if (Drand01() <= prob) successes++;
151             }
152 20299           return successes;
153             }
154              
155             #define FT_EPS 2.220446049250313e-16
156             #define FT_TOL 0.0001220703125 // .Machine$double.eps^0.25, R uniroot default
157              
158 546           static NV ft_lchoose(long n, long k) {
159 546 50         if (k < 0 || k > n || n < 0) return -INFINITY;
    50          
    50          
160 546           return lgamma((NV)n + 1) - lgamma((NV)k + 1) - lgamma((NV)(n - k) + 1);
161             }
162              
163             typedef struct {
164             long lo, hi, ns, m, n, k, x;
165             NV *restrict logdc; // central log hypergeometric density over the support
166             } ft_support;
167              
168 26           static int ft_init(ft_support *S, long a, long b, long c, long d) {
169 26           S->m = a + c; S->n = b + d; S->k = a + b; S->x = a;
170 26           S->lo = (S->k - S->n > 0) ? (S->k - S->n) : 0;
171 26           S->hi = (S->k < S->m) ? S->k : S->m;
172 26           S->ns = S->hi - S->lo + 1;
173 26 50         if (S->ns <= 0) { S->logdc = NULL; return 0; }
174 26 50         Newx(S->logdc, S->ns, NV);
175 208 100         for (long i = 0; i < S->ns; i++) {
176 182           long j = S->lo + i;
177 182           S->logdc[i] = ft_lchoose(S->m, j) + ft_lchoose(S->n, S->k - j)
178 182           - ft_lchoose(S->m + S->n, S->k);
179             }
180 26           return 1;
181             }
182 26           static void ft_free(ft_support *S) { Safefree(S->logdc); S->logdc = NULL; }
183              
184 233           static void ft_dnhyper(const ft_support *S, NV ncp, NV *out) {
185 233           NV lncp = log(ncp), mx = -INFINITY;
186 2015 100         for (long i = 0; i < S->ns; i++) {
187 1782           out[i] = S->logdc[i] + lncp * (NV)(S->lo + i);
188 1782 100         if (out[i] > mx) mx = out[i];
189             }
190 233           NV s = 0;
191 2015 100         for (long i = 0; i < S->ns; i++) { out[i] = exp(out[i] - mx); s += out[i]; }
192 2015 100         for (long i = 0; i < S->ns; i++) out[i] /= s;
193 233           }
194              
195 93           static NV ft_mnhyper(const ft_support *restrict S, NV ncp, NV *scratch) {
196 93 100         if (ncp == 0) return (NV)S->lo;
197 91 50         if (isinf(ncp)) return (NV)S->hi;
198 91           ft_dnhyper(S, ncp, scratch);
199 91           NV mu = 0;
200 770 100         for (long i = 0; i < S->ns; i++) mu += (NV)(S->lo + i) * scratch[i];
201 91           return mu;
202             }
203              
204             // upper != 0 => P(X >= q), upper == 0 => P(X <= q)
205 185           static NV ft_pnhyper(const ft_support *S, long q, NV ncp, int upper, NV *scratch) {
206 185 100         if (ncp == 1.0) {
207 42           NV s = 0;
208 344 100         for (long i = 0; i < S->ns; i++) {
209 302           long j = S->lo + i;
210 302 100         if (upper ? (j >= q) : (j <= q)) s += exp(S->logdc[i]);
    100          
211             }
212 42           return s;
213             }
214 143 100         if (ncp == 0.0) return upper ? (NV)(q <= S->lo) : (NV)(q >= S->lo);
    100          
    50          
    50          
215 133 50         if (isinf(ncp)) return upper ? (NV)(q <= S->hi) : (NV)(q >= S->hi);
    0          
    0          
    0          
216 133           ft_dnhyper(S, ncp, scratch);
217 133           NV s = 0;
218 1173 100         for (long i = 0; i < S->ns; i++) {
219 1040           long j = S->lo + i;
220 1040 100         if (upper ? (j >= q) : (j <= q)) s += scratch[i];
    100          
221             }
222 133           return s;
223             }
224              
225             /* R's src/library/stats/src/zeroin.c (Brent-Dekker) */
226             typedef NV (*ft_fn)(NV t, void *ctx);
227 29           static NV ft_zeroin(NV ax, NV bx, ft_fn f, void *ctx, NV tol, int maxit) {
228 29           NV a = ax, b = bx, fa = f(a, ctx), fb = f(b, ctx), c = a, fc = fa;
229 216 50         while (maxit-- > 0) {
230 216           NV prev = b - a;
231 216 100         if (fabs(fc) < fabs(fb)) { a = b; b = c; c = a; fa = fb; fb = fc; fc = fa; }
232 216           NV tol_act = 2 * FT_EPS * fabs(b) + tol / 2;
233 216           NV step = (c - b) / 2;
234 216 100         if (fabs(step) <= tol_act || fb == 0.0) return b;
    50          
235 187 50         if (fabs(prev) >= tol_act && fabs(fa) > fabs(fb)) {
    50          
236 187           NV cb = c - b, p, q;
237 187 100         if (a == c) { NV t1 = fb / fa; p = cb * t1; q = 1.0 - t1; }
238             else {
239 68           NV q0 = fa / fc, t1 = fb / fc, t2 = fb / fa;
240 68           p = t2 * (cb * q0 * (q0 - t1) - (b - a) * (t1 - 1.0));
241 68           q = (q0 - 1.0) * (t1 - 1.0) * (t2 - 1.0);
242             }
243 187 100         if (p > 0) q = -q; else p = -p;
244 187 100         if (p < 0.75 * cb * q - fabs(tol_act * q) / 2 && p < fabs(prev * q / 2)) step = p / q;
    100          
245             }
246 187 100         if (fabs(step) < tol_act) step = step > 0 ? tol_act : -tol_act;
    100          
247 187           a = b; fa = fb; b += step; fb = f(b, ctx);
248 187 100         if ((fb > 0) == (fc > 0)) { c = a; fc = fa; }
249             }
250 0           return b;
251             }
252              
253             typedef struct { const ft_support *S; NV target; NV *scratch; int mode; } ft_rc;
254             /* mode 0: mnhyper(t)-target 1: mnhyper(1/t)-target
255             mode 2: pnhyper(x,t,low)-tgt 3: pnhyper(x,1/t,low)-tgt
256             mode 4: pnhyper(x,t,up)-tgt 5: pnhyper(x,1/t,up)-tgt */
257 245           static NV ft_rootf(NV t, void *ctx) {
258 245           ft_rc *r = (ft_rc *)ctx; const ft_support *S = r->S;
259 245           switch (r->mode) {
260 18           case 0: return ft_mnhyper(S, t, r->scratch) - r->target;
261 65           case 1: return ft_mnhyper(S, 1.0 / t, r->scratch) - r->target;
262 31           case 2: return ft_pnhyper(S, S->x, t, 0, r->scratch) - r->target;
263 40           case 3: return ft_pnhyper(S, S->x, 1.0 / t, 0, r->scratch) - r->target;
264 62           case 4: return ft_pnhyper(S, S->x, t, 1, r->scratch) - r->target;
265 29           default:return ft_pnhyper(S, S->x, 1.0 / t, 1, r->scratch) - r->target;
266             }
267             }
268              
269 13           static NV exact_p_value(long a, long b, long c, long d, const char *alt) {
270             ft_support S;
271 13 50         if (!ft_init(&S, a, b, c, d)) return 1.0;
272 13 50         NV *restrict sc; Newx(sc, S.ns, NV);
273             NV p;
274 13 100         if (!strcmp(alt, "less")) p = ft_pnhyper(&S, S.x, 1.0, 0, sc);
275 11 100         else if (!strcmp(alt, "greater")) p = ft_pnhyper(&S, S.x, 1.0, 1, sc);
276             else {
277 9           ft_dnhyper(&S, 1.0, sc);
278 9           NV dx = sc[S.x - S.lo], relErr = 1 + 1e-7, s = 0;
279 72 100         for (long i = 0; i < S.ns; i++) if (sc[i] <= dx * relErr) s += sc[i];
    100          
280 9           p = s;
281             }
282 13 50         if (p < 0) p = 0; if (p > 1) p = 1;
    50          
283 13           Safefree(sc); ft_free(&S);
284 13           return p;
285             }
286              
287 13           static void calculate_exact_stats(long a, long b, long c, long d, NV conf,
288             const char *alt, NV *orp, NV *lop, NV *hip) {
289             ft_support S;
290 13 50         if (!ft_init(&S, a, b, c, d)) { *orp = NAN; *lop = NAN; *hip = NAN; return; }
291 13 50         NV *restrict sc; Newx(sc, S.ns, NV);
292 13           long x = S.x, lo = S.lo, hi = S.hi;
293              
294             // conditional MLE of the odds ratio
295             NV est;
296 13 100         if (x == lo) est = 0.0;
297 12 100         else if (x == hi) est = INFINITY;
298             else {
299 10           NV mu = ft_mnhyper(&S, 1.0, sc);
300 10           ft_rc r = { &S, (NV)x, sc, 0 };
301 10 100         if (mu > x) { r.mode = 0; est = ft_zeroin(0, 1, ft_rootf, &r, FT_TOL, 1000); }
302 8 50         else if (mu < x) { r.mode = 1; est = 1.0 / ft_zeroin(FT_EPS, 1, ft_rootf, &r, FT_TOL, 1000); }
303 0           else est = 1.0;
304             }
305 13           *orp = est;
306             // confidence interval via inversion of the noncentral hypergeometric
307             NV clo, chi;
308 13           ft_rc r = { &S, 0, sc, 0 };
309             #define FT_NCP_L(alpha, dst) do { \
310             if (x == lo) { dst = 0.0; } else { \
311             NV p = ft_pnhyper(&S, x, 1.0, 1, sc); \
312             if (p > (alpha)) { r.mode = 4; r.target = (alpha); dst = ft_zeroin(0, 1, ft_rootf, &r, FT_TOL, 1000); } \
313             else if (p < (alpha)) { r.mode = 5; r.target = (alpha); dst = 1.0 / ft_zeroin(FT_EPS, 1, ft_rootf, &r, FT_TOL, 1000); } \
314             else dst = 1.0; } } while (0)
315             #define FT_NCP_U(alpha, dst) do { \
316             if (x == hi) { dst = INFINITY; } else { \
317             NV p = ft_pnhyper(&S, x, 1.0, 0, sc); \
318             if (p < (alpha)) { r.mode = 2; r.target = (alpha); dst = ft_zeroin(0, 1, ft_rootf, &r, FT_TOL, 1000); } \
319             else if (p > (alpha)) { r.mode = 3; r.target = (alpha); dst = 1.0 / ft_zeroin(FT_EPS, 1, ft_rootf, &r, FT_TOL, 1000); } \
320             else dst = 1.0; } } while (0)
321              
322 13 100         if (!strcmp(alt, "less")) { clo = 0.0; FT_NCP_U(1 - conf, chi); }
    50          
    100          
    50          
323 11 100         else if (!strcmp(alt, "greater")) { FT_NCP_L(1 - conf, clo); chi = INFINITY; }
    50          
    50          
    0          
324 9 100         else { NV al = (1 - conf) / 2; FT_NCP_L(al, clo); FT_NCP_U(al, chi); }
    100          
    50          
    100          
    100          
    50          
325              
326 13           *lop = clo; *hip = chi;
327 13           Safefree(sc); ft_free(&S);
328             }
329              
330             // small helper: fetch a nonnegative integer cell from an SV, with validation
331 56           static long ft_cell(pTHX_ SV *sv, const char *what) {
332 56 50         if (!sv || !SvOK(sv)) croak("fisher_test: %s is undef", what);
    50          
333 56 50         if (!looks_like_number(sv)) croak("fisher_test: %s is not a number", what);
334 56           IV v = SvIV(sv);
335 56 100         if (v < 0) croak("fisher_test: %s must be nonnegative (got %" IVdf ")", what, v);
336 55           return (long)v;
337             }
338              
339             /*Helpers for lm Linear Regression: OLS Matrix Math & Formula Parsing
340             * -----------------------------------------------------------------------
341             Sweep operator for symmetric positive-definite matrices (e.g., XtX).
342             This gracefully handles collinearity by bypassing aliased columns.
343             Utilizes a relative tolerance check to prevent dropping micro-variance features.*/
344 75           static int sweep_matrix_ols(NV *restrict A, size_t n, bool *restrict aliased) {
345 75           int rank = 0;
346 75           NV *restrict orig_diag = (NV*)safemalloc(n * sizeof(NV));
347             // Save the original diagonal values to use as a baseline for relative variance
348 312 100         for (size_t k = 0; k < n; k++) {
349 237           aliased[k] = FALSE;
350 237           orig_diag[k] = A[k * n + k];
351             }
352 312 100         for (size_t k = 0; k < n; k++) {
353             // Check pivot for collinearity using a RELATIVE tolerance
354             // (Fallback to a tiny absolute tolerance of 1e-24 to catch literal zero vectors)
355 237 100         if (fabs(A[k * n + k]) <= 1e-10 * orig_diag[k] || fabs(A[k * n + k]) < 1e-24) {
    50          
356 49           aliased[k] = TRUE;
357             // Isolate this column so it doesn't affect the rest of the matrix
358 2500 100         for (size_t i = 0; i < n; i++) {
359 2451           A[k * n + i] = 0.0;
360 2451           A[i * n + k] = 0.0;
361             }
362 49           continue;
363             }
364 188           rank++;
365 188           NV pivot = 1.0 / A[k * n + k];
366 188           A[k * n + k] = 1.0;
367 832 100         for (size_t j = 0; j < n; j++) A[k * n + j] *= pivot;
368 832 100         for (size_t i = 0; i < n; i++) {
369 644 100         if (i != k && A[i * n + k] != 0.0) {
    100          
370 450           NV factor = A[i * n + k];
371 450           A[i * n + k] = 0.0;
372 8950 100         for (size_t j = 0; j < n; j++) {
373 8500           A[i * n + j] -= factor * A[k * n + j];
374             }
375             }
376             }
377             }
378 75           Safefree(orig_diag);
379 75           return rank;
380             }
381              
382             // Internal extractor resolving single data values. Returns NAN on missing or non-numeric.
383 4896           static NV get_data_value(pTHX_ HV *restrict data_hoa, HV **restrict row_hashes, unsigned int i, const char *restrict var) {
384 4896           SV **restrict val = NULL;
385 4896 100         if (row_hashes) {
386 1184           val = hv_fetch(row_hashes[i], var, strlen(var), 0);
387 1184 50         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVAV) {
    50          
    50          
388 1184           AV*restrict av = (AV*)SvRV(*val);
389 1184           val = av_fetch(av, 0, 0);
390             }
391 3712 50         } else if (data_hoa) {
392 3712           SV**restrict col = hv_fetch(data_hoa, var, strlen(var), 0);
393 3712 50         if (col && SvROK(*col) && SvTYPE(SvRV(*col)) == SVt_PVAV) {
    50          
    50          
394 3712           AV*restrict av = (AV*)SvRV(*col);
395 3712           val = av_fetch(av, i, 0);
396             }
397             }
398 4896 50         if (val && SvOK(*val)) {
    100          
399 4893 100         if (looks_like_number(*val)) return SvNV(*val);
400 49           return NAN; // Catch strings like "blue"
401             }
402 3           return NAN; // Catch undef/missing keys
403             }
404              
405             // Helper: Get all available columns for the '.' operator expansion
406 9           static AV* get_all_columns(pTHX_ HV *restrict data_hoa, HV **restrict row_hashes, size_t n) {
407 9           AV *restrict cols = newAV();
408 9 50         if (data_hoa) {
409 9           hv_iterinit(data_hoa);
410             HE *restrict entry;
411 33 100         while ((entry = hv_iternext(data_hoa))) {
412 24           av_push(cols, newSVsv(hv_iterkeysv(entry)));
413             }
414 0 0         } else if (row_hashes && n > 0 && row_hashes[0]) {
    0          
    0          
415 0           hv_iterinit(row_hashes[0]);
416             HE *restrict entry;
417 0 0         while ((entry = hv_iternext(row_hashes[0]))) {
418 0           av_push(cols, newSVsv(hv_iterkeysv(entry)));
419             }
420             }
421 9           return cols;
422             }
423              
424             // Recursive formula resolver with tightened NaN and Null handling
425 4928           static NV evaluate_term(pTHX_ HV *restrict data_hoa, HV **restrict row_hashes, unsigned int i, const char *restrict term) {
426 4928 50         if (!term || term[0] == '\0') return NAN;
    50          
427              
428 4928           char *restrict term_cpy = savepv(term);
429 4928           char *restrict colon = strchr(term_cpy, ':');
430 4928 100         if (colon) {
431 32           *colon = '\0';
432 32           NV left = evaluate_term(aTHX_ data_hoa, row_hashes, i, term_cpy);
433 32           NV right = evaluate_term(aTHX_ data_hoa, row_hashes, i, colon + 1);
434 32           Safefree(term_cpy);
435 32 50         if (isnan(left) || isnan(right)) return NAN;
    50          
436 32           return left * right;
437             }
438 4896 50         if (strncmp(term_cpy, "I(", 2) == 0) {
439 0           char *restrict end = strrchr(term_cpy, ')');
440 0 0         if (end) *end = '\0';
441 0           char *restrict inner = term_cpy + 2;
442 0           char *restrict caret = strchr(inner, '^');
443 0           int power = 1;
444 0 0         if (caret) {
445 0           *caret = '\0';
446 0           power = atoi(caret + 1);
447             }
448 0           NV v = get_data_value(aTHX_ data_hoa, row_hashes, i, inner);
449 0           Safefree(term_cpy);
450              
451 0 0         if (isnan(v)) return NAN;
452 0 0         return power == 1 ? v : pow(v, power);
453             }
454 4896           NV result = get_data_value(aTHX_ data_hoa, row_hashes, i, term_cpy);
455 4896           Safefree(term_cpy);
456 4896           return result;
457             }
458              
459             // Helper to infer column type from its first valid element
460 114           static bool is_column_categorical(pTHX_ HV *restrict data_hoa, HV **restrict row_hashes, size_t n, const char *restrict var) {
461 146 100         for (size_t i = 0; i < n; i++) {
462 145           SV **restrict val = NULL;
463 145 100         if (row_hashes) {
464 55           val = hv_fetch(row_hashes[i], var, strlen(var), 0);
465 55 100         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVAV) {
    50          
    50          
466 23           AV*restrict av = (AV*)SvRV(*val);
467 23           val = av_fetch(av, 0, 0);
468             }
469 90 50         } else if (data_hoa) {
470 90           SV **restrict col = hv_fetch(data_hoa, var, strlen(var), 0);
471 90 50         if (col && SvROK(*col) && SvTYPE(SvRV(*col)) == SVt_PVAV) {
    50          
    50          
472 90           AV*restrict av = (AV*)SvRV(*col);
473 90           val = av_fetch(av, i, 0);
474             }
475             }
476 145 100         if (val && SvOK(*val)) {
    50          
477 113 100         if (looks_like_number(*val)) return FALSE; // First valid is number -> Numeric Column
478 10           return TRUE; // First valid is string -> Categorical Column
479             }
480             }
481 1           return FALSE;
482             }
483              
484             /* Internal extractor resolving single data string values using dynamic allocation. */
485 371           static char* get_data_string_alloc(pTHX_ HV *restrict data_hoa, HV **restrict row_hashes, size_t i, const char *restrict var) {
486 371           SV **restrict val = NULL;
487 371 50         if (row_hashes) {
488 0           val = hv_fetch(row_hashes[i], var, strlen(var), 0);
489 0 0         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVAV) {
    0          
    0          
490 0           AV*restrict av = (AV*)SvRV(*val);
491 0           val = av_fetch(av, 0, 0);
492             }
493 371 50         } else if (data_hoa) {
494 371           SV **restrict col = hv_fetch(data_hoa, var, strlen(var), 0);
495 371 50         if (col && SvROK(*col) && SvTYPE(SvRV(*col)) == SVt_PVAV) {
    50          
    50          
496 371           AV*restrict av = (AV*)SvRV(*col);
497 371           val = av_fetch(av, i, 0);
498             }
499             }
500 371 50         if (val && SvOK(*val)) {
    50          
501 371           return savepv(SvPV_nolen(*val)); /* Allocates and returns string */
502             }
503 0           return NULL;
504             }
505              
506             // Struct for sorting p-values while remembering their original index
507             typedef struct {
508             NV p;
509             size_t orig_idx;
510             } PVal;
511              
512             // Comparator for qsort
513 1519           static int cmp_pval(const void *restrict a, const void *restrict b) {
514 1519           NV diff = ((PVal*)a)->p - ((PVal*)b)->p;
515 1519 100         if (diff < 0) return -1;
516 812 50         if (diff > 0) return 1;
517             /* Stabilize sort by falling back to original index */
518 0           return ((PVal*)a)->orig_idx - ((PVal*)b)->orig_idx;
519             }
520             /* -----------------------------------------------------------------------
521             * Helpers for cor(): ranking (Spearman), Pearson r, Kendall tau-b
522             * ----------------------------------------------------------------------- */
523             /* Item used to sort values while remembering their original index,
524             * needed for average-rank tie-breaking in Spearman correlation. */
525             typedef struct {
526             NV val;
527             size_t idx;
528             } RankItem;
529              
530 57           static int cmp_rank_item(const void *restrict a, const void *restrict b) {
531 57           NV diff = ((RankItem*)a)->val - ((RankItem*)b)->val;
532 57 100         if (diff < 0) return -1;
533 4 100         if (diff > 0) return 1;
534 1           return 0;
535             }
536              
537             /* Compute 1-based average ranks with tie-breaking into out[].
538             * in[] is not modified. */
539 8           static void rank_data(const NV *restrict in, NV *restrict out, size_t n) {
540             RankItem *restrict ri;
541 8 50         Newx(ri, n, RankItem);
542 56 100         for (size_t i = 0; i < n; i++) { ri[i].val = in[i]; ri[i].idx = i; }
543 8           qsort(ri, n, sizeof(RankItem), cmp_rank_item);
544              
545 8           size_t i = 0;
546 55 100         while (i < n) {
547 47           size_t j = i;
548             /* Find the full extent of this tie group */
549 48 100         while (j + 1 < n && ri[j + 1].val == ri[j].val) j++;
    100          
550             /* All members get the average of ranks i+1 … j+1 (1-based) */
551 47           NV avg = (NV)(i + j) / 2.0 + 1.0;
552 95 100         for (size_t k = i; k <= j; k++) out[ri[k].idx] = avg;
553 47           i = j + 1;
554             }
555 8           Safefree(ri);
556 8           }
557              
558             /* Pearson product-moment r between two n-element arrays.
559             * Returns NAN when either variable has zero variance (matches R). */
560 61           static NV pearson_corr(const NV *restrict x, const NV *restrict y, size_t n) {
561 61           NV sx = 0, sy = 0, sxy = 0, sx2 = 0, sy2 = 0;
562 364 100         for (size_t i = 0; i < n; i++) {
563 303           sx += x[i]; sy += y[i];
564 303           sxy += x[i]*y[i]; sx2 += x[i]*x[i]; sy2 += y[i]*y[i];
565             }
566 61           NV num = (NV)n * sxy - sx * sy;
567 61           NV den = sqrt(((NV)n * sx2 - sx*sx) * ((NV)n * sy2 - sy*sy));
568 61 50         if (den == 0.0) return NAN;
569 61           return num / den;
570             }
571              
572             /* Kendall's tau-b between two n-element arrays.
573              
574             * tau-b = (C − D) / sqrt((C + D + T_x)(C + D + T_y))
575             *
576             * where C = concordant pairs, D = discordant, T_x = pairs tied only on
577             * x, T_y = pairs tied only on y. Joint ties (both zero) are excluded
578             * from numerator and denominator, matching R's cor(method="kendall").
579             * Returns NAN when the denominator is zero. */
580 1           static NV kendall_tau_b(const NV *restrict x, const NV *restrict y, unsigned int n) {
581 1           size_t C = 0, D = 0, tie_x = 0, tie_y = 0;
582 9 100         for (size_t i = 0; i < n - 1; i++) {
583 44 100         for (size_t j = i + 1; j < n; j++) {
584 36           int sx = (x[i] > x[j]) - (x[i] < x[j]); /* sign of x[i]-x[j] */
585 36           int sy = (y[i] > y[j]) - (y[i] < y[j]);
586 36 100         if (sx == 0 && sy == 0) { /* joint tie — not counted */ }
    50          
587 36 100         else if (sx == 0) tie_x++;
588 35 50         else if (sy == 0) tie_y++;
589 35 50         else if (sx == sy) C++;
590 0           else D++;
591             }
592             }
593 1           NV denom = sqrt((NV)(C + D + tie_x) * (NV)(C + D + tie_y));
594 1 50         if (denom == 0.0) return NAN;
595 1           return (NV)(C - D) / denom;
596             }
597              
598             /* Single dispatch: compute correlation according to method string.
599             * Allocates and frees temporary rank arrays internally for Spearman. */
600 62           static NV compute_cor(const NV *restrict x, const NV *restrict y,
601             size_t n, const char *restrict method) {
602 62 100         if (strcmp(method, "spearman") == 0) {
603             NV *restrict rx, *restrict ry;
604 3 50         Newx(rx, n, NV); Newx(ry, n, NV);
    50          
605 3           rank_data(x, rx, n);
606 3           rank_data(y, ry, n);
607 3           NV r = pearson_corr(rx, ry, n);
608 3           Safefree(rx); Safefree(ry);
609 3           return r;
610             }
611 59 100         if (strcmp(method, "kendall") == 0)
612 1           return kendall_tau_b(x, y, n);
613             /* default: pearson */
614 58           return pearson_corr(x, y, n);
615             }
616              
617             // Math macros
618             #define MAX_ITER 500
619             #define EPS 3.0e-15
620             #define FPMIN 1.0e-30
621              
622 8632           static NV _incbeta_cf(NV a, NV b, NV x) {
623             int m;
624             NV aa, c, d, del, h, qab, qam, qap;
625 8632           qab = a + b; qap = a + 1.0; qam = a - 1.0;
626 8632           c = 1.0; d = 1.0 - qab * x / qap;
627 8632 50         if (fabs(d) < FPMIN) d = FPMIN;
628 8632           d = 1.0 / d; h = d;
629 184716 100         for (m = 1; m <= MAX_ITER; m++) {
630 184713           int m2 = 2 * m;
631 184713           aa = m * (b - m) * x / ((qam + m2) * (a + m2));
632 184713           d = 1.0 + aa * d;
633 184713 50         if (fabs(d) < FPMIN) d = FPMIN;
634 184713           c = 1.0 + aa / c;
635 184713 50         if (fabs(c) < FPMIN) c = FPMIN;
636 184713           d = 1.0 / d; h *= d * c;
637 184713           aa = -(a + m) * (qab + m) * x / ((a + m2) * (qap + m2));
638 184713           d = 1.0 + aa * d;
639 184713 50         if (fabs(d) < FPMIN) d = FPMIN;
640 184713           c = 1.0 + aa / c;
641 184713 50         if (fabs(c) < FPMIN) c = FPMIN;
642 184713           d = 1.0 / d; del = d * c; h *= del;
643 184713 100         if (fabs(del - 1.0) < EPS) break;
644             }
645 8632           return h;
646             }
647              
648 8683           static NV incbeta(NV a, NV b, NV x) {
649 8683 100         if (x <= 0.0) return 0.0;
650 8674 100         if (x >= 1.0) return 1.0;
651 8632           NV bt = exp(lgamma(a + b) - lgamma(a) - lgamma(b) + a * log(x) + b * log(1.0 - x));
652 8632 100         if (x < (a + 1.0) / (a + b + 2.0)) return bt * _incbeta_cf(a, b, x) / a;
653 1597           return 1.0 - bt * _incbeta_cf(b, a, 1.0 - x) / b;
654             }
655              
656 8375           static NV get_t_pvalue(NV t, NV df, const char*restrict alt) {
657 8375           NV x = df / (df + t * t);
658 8375           NV prob_2tail = incbeta(df / 2.0, 0.5, x);
659 8375 100         if (strcmp(alt, "less") == 0) return (t < 0) ? 0.5 * prob_2tail : 1.0 - 0.5 * prob_2tail;
    100          
660 8373 100         if (strcmp(alt, "greater") == 0) return (t > 0) ? 0.5 * prob_2tail : 1.0 - 0.5 * prob_2tail;
    50          
661 125           return prob_2tail;
662             }
663              
664             // Bisection algorithm to find the inverse t-distribution (Critical t-value)
665 277           static NV qt_tail(NV df, NV p_tail) {
666 277           NV low = 0.0, high = 1.0;
667             // Find upper bound
668 661 100         while (get_t_pvalue(high, df, "greater") > p_tail) {
669 384           low = high;
670 384           high *= 2.0;
671 384 50         if (high > 1000000.0) break; /* Fallback limit */
672             }
673             // Bisect to find the root
674 7586 50         for (unsigned short int i = 0; i < 100; i++) {
675 7586           NV mid = (low + high) / 2.0;
676 7586           NV p_mid = get_t_pvalue(mid, df, "greater");
677 7586 100         if (p_mid > p_tail) {
678 3711           low = mid;
679             } else {
680 3875           high = mid;
681             }
682 7586 100         if (high - low < 1e-8) break;
683             }
684 277           return (low + high) / 2.0;
685             }
686              
687 1303           int compare_doubles(const void *restrict a, const void *restrict b) {
688 1303           NV da = *(const NV*restrict)a;
689 1303           NV db = *(const NV*restrict)b;
690 1303           return (da > db) - (da < db);
691             }
692             /* Helper to calculate the number of bins using Sturges' formula: log2(n) + 1 */
693 0           static size_t calculate_sturges_bins(size_t n) {
694 0 0         if (n == 0) return 1;
695 0           return (size_t)(log((NV)n) / log(2.0) + 1.0);
696             }
697              
698             // Logic for distributing data into bins (Optimized to O(N))
699 5           static void compute_hist_logic(NV *restrict x, size_t n, NV *restrict breaks, size_t n_bins,
700             size_t *restrict counts, NV *restrict mids, NV *restrict density) {
701 5           NV total_n = (NV)n;
702 5           NV min_val = breaks[0];
703 5 50         NV step = (n_bins > 0) ? (breaks[1] - breaks[0]) : 0.0;
704             // Initialize counts and compute midpoints
705 23 100         for (size_t i = 0; i < n_bins; i++) {
706 18           counts[i] = 0;
707 18           mids[i] = (breaks[i] + breaks[i+1]) / 2.0;
708             }
709             // Single O(N) pass to assign elements to bins
710 5 100         if (step > 0.0) {
711 2017 100         for (size_t j = 0; j < n; j++) {
712 2014           NV val = x[j];
713             // Ignore out-of-bounds or invalid values
714 2014 50         if (isnan(val) || isinf(val) || val < min_val) continue;
    50          
    50          
715             // Calculate initial bin index mathematically
716 2014           size_t idx = (size_t)((val - min_val) / step);
717             // Clamp to valid array bounds first to prevent overflow */
718 2014 100         if (idx >= n_bins) {
719 3           idx = n_bins - 1;
720             }
721             /* Adjust for exact boundaries (R's right-inclusive default: (a, b]) */
722             /* If value is exactly on or slightly below the lower boundary of the assigned bin,
723             it belongs in the previous bin. (First bin [a, b] is inclusive on both ends) */
724 2023 100         while (idx > 0 && val <= breaks[idx]) {
    100          
725 9           idx--;
726             }
727             // Conversely, if floating-point truncation placed it too low, push it up
728 2014 100         while (idx < n_bins - 1 && val > breaks[idx + 1]) {
    50          
729 0           idx++;
730             }
731 2014           counts[idx]++;
732             }
733 2 50         } else if (n_bins > 0) {
734             // Edge case: All data points have the exact same value (step == 0)
735 2           counts[0] = n;
736             }
737             // Compute densities
738 23 100         for (size_t i = 0; i < n_bins; i++) {
739 18           NV bin_width = breaks[i+1] - breaks[i];
740 18 100         if (bin_width > 0) {
741 16           density[i] = (NV)counts[i] / (total_n * bin_width);
742             } else {
743 2 50         density[i] = (n_bins == 1) ? 1.0 : 0.0;
744             }
745             }
746 5           }
747              
748             // Standard Normal CDF approximation
749 68           NV approx_pnorm(NV x) {
750 68           return 0.5 * erfc(-x * 0.70710678118654752440); // 0.707... = 1/sqrt(2)
751             }
752             #ifndef M_SQRT1_2
753             #define M_SQRT1_2 0.70710678118654752440
754             #endif
755              
756             /* Macro for exact Wilcoxon 3D array indexing */
757             #define DP_INDEX(i, j, k, n2, max_u) ((i) * ((n2) + 1) * ((max_u) + 1) + (j) * ((max_u) + 1) + (k))
758 30           static NV inverse_normal_cdf(NV p) {
759 30           NV a[4] = {2.50662823884, -18.61500062529, 41.39119773534, -25.44106049637};
760 30           NV b[4] = {-8.47351093090, 23.08336743743, -21.06224101826, 3.13082909833};
761 30           NV c[9] = {0.3374754822726147, 0.9761690190917186, 0.1607979714918209,
762             0.0276438810333863, 0.0038405729373609, 0.0003951896511919,
763             0.0000321767881768, 0.0000002888167364, 0.0000003960315187};
764             NV x, r, y;
765 30           y = p - 0.5;
766 30 100         if (fabs(y) < 0.42) {
767 22           r = y * y;
768 22           x = y * (((a[3]*r + a[2])*r + a[1])*r + a[0]) /
769 22           ((((b[3]*r + b[2])*r + b[1])*r + b[0])*r + 1.0);
770             } else {
771 8           r = p;
772 8 100         if (y > 0) r = 1.0 - p;
773 8           r = log(-log(r));
774 8           x = c[0] + r * (c[1] + r * (c[2] + r * (c[3] + r * (c[4] +
775 8           r * (c[5] + r * (c[6] + r * (c[7] + r * c[8])))))));
776 8 100         if (y < 0) x = -x;
777             }
778 30           return x;
779             }
780             /* -----------------------------------------------------------------------
781             * Exact Spearman p-value via exhaustive permutation enumeration.
782             *
783             * Under H0, all n! orderings of ranks are equally probable. We visit
784             * every permutation of {1..n} with Heap's algorithm (O(n!), no allocs
785             * inside the loop) and count how many yield S ≤ s_obs ("lower tail",
786             * i.e. rho ≥ rho_obs) and how many yield S ≥ s_obs ("upper tail").
787             *
788             * Mirrors R's default: exact = (n < 10) with no ties.
789             * Valid up to n = 9 (362 880 iterations — negligible cost).
790             * ----------------------------------------------------------------------- */
791 1           static NV spearman_exact_pvalue(NV s_obs, size_t n, const char *restrict alt) {
792 1           int *restrict perm = (int*)safemalloc(n * sizeof(int));
793 1           int *restrict c = (int*)safemalloc(n * sizeof(int));
794 6 100         for (size_t i = 0; i < n; i++) { perm[i] = i + 1; c[i] = 0; }
795              
796 1           long count_le = 0, count_ge = 0, total = 0;
797              
798             #define TALLY_PERM() do { \
799             NV s_ = 0.0; \
800             for (int ii = 0; ii < n; ii++) { \
801             NV d_ = (NV)(ii + 1) - (NV)perm[ii];\
802             s_ += d_ * d_; \
803             } \
804             if (s_ <= s_obs + 1e-9) count_le++; \
805             if (s_ >= s_obs - 1e-9) count_ge++; \
806             total++; \
807             } while (0)
808              
809 6 100         TALLY_PERM(); /* initial permutation [1, 2, ..., n] */
    50          
    50          
810              
811 1           unsigned int k = 1;
812 206 100         while (k < n) {
813 205 100         if (c[k] < k) {
814             int tmp;
815 119 100         if (k % 2 == 0) {
816 44           tmp = perm[0]; perm[0] = perm[k]; perm[k] = tmp;
817             } else {
818 75           tmp = perm[c[k]]; perm[c[k]] = perm[k]; perm[k] = tmp;
819             }
820 714 100         TALLY_PERM();
    100          
    100          
821 119           c[k]++;
822 119           k = 1;
823             } else {
824 86           c[k] = 0;
825 86           k++;
826             }
827             }
828             #undef TALLY_PERM
829 1           Safefree(perm); Safefree(c);
830             /* p_le = P(S ≤ s_obs) ≡ P(rho ≥ rho_obs) — upper rho tail
831             * p_ge = P(S ≥ s_obs) ≡ P(rho ≤ rho_obs) — lower rho tail */
832 1           NV p_le = (NV)count_le / (NV)total;
833 1           NV p_ge = (NV)count_ge / (NV)total;
834              
835 1 50         if (strcmp(alt, "greater") == 0) return p_le;
836 1 50         if (strcmp(alt, "less") == 0) return p_ge;
837             /* two.sided: 2 × the smaller tail, clamped to 1 */
838 1 50         NV p = 2.0 * (p_le < p_ge ? p_le : p_ge);
839 1 50         return (p > 1.0) ? 1.0 : p;
840             }
841             /* -----------------------------------------------------------------------
842             * Exact Kendall p-value via Mahonian Numbers (Inversions distribution)
843             * Matches R's behavior for N < 50 without ties.
844             * ----------------------------------------------------------------------- */
845 2           static NV kendall_exact_pvalue(size_t n, NV s_obs, const char *restrict alt) {
846 2           long max_inv = (long)n * (n - 1) / 2;
847 2           NV *restrict dp = (NV*)safemalloc((max_inv + 1) * sizeof(NV));
848 24 100         for (long i = 0; i <= max_inv; i++) dp[i] = 0.0;
849 2           dp[0] = 1.0;
850             /* Build the distribution of inversions via DP */
851 10 100         for (size_t i = 2; i <= n; i++) {
852 8           NV *restrict next_dp = (NV*)safemalloc((max_inv + 1) * sizeof(NV));
853 96 100         for (long k = 0; k <= max_inv; k++) next_dp[k] = 0.0;
854 8           int current_max_inv = i * (i - 1) / 2;
855 56 100         for (int k = 0; k <= current_max_inv; k++) {
856 48           NV sum = 0;
857 206 100         for (int j = 0; j <= i - 1 && k - j >= 0; j++) {
    100          
858 158           sum += dp[k - j];
859             }
860             // Divide by 'i' directly to keep array as pure probabilities and prevent overflow
861 48           next_dp[k] = sum / (NV)i;
862             }
863 8           Safefree(dp);
864 8           dp = next_dp;
865             }
866             // Convert S statistic to target number of inversions
867 2           long i_obs = (long)round((max_inv - s_obs) / 2.0);
868 2 50         if (i_obs < 0) i_obs = 0;
869 2 50         if (i_obs > max_inv) i_obs = max_inv;
870 2           NV p_le = 0.0; /* P(S <= S_obs) */
871 20 100         for (long k = i_obs; k <= max_inv; k++) p_le += dp[k];
872 2           NV p_ge = 0.0; /* P(S >= S_obs) */
873 8 100         for (long k = 0; k <= i_obs; k++) p_ge += dp[k];
874 2           Safefree(dp);
875 2 50         if (strcmp(alt, "greater") == 0) return p_ge;
876 2 100         if (strcmp(alt, "less") == 0) return p_le;
877             // two.sided
878 1 50         NV p = 2.0 * (p_ge < p_le ? p_ge : p_le);
879 1 50         return p > 1.0 ? 1.0 : p;
880             }
881             // F-distribution Cumulative Distribution Function P(F <= f)
882 308           static NV pf(NV f, NV df1, NV df2) {
883 308 50         if (f <= 0.0) return 0.0;
884 308           NV x = (df1 * f) / (df1 * f + df2);
885 308           return incbeta(df1 / 2.0, df2 / 2.0, x);
886             }
887              
888             /* Householder QR Decomposition for Sequential Sums of Squares */
889             /* Householder QR Decomposition for Sequential Sums of Squares */
890 7           static void apply_householder_aov(NV** restrict X, NV* restrict y, size_t n, size_t p, bool* restrict aliased, size_t* restrict rank_map) {
891 7           size_t r = 0; // Rank/Row tracker
892 27 100         for (size_t k = 0; k < p; k++) {
893 20           aliased[k] = FALSE;
894 20 50         if (r >= n) {
895 0           aliased[k] = TRUE;
896 0           continue;
897             }
898              
899 20           NV max_val = 0;
900 188 100         for (size_t i = r; i < n; i++) {
901 168 100         if (fabs(X[i][k]) > max_val) max_val = fabs(X[i][k]);
902             }
903 20 100         if (max_val < 1e-10) {
904 1           aliased[k] = TRUE;
905 1           continue;
906             } // Collinear or zero column
907              
908 19           NV norm = 0;
909 184 100         for (size_t i = r; i < n; i++) {
910 165           X[i][k] /= max_val;
911 165           norm += X[i][k] * X[i][k];
912             }
913 19           norm = sqrt(norm);
914 19 100         NV s = (X[r][k] > 0) ? -norm : norm;
915 19           NV u1 = X[r][k] - s;
916 19           X[r][k] = s * max_val;
917              
918 39 100         for (size_t j = k + 1; j < p; j++) {
919 20           NV dot = u1 * X[r][j];
920 202 100         for (size_t i = r + 1; i < n; i++) dot += X[i][j] * X[i][k];
921 20           NV tau = dot / (s * u1);
922 20           X[r][j] += tau * u1;
923 202 100         for (size_t i = r + 1; i < n; i++) X[i][j] += tau * X[i][k];
924             }
925              
926             // Transform the response vector y
927 19           NV dot_y = u1 * y[r];
928 165 100         for (size_t i = r + 1; i < n; i++) dot_y += y[i] * X[i][k];
929 19           NV tau_y = dot_y / (s * u1);
930 19           y[r] += tau_y * u1;
931 165 100         for (size_t i = r + 1; i < n; i++) y[i] += tau_y * X[i][k];
932              
933 19           rank_map[k] = r; // Map original column index to orthogonal row index
934 19           r++;
935             }
936 7           }
937              
938             // --- write_table Helpers ---
939              
940             // Sorts string arrays alphabetically
941 2           static int cmp_string_wt(const void *a, const void *b) {
942 2           return strcmp(*(const char**)a, *(const char**)b);
943             }
944              
945             // Emulates Perl's /\D/ check
946 21           static bool contains_nondigit(pTHX_ SV *restrict sv) {
947 21 50         if (!sv || !SvOK(sv)) return 0;
    50          
948             STRLEN len;
949 21           char *restrict s = SvPVbyte(sv, len);
950 40 100         for (size_t i = 0; i < len; i++) {
951 21 100         if (!isdigit(s[i])) return 1;
952             }
953 19           return 0;
954             }
955              
956             /* ---------------------------------------------------------------------------
957             * print_string_row: emit one record.
958             *
959             * Quoting contract (matches the behaviors your tests pin down):
960             * - A field is quoted IFF it contains the separator string, a double
961             * quote, or a newline / carriage return. Quoting is per-field, so in a
962             * TSV "hello,world" stays bare while "tab\tin" becomes "tab in".
963             * - Inside a quoted field, embedded double quotes are doubled:
964             * p"q -> "p""q" (RFC 4180 style)
965             * - A NULL or zero-length field prints as NOTHING between separators:
966             * a,,c -- never '' or "". A zero-length field cannot contain a
967             * separator, quote, or newline, so it never needs quoting.
968             * - The separator is treated as a string (strstr), so multi-character
969             * separators work; an empty separator never triggers quoting.
970             *
971             * Returns nothing; I/O errors surface on PerlIO_close at the call site.
972             */
973 165           static void print_string_row(pTHX_ PerlIO *restrict fh,
974             const char **restrict fields, size_t n, const char *restrict sep)
975             {
976 165 50         const size_t sep_len = sep ? strlen(sep) : 0;
977 140648 100         for (size_t i = 0; i < n; i++) {
978 140483 100         if (i && sep_len) PerlIO_write(fh, sep, sep_len);
    50          
979 140483           const char *restrict f = fields[i];
980 140483 50         if (!f || !*f) continue; /* undef/empty -> print nothing */
    100          
981             /* Does this field need quoting? */
982 140431           bool need_quotes = 0;
983 140431 100         if (strchr(f, '"') || strchr(f, '\n') || strchr(f, '\r')) {
    100          
    100          
984 13           need_quotes = 1;
985 140418 50         } else if (sep_len && strstr(f, sep)) {
    100          
986 10           need_quotes = 1;
987             }
988 140431 100         if (!need_quotes) {
989 140408           PerlIO_write(fh, f, strlen(f));
990             } else {
991 23           PerlIO_putc(fh, '"');
992 197 100         for (const char *restrict p = f; *p; p++) {
993 174 100         if (*p == '"') PerlIO_putc(fh, '"'); /* double it */
994 174           PerlIO_putc(fh, *p);
995             }
996 23           PerlIO_putc(fh, '"');
997             }
998             }
999 165           PerlIO_putc(fh, '\n');
1000 165           }
1001              
1002             // Calculates the Regularized Upper Incomplete Gamma Function Q(a, x)
1003             // This perfectly replicates R's pchisq(..., lower.tail=FALSE)
1004 11           NV igamc(NV a, NV x) {
1005 11 50         if (x < 0.0 || a <= 0.0) return 1.0;
    50          
1006 11 50         if (x == 0.0) return 1.0;
1007              
1008             // Series expansion for x < a + 1
1009 11 100         if (x < a + 1.0) {
1010 4           NV sum = 1.0 / a;
1011 4           NV term = 1.0 / a;
1012 4           NV n = 1.0;
1013 62 100         while (fabs(term) > 1e-15) {
1014 58           term *= x / (a + n);
1015 58           sum += term;
1016 58           n += 1.0;
1017             }
1018 4           return 1.0 - (sum * exp(-x + a * log(x) - lgamma(a)));
1019             }
1020              
1021             // Continued fraction for x >= a + 1
1022 7           NV b = x + 1.0 - a;
1023 7           NV c = 1.0 / 1e-30;
1024 7           NV d = 1.0 / b;
1025 7           NV h = d, i = 1.0;
1026 105 50         while (i < 10000) { // Safety bound
1027 105           NV an = -i * (i - a);
1028 105           b += 2.0;
1029 105           d = an * d + b;
1030 105 50         if (fabs(d) < 1e-30) d = 1e-30;
1031 105           c = b + an / c;
1032 105 50         if (fabs(c) < 1e-30) c = 1e-30;
1033 105           d = 1.0 / d;
1034 105           NV del = d * c;
1035 105           h *= del;
1036 105 100         if (fabs(del - 1.0) < 1e-15) break;
1037 98           i += 1.0;
1038             }
1039 7           return h * exp(-x + a * log(x) - lgamma(a));
1040             }
1041              
1042             // Chi-Squared p-value is simply the Incomplete Gamma of (df/2, stat/2)
1043 11           NV get_p_value(NV stat, int df) {
1044 11 50         if (df <= 0) return 1.0;
1045 11 50         if (stat <= 0.0) return 1.0;
1046 11           return igamc((NV)df / 2.0, stat / 2.0);
1047             }
1048              
1049             #ifndef M_SQRT1_2
1050             #define M_SQRT1_2 0.70710678118654752440
1051             #endif
1052              
1053             // Robust Binomial Coefficient using long double
1054 2           static long double choose_comb(int n, int k) {
1055 2 50         if (k < 0 || k > n) return 0.0L;
    50          
1056 2 50         if (k > n / 2) k = n - k;
1057 2           long double res = 1.0L;
1058 8 100         for (int i = 1; i <= k; i++) {
1059 6           res = res * (long double)(n - i + 1) / (long double)i;
1060             }
1061 2           return res;
1062             }
1063              
1064             /* Exact CDF for Mann-Whitney U: P(U <= q)
1065             Mathematically identical to R's cwilcox generating function */
1066 4           static NV exact_pwilcox(NV q, int m, int n) {
1067 4           int k = (int)floor(q + 1e-7); // R uses 1e-7 fuzz
1068 4           int max_u = m * n;
1069 4 100         if (k < 0) return 0.0;
1070 2 50         if (k >= max_u) return 1.0;
1071              
1072 2           long double *restrict w = (long double *)safecalloc(max_u + 1, sizeof(long double));
1073 2           w[0] = 1.0L;
1074              
1075 8 100         for (int j = 1; j <= n; j++) {
1076 54 100         for (int i = j; i <= max_u; i++) w[i] += w[i - j];
1077 36 100         for (int i = max_u; i >= j + m; i--) w[i] -= w[i - j - m];
1078             }
1079              
1080 2           long double cum_p = 0.0L;
1081 4 100         for (int i = 0; i <= k; i++) cum_p += w[i];
1082              
1083 2           long double total = choose_comb(m + n, n);
1084 2           NV result = (NV)(cum_p / total);
1085              
1086 2           Safefree(w);
1087 2           return result;
1088             }
1089              
1090             /* Exact CDF for Wilcoxon Signed Rank: P(V <= q)
1091             Subset-sum DP, same recurrence as R's csignrank.
1092             Portable: no long-double libm calls (powl/ldexpl/expl), which are
1093             absent on some platforms (e.g. older FreeBSD). 2^n is built exactly
1094             by repeated doubling — exact in any radix-2 float format. */
1095 6           static NV exact_psignrank(NV q, size_t n) {
1096 6           long k = (long)floor(q + 1e-7); /* signed: negative q is a valid sentinel */
1097 6 50         if (k < 0) return 0.0;
1098 6           size_t max_v = n * (n + 1) / 2;
1099 6 100         if ((size_t)k >= max_v) return 1.0;
1100              
1101 5           long double *restrict w = (long double *)safecalloc(max_v + 1, sizeof(long double));
1102 5           w[0] = 1.0L;
1103 46 100         for (size_t i = 1; i <= n; i++)
1104 1582 100         for (size_t j = max_v; j >= i; j--)
1105 1541           w[j] += w[j - i];
1106              
1107 5           long double cum_p = 0.0L;
1108 182 100         for (size_t v = 0; v <= (size_t)k; v++) cum_p += w[v];
1109              
1110 5           long double total = 1.0L; /* 2^n, exact, zero libm dependency */
1111 46 100         for (size_t i = 0; i < n; i++) total *= 2.0L;
1112              
1113 5           NV result = (NV)(cum_p / total);
1114 5           Safefree(w);
1115 5           return result;
1116             }
1117              
1118 297           static int cmp_rank_info(const void *a, const void *b) {
1119 297           NV da = ((const RankInfo*)a)->val;
1120 297           NV db = ((const RankInfo*)b)->val;
1121 297           return (da > db) - (da < db);
1122             }
1123              
1124 11           static NV rank_and_count_ties(RankInfo *restrict ri, size_t n, bool *restrict has_ties) {
1125 11 50         if (n == 0) return 0.0;
1126 11           qsort(ri, n, sizeof(RankInfo), cmp_rank_info);
1127 11           size_t i = 0;
1128 11           NV tie_adj = 0.0;
1129 11           *has_ties = 0;
1130 124 100         while (i < n) {
1131 113           size_t j = i + 1;
1132 121 100         while (j < n && ri[j].val == ri[i].val) j++;
    100          
1133 113           NV r = (NV)(i + 1 + j) / 2.0;
1134 234 100         for (size_t k = i; k < j; k++) ri[k].rank = r;
1135 113           size_t t = j - i;
1136 113 100         if (t > 1) { *has_ties = 1; tie_adj += ((NV)t * t * t - t); }
1137 113           i = j;
1138             }
1139 11           return tie_adj;
1140             }
1141             /* --- KS-TEST C HELPER SECTION --- */
1142             #ifndef M_PI_2
1143             #define M_PI_2 1.57079632679489661923
1144             #endif
1145             #ifndef M_PI_4
1146             #define M_PI_4 0.78539816339744830962
1147             #endif
1148             #ifndef M_1_SQRT_2PI
1149             #define M_1_SQRT_2PI 0.39894228040143267794
1150             #endif
1151              
1152             // Scalar integer power used by K2x
1153 43           static NV r_pow_di(NV x, int n) {
1154 43 50         if (n == 0) return 1.0;
1155 43 50         if (n < 0) return 1.0 / r_pow_di(x, -n);
1156 43           NV val = 1.0;
1157 446 100         for (int i = 0; i < n; i++) val *= x;
1158 43           return val;
1159             }
1160              
1161             // Two-sample two-sided asymptotic distribution
1162 3           static NV K2l(NV x, int lower, NV tol) {
1163             NV s, z, p;
1164             int k;
1165 3 100         if(x <= 0.) {
1166 1 50         if(lower) p = 0.;
1167 1           else p = 1.;
1168 2 50         } else if(x < 1.) {
1169 2           int k_max = (int) sqrt(2.0 - log(tol));
1170 2           NV w = log(x);
1171 2           z = - (M_PI_2 * M_PI_4) / (x * x);
1172 2           s = 0;
1173 5 100         for(k = 1; k < k_max; k += 2) {
1174 3           s += exp(k * k * z - w);
1175             }
1176 2           p = s / M_1_SQRT_2PI;
1177 2 50         if(!lower) p = 1.0 - p;
1178             } else {
1179             NV new_val, old_val;
1180 0           z = -2.0 * x * x;
1181 0           s = -1.0;
1182 0 0         if(lower) {
1183 0           k = 1; old_val = 0.0; new_val = 1.0;
1184             } else {
1185 0           k = 2; old_val = 0.0; new_val = 2.0 * exp(z);
1186             }
1187 0 0         while(fabs(old_val - new_val) > tol) {
1188 0           old_val = new_val;
1189 0           new_val += 2.0 * s * exp(z * k * k);
1190 0           s *= -1.0;
1191 0           k++;
1192             }
1193 0           p = new_val;
1194             }
1195 3           return p;
1196             }
1197              
1198             // Auxiliary routines used by K2x() for matrix operations
1199 11           static void m_multiply(NV *A, NV *B, NV *C, unsigned int m) {
1200 148 100         for(unsigned int i = 0; i < m; i++) {
1201 2668 100         for(unsigned int j = 0; j < m; j++) {
1202 2531           NV s = 0.;
1203 50548 100         for(unsigned int k = 0; k < m; k++) s += A[i * m + k] * B[k * m + j];
1204 2531           C[i * m + j] = s;
1205             }
1206             }
1207 11           }
1208              
1209 10           static void m_power(NV *A, int eA, NV *V, int *eV, int m, int n) {
1210 10 100         if(n == 1) {
1211 366 100         for(int i = 0; i < m * m; i++) V[i] = A[i];
1212 3           *eV = eA;
1213 3           return;
1214             }
1215 7           m_power(A, eA, V, eV, m, n / 2);
1216 7           NV *restrict B = (NV*) safecalloc(m * m, sizeof(NV));
1217 7           m_multiply(V, V, B, m);
1218 7           int eB = 2 * (*eV);
1219 7 100         if((n % 2) == 0) {
1220 1086 100         for(int i = 0; i < m * m; i++) V[i] = B[i];
1221 3           *eV = eB;
1222             } else {
1223 4           m_multiply(A, B, V, m);
1224 4           *eV = eA + eB;
1225             }
1226 7 50         if(V[(m / 2) * m + (m / 2)] > 1e140) {
1227 0 0         for(int i = 0; i < m * m; i++) V[i] = V[i] * 1e-140;
1228 0           *eV += 140;
1229             }
1230 7           Safefree(B);
1231             }
1232              
1233             // One-sample two-sided exact distribution
1234 3           static NV K2x(int n, NV d) {
1235 3           int k = (int) (n * d) + 1;
1236 3           int m = 2 * k - 1;
1237 3           NV h = k - n * d;
1238 3           NV *restrict H = (NV*) safecalloc(m * m, sizeof(NV));
1239 3           NV *restrict Q = (NV*) safecalloc(m * m, sizeof(NV));
1240              
1241 24 100         for(int i = 0; i < m; i++) {
1242 384 100         for(int j = 0; j < m; j++) {
1243 363 100         if(i - j + 1 < 0) H[i * m + j] = 0;
1244 210           else H[i * m + j] = 1;
1245             }
1246             }
1247 24 100         for(int i = 0; i < m; i++) {
1248 21           H[i * m] -= r_pow_di(h, i + 1);
1249 21           H[(m - 1) * m + i] -= r_pow_di(h, (m - i));
1250             }
1251 3 100         H[(m - 1) * m] += ((2 * h - 1 > 0) ? r_pow_di(2 * h - 1, m) : 0);
1252              
1253 24 100         for(int i = 0; i < m; i++) {
1254 384 100         for(int j = 0; j < m; j++) {
1255 363 100         if(i - j + 1 > 0) {
1256 1524 100         for(int g = 1; g <= i - j + 1; g++) H[i * m + j] /= g;
1257             }
1258             }
1259             }
1260              
1261 3           int eH = 0, eQ;
1262 3           m_power(H, eH, Q, &eQ, m, n);
1263 3           NV s = Q[(k - 1) * m + k - 1];
1264              
1265 59 100         for(int i = 1; i <= n; i++) {
1266 56           s = s * (NV)i / (NV)n;
1267 56 50         if(s < 1e-140) {
1268 0           s *= 1e140;
1269 0           eQ -= 140;
1270             }
1271             }
1272 3           s *= pow(10.0, eQ);
1273 3           Safefree(H);
1274 3           Safefree(Q);
1275 3           return s;
1276             }
1277             /* One comparator, used by every qsort below. Branch form avoids overflow that
1278             * a subtraction-based comparator would hit, and is correct for any NV width. */
1279 4214           static int compare_NVs(const void *a, const void *b) {
1280 4214           NV x = *(const NV *)a, y = *(const NV *)b;
1281 4214           return (x > y) - (x < y);
1282             }
1283             /* Largest m*n for which we will run the exact DP even when exact=>1 is forced.
1284             * Time is O(m*n); memory is O(min(m,n)). Beyond this we warn and go asymptotic. */
1285             #define KS_EXACT_MAX_PRODUCT 10000000.0
1286 21           static void calc_2sample_stats(NV *x, size_t nx, NV *y, size_t ny,
1287             NV *d, NV *d_plus, NV *d_minus) {
1288 21           qsort(x, nx, sizeof(NV), compare_NVs);
1289 21           qsort(y, ny, sizeof(NV), compare_NVs);
1290 21           NV max_d = 0.0, max_d_plus = 0.0, max_d_minus = 0.0;
1291 21           size_t i = 0, j = 0;
1292 702 100         while (i < nx || j < ny) {
    100          
1293             NV val;
1294 681 100         if (i < nx && j < ny) val = (x[i] < y[j]) ? x[i] : y[j];
    100          
    100          
1295 107 100         else if (i < nx) val = x[i];
1296 53           else val = y[j];
1297 1056 100         while (i < nx && x[i] <= val) i++;
    100          
1298 996 100         while (j < ny && y[j] <= val) j++;
    100          
1299 681           NV cdf1 = (NV)i / nx;
1300 681           NV cdf2 = (NV)j / ny;
1301 681           NV diff = cdf1 - cdf2;
1302 681 100         if (diff > max_d_plus) max_d_plus = diff;
1303 681 100         if (-diff > max_d_minus) max_d_minus = -diff;
1304 681 100         if (fabs(diff) > max_d) max_d = fabs(diff);
1305             }
1306 21           *d = max_d; *d_plus = max_d_plus; *d_minus = max_d_minus;
1307 21           }
1308              
1309 27966           static int psmirnov_exact_test(NV q, NV r, NV s, int two_sided) {
1310 27966 100         if (two_sided) return (fabs(r - s) >= q);
1311 3208           return ((r - s) >= q);
1312             }
1313              
1314             // Evaluate the exact 2-sample probability
1315 19           static NV psmirnov_exact_uniq_upper(NV q, size_t m, size_t n, int two_sided) {
1316 19           NV md = (NV) m, nd = (NV) n;
1317 19           NV *u = (NV *) safemalloc((n + 1) * sizeof(NV)); /* malloc + full init below */
1318 19           u[0] = 0.;
1319 325 100         for (size_t j = 1; j <= n; j++)
1320 306 100         u[j] = psmirnov_exact_test(q, 0., j / nd, two_sided) ? 1. : u[j - 1];
1321 385 100         for (size_t i = 1; i <= m; i++) {
1322 366 100         if (psmirnov_exact_test(q, i / md, 0., two_sided)) u[0] = 1.;
1323 27660 100         for (size_t j = 1; j <= n; j++) {
1324 27294 100         if (psmirnov_exact_test(q, i / md, j / nd, two_sided)) u[j] = 1.;
1325             else {
1326 3768           NV v = (NV)(i) / (NV)(i + j);
1327 3768           NV w = (NV)(j) / (NV)(i + j);
1328 3768           u[j] = v * u[j] + w * u[j - 1];
1329             }
1330             }
1331             }
1332 19           NV res = u[n];
1333 19           Safefree(u);
1334 19           return res;
1335             }
1336              
1337 229           static NV p_body(NV n, NV delta, NV sd, NV sig_level, int tsample, int tside, bool strict) {
1338 229           NV nu = (n - 1.0) * (NV)tsample;
1339 229 50         if (nu < 1e-7) nu = 1e-7;
1340              
1341             // Ensure sig_level/tside is not truncated
1342 229           NV p_tail = sig_level / (NV)tside;
1343 229           NV qu = qt_tail(nu, p_tail); // qt(p, df, lower.tail=FALSE)
1344              
1345 229           NV ncp = sqrt(n / (NV)tsample) * (delta / sd);
1346              
1347 229 50         if (strict && tside == 2) {
    0          
1348             // Use R-style tail calls: 1 - P(T < qu) + P(T < -qu)
1349 0           return (1.0 - exact_pnt(qu, nu, ncp)) + exact_pnt(-qu, nu, ncp);
1350             } else {
1351             // Default: 1 - P(T < qu)
1352             // Ensure exact_pnt is using a convergence tolerance of at least 1e-15
1353 229           return 1.0 - exact_pnt(qu, nu, ncp);
1354             }
1355             }
1356              
1357             // Bisection algorithm to find the inverse F-distribution (Quantile function)
1358             // Equivalent to R's qf(p, df1, df2)
1359 6           static NV qf_bisection(NV p, NV df1, NV df2) {
1360 6 50         if (p <= 0.0) return 0.0;
1361 6 50         if (p >= 1.0) return INFINITY;
1362 6           NV low = 0.0, high = 1.0;
1363             // Find upper bound
1364 20 100         while (pf(high, df1, df2) < p) {
1365 14           low = high;
1366 14           high *= 2.0;
1367 14 50         if (high > 1e100) break; /* Fallback limit */
1368             }
1369              
1370             // Bisect to find the root
1371 251 50         for (unsigned short int i = 0; i < 150; i++) {
1372 251           NV mid = low + (high - low) / 2.0;
1373 251           NV p_mid = pf(mid, df1, df2);
1374              
1375 251 100         if (p_mid < p) {
1376 122           low = mid;
1377             } else {
1378 129           high = mid;
1379             }
1380 251 100         if (high - low < 1e-12) break;
1381             }
1382 6           return (low + high) / 2.0;
1383             }
1384              
1385             typedef struct {
1386             NV statistic;
1387             NV num_df;
1388             NV denom_df;
1389             NV p_value;
1390             NV ss_between; /* between-group sum of squares */
1391             NV ss_within; /* within-group sum of squares */
1392             NV ms_between; /* ss_between / num_df */
1393             NV ms_within; /* ss_within / denom_df */
1394             int k; /* number of groups */
1395             IV n; /* total observations */
1396             bool var_equal; /* 0 = Welch, 1 = classic */
1397             } OneWayResult;
1398              
1399             static OneWayResult
1400 6           c_oneway_test(const NV *restrict data, const size_t *restrict sizes,
1401             size_t k, bool var_equal)
1402             {
1403             OneWayResult res;
1404 6           res.var_equal = var_equal;
1405 6           res.k = (int)k;
1406              
1407 6           NV *restrict n_i = (NV *)safemalloc(k * sizeof(NV));
1408 6           NV *restrict m_i = (NV *)safemalloc(k * sizeof(NV));
1409 6           NV *restrict v_i = (NV *)safemalloc(k * sizeof(NV));
1410 6           size_t offset = 0;
1411 6           IV total_n = 0;
1412 18 100         for (size_t g = 0; g < k; g++) {
1413 12           size_t ng = sizes[g];
1414 12           n_i[g] = (NV)ng;
1415 12           total_n += (IV)ng;
1416 12           NV sum = 0.0;
1417 78 100         for (size_t i = 0; i < ng; i++) sum += data[offset + i];
1418 12           NV mean = sum / (NV)ng;
1419 12           m_i[g] = mean;
1420              
1421 12           NV ss = 0.0;
1422 78 100         for (size_t i = 0; i < ng; i++) {
1423 66           NV d = data[offset + i] - mean;
1424 66           ss += d * d;
1425             }
1426 12           v_i[g] = ss / (NV)(ng - 1); /* ng >= 2 guaranteed by caller */
1427 12           offset += ng;
1428             }
1429 6           res.n = total_n;
1430             // grand mean (simple average over all obs; used only by classic branch)/
1431 6           NV grand_mean = 0.0;
1432 72 100         for (IV i = 0; i < (IV)total_n; i++) grand_mean += data[i];
1433 6           grand_mean /= (NV)total_n;
1434              
1435 6           NV df1 = (NV)(k - 1);
1436              
1437 6 50         if (var_equal) {/* ── Classic one-way ANOVA
1438             * F = [Σ n_i·(m_i − ȳ)² / (k−1)] / [Σ (n_i−1)·v_i / (n−k)] */
1439 0           NV ssbg = 0.0, sswg = 0.0;
1440 0 0         for (size_t g = 0; g < k; g++) {
1441 0           NV dm = m_i[g] - grand_mean;
1442 0           ssbg += n_i[g] * dm * dm;
1443 0           sswg += (n_i[g] - 1.0) * v_i[g];
1444             }
1445 0           NV df2 = (NV)(total_n - (IV)k);
1446 0           res.statistic = (ssbg / df1) / (sswg / df2);
1447 0           res.num_df = df1;
1448 0           res.denom_df = df2;
1449 0           res.ss_between = ssbg;
1450 0           res.ss_within = sswg;
1451 0           res.ms_between = ssbg / df1;
1452 0           res.ms_within = sswg / df2;
1453             } else {// ── Welch one-way (heteroscedastic)
1454 6           NV *restrict w_i = (NV *)safemalloc(k * sizeof(NV));
1455 6           NV sum_w = 0.0;
1456 18 100         for (size_t g = 0; g < k; g++) { w_i[g] = n_i[g] / v_i[g]; sum_w += w_i[g]; }
1457 6           NV wgrand = 0.0;
1458 18 100         for (size_t g = 0; g < k; g++) wgrand += w_i[g] * m_i[g];
1459 6           wgrand /= sum_w;
1460 6           NV tmp = 0.0;
1461 18 100         for (size_t g = 0; g < k; g++) {
1462 12           NV t = 1.0 - w_i[g] / sum_w;
1463 12           tmp += (t * t) / (n_i[g] - 1.0);
1464             }
1465 6           tmp /= ((NV)k * (NV)k - 1.0); /* k² − 1 */
1466 6           NV num = 0.0;
1467 18 100         for (size_t g = 0; g < k; g++) {
1468 12           NV dm = m_i[g] - wgrand;
1469 12           num += w_i[g] * dm * dm;
1470             }
1471 6           res.statistic = num / (df1 * (1.0 + 2.0 * (NV)(k - 2) * tmp));
1472 6           res.num_df = df1;
1473 6 50         res.denom_df = (tmp > 0.0) ? (1.0 / (3.0 * tmp)) : 1e300;
1474             /* unweighted SS for the output table */
1475 6           NV ssbg = 0.0, sswg = 0.0;
1476 18 100         for (size_t g = 0; g < k; g++) {
1477 12           NV dm = m_i[g] - grand_mean;
1478 12           ssbg += n_i[g] * dm * dm;
1479 12           sswg += (n_i[g] - 1.0) * v_i[g];
1480             }
1481 6           res.ss_between = ssbg;
1482 6           res.ss_within = sswg;
1483 6 50         res.ms_between = (df1 > 0.0) ? ssbg / df1 : 0.0;
1484 6 50         res.ms_within = (res.denom_df > 0.0) ? sswg / res.denom_df : 0.0;
1485 6           Safefree(w_i);
1486             }
1487             // upper-tail p-value P(F ≥ statistic)
1488 6           res.p_value = 1 - pf(res.statistic, res.num_df, res.denom_df);
1489 6           Safefree(n_i); Safefree(m_i); Safefree(v_i);
1490 6           return res;
1491             }
1492              
1493             /* ── parse_formula
1494             *
1495             * Splits "response ~ factor" into two NUL-terminated, heap-allocated
1496             * strings. Leading/trailing whitespace is stripped from each side.
1497             * Returns 1 on success, 0 on failure (malformed / missing '~').
1498             * Caller must Safefree() both *lhs and *rhs on success. */
1499             static int
1500 4           parse_formula(const char *formula, char **lhs, char **rhs)
1501             {
1502 4           const char *restrict tilde = strchr(formula, '~');
1503 4 100         if (!tilde) return 0;
1504              
1505             // left-hand side: trim trailing whitespace
1506 3           const char *restrict l_start = formula;
1507 3           const char *restrict l_end = tilde - 1;
1508 6 50         while (l_end >= l_start && isspace((unsigned char)*l_end)) l_end--;
    100          
1509 3 50         if (l_end < l_start) return 0; /* empty LHS */
1510              
1511             // right-hand side: trim leading whitespace */
1512 3           const char *restrict r_start = tilde + 1;
1513 6 50         while (*r_start && isspace((unsigned char)*r_start)) r_start++;
    100          
1514 3           const char *restrict r_end = r_start + strlen(r_start) - 1;
1515 3 50         while (r_end >= r_start && isspace((unsigned char)*r_end)) r_end--;
    50          
1516 3 50         if (r_end < r_start) return 0; /* empty RHS */
1517              
1518 3           size_t llen = (size_t)(l_end - l_start + 1);
1519 3           size_t rlen = (size_t)(r_end - r_start + 1);
1520              
1521 3           *lhs = (char *)safemalloc(llen + 1);
1522 3           *rhs = (char *)safemalloc(rlen + 1);
1523 3           memcpy(*lhs, l_start, llen); (*lhs)[llen] = '\0';
1524 3           memcpy(*rhs, r_start, rlen); (*rhs)[rlen] = '\0';
1525 3           return 1;
1526             }
1527              
1528             /* ── build_groups_from_formula ───────────────
1529             *
1530             * Takes parallel response[] and label[] arrays (each length n) and
1531             * partitions them into groups, filling:
1532             * out_flat[] – observations sorted into contiguous group blocks
1533             * out_sizes[] – number of observations per group (caller allocates n
1534             * slots for both; actual group count returned via *out_k)
1535             * out_names – if non-NULL, receives a heap-allocated char** of k
1536             * group-name strings (caller must free each and the array)
1537             *
1538             * Group identity is the string representation of each label element
1539             * (SvPV_nolen), so integer 0 and string "0" are the same group.
1540             * Groups are ordered by first appearance in label[], matching R's
1541             * factor level ordering from stack().
1542             *
1543             * Returns 1 on success; 0 if any validation error (sets errbuf).
1544             */
1545             #define OWT_MAX_GROUPS 1024 /* sane ceiling; ANOVA with >1024 groups is absurd */
1546              
1547 2           static int build_groups_from_formula(pTHX_
1548             AV *restrict response_av,
1549             AV *restrict label_av,
1550             NV *restrict out_flat,
1551             size_t *restrict out_sizes,
1552             size_t *restrict out_k,
1553             char ***restrict out_names,
1554             char *restrict errbuf,
1555             size_t errbuf_len)
1556             {
1557 2           IV n = av_len(response_av) + 1;
1558 2           IV nl = av_len(label_av) + 1;
1559              
1560 2 100         if (n != nl) {
1561 1           snprintf(errbuf, errbuf_len,
1562             "formula: response length (%"IVdf") != factor length (%"IVdf")",
1563             n, nl);
1564 1           return 0;
1565             }
1566 1 50         if (n < 2) {
1567 0           snprintf(errbuf, errbuf_len, "formula: need at least 2 observations");
1568 0           return 0;
1569             }
1570              
1571             /* ── discover unique group labels in order of first appearance ─── */
1572             /* We store pointers into a heap-allocated label string table. */
1573 1           char **restrict group_names = (char **)safemalloc(OWT_MAX_GROUPS * sizeof(char *));
1574 1           size_t ngroups = 0;
1575 1           IV *restrict obs_group = (IV *)safemalloc((size_t)n * sizeof(IV));
1576             /* maps obs index → group index */
1577              
1578 7 100         for (IV i = 0; i < n; i++) {
1579 6           SV **restrict lsv = av_fetch(label_av, i, 0);
1580 6 50         const char *restrict label = (lsv && *lsv) ? SvPV_nolen(*lsv) : "";
    50          
1581             /* linear scan for existing group (k is small, O(n·k) is fine) */
1582 6           IV gidx = -1;
1583 9 100         for (size_t g = 0; g < ngroups; g++) {
1584 7 100         if (strEQ(group_names[g], label)) { gidx = (IV)g; break; }
1585             }
1586 6 100         if (gidx < 0) {
1587 2 50         if (ngroups >= OWT_MAX_GROUPS) {
1588 0           snprintf(errbuf, errbuf_len,
1589             "formula: too many distinct groups (max %d)", OWT_MAX_GROUPS);
1590 0           Safefree(group_names);
1591 0           Safefree(obs_group);
1592 0           return 0;
1593             }
1594             /* new group: copy the label string */
1595 2           size_t lablen = strlen(label);
1596 2           group_names[ngroups] = (char *)safemalloc(lablen + 1);
1597 2           memcpy(group_names[ngroups], label, lablen + 1);
1598 2           gidx = (IV)ngroups++;
1599             }
1600 6           obs_group[i] = gidx;
1601             }
1602              
1603 1 50         if (ngroups < 2) {
1604 0           snprintf(errbuf, errbuf_len,
1605             "formula: need at least 2 distinct groups, found %zu", ngroups);
1606 0 0         for (size_t g = 0; g < ngroups; g++) Safefree(group_names[g]);
1607 0           Safefree(group_names); Safefree(obs_group);
1608 0           return 0;
1609             }
1610             /* count per-group sizes */
1611 1           memset(out_sizes, 0, ngroups * sizeof(size_t));
1612 7 100         for (unsigned i = 0; i < n; i++) out_sizes[obs_group[i]]++;
1613             /* validate: every group needs >= 2 observations */
1614 3 100         for (size_t g = 0; g < ngroups; g++) {
1615 2 50         if (out_sizes[g] < 2) {
1616 0           snprintf(errbuf, errbuf_len,
1617             "formula: group '%s' has only %zu observation(s); need >= 2",
1618 0           group_names[g], out_sizes[g]);
1619 0 0         for (size_t gg = 0; gg < ngroups; gg++) Safefree(group_names[gg]);
1620 0           Safefree(group_names); Safefree(obs_group);
1621 0           return 0;
1622             }
1623             }
1624             /* ── fill flat output array in group order *
1625             * We compute a running write-offset per group, then scatter*/
1626 1           size_t *restrict write_pos = (size_t *)safemalloc(ngroups * sizeof(size_t));
1627 1           write_pos[0] = 0;
1628 2 100         for (size_t g = 1; g < ngroups; g++)
1629 1           write_pos[g] = write_pos[g - 1] + out_sizes[g - 1];
1630 7 100         for (IV i = 0; i < n; i++) {
1631 6           SV **restrict rsv = av_fetch(response_av, i, 0);
1632 6 50         NV val = (rsv && *rsv) ? SvNV(*rsv) : 0.0;
    50          
1633 6           size_t g = (size_t)obs_group[i];
1634 6           out_flat[write_pos[g]++] = val;
1635             }
1636 1           *out_k = ngroups;
1637             /* ── clean up or hand off group names */
1638 1           Safefree(write_pos); Safefree(obs_group);
1639 1 50         if (out_names) {
1640 1           *out_names = group_names; /* caller takes ownership */
1641             } else {
1642 0 0         for (size_t g = 0; g < ngroups; g++) Safefree(group_names[g]);
1643 0           Safefree(group_names);
1644             }
1645 1           return 1;
1646             }
1647             #undef OWT_MAX_GROUPS
1648             // --- Math Macros ---
1649             #ifndef M_LN_SQRT_2PI
1650             #define M_LN_SQRT_2PI 0.91893853320467274178
1651             #endif
1652             #ifndef M_LN2
1653             #define M_LN2 0.69314718055994530941
1654             #endif
1655             #ifndef M_1_SQRT_2PI
1656             #define M_1_SQRT_2PI 0.39894228040143267794
1657             #endif
1658              
1659             /* c_dnorm: Normal distribution PDF
1660             *
1661             * Mathematically identical to R's dnorm4.
1662             * Includes Morten Welinder's precision improvements for extreme tails.
1663             */
1664 25           static NV c_dnorm(NV x, NV mu, NV sigma, int give_log) {
1665             // Propagate NaNs
1666 25 50         if (isnan(x) || isnan(mu) || isnan(sigma)) return x + mu + sigma;
    50          
    50          
1667 25 50         if (sigma < 0.0) {
1668 0           warn("dnorm: standard deviation must be non-negative");
1669 0           return NAN;
1670             }
1671 25 50         if (isinf(sigma)) return 0.0;
1672 25 50         if ((isnan(x) || isinf(x)) && mu == x) return NAN; // x-mu is NaN
    50          
    0          
1673             // Dirac delta behavior for zero variance
1674 25 50         if (sigma == 0.0) return (x == mu) ? INFINITY : 0.0;
    0          
1675              
1676             // Standardize x
1677 25           x = (x - mu) / sigma;
1678 25 50         if (isnan(x) || isinf(x)) return 0.0;
    50          
1679 25           x = fabs(x);
1680             // Catch massive limits early to prevent math overflow
1681 25 50         if (x >= 2.0 * sqrt(DBL_MAX)) return 0.0;
1682 25 100         if (give_log) {
1683 1           return -(M_LN_SQRT_2PI + 0.5 * x * x + log(sigma));
1684             }
1685             // Naive formula for standard bodies
1686 24 100         if (x < 5.0) {
1687 22           return M_1_SQRT_2PI * exp(-0.5 * x * x) / sigma;
1688             }
1689             // Underflow boundary check using IEEE float characteristics
1690 2 50         if (x > sqrt(-2.0 * M_LN2 * (DBL_MIN_EXP + 1.0 - DBL_MANT_DIG))) {
1691 0           return 0.0;
1692             }
1693             /* Splitting x to dodge floating point inaccuracies in x^2 for large x.
1694             * x = x1 + x2, where |x2| <= 2^-16
1695             * trunc() safely substitutes R_forceint() */
1696 2           NV x1 = ldexp(trunc(ldexp(x, 16)), -16);
1697 2           NV x2 = x - x1;
1698 2           return (M_1_SQRT_2PI / sigma) * (exp(-0.5 * x1 * x1) * exp((-0.5 * x2 - x1) * x2));
1699             }
1700             /*Helper for prcomp: Jacobi Eigenvalue Algorithm for Symmetric Matrices
1701             * Used to compute the eigendecomposition of the X^T X covariance matrix.*/
1702 7           static void jacobi_eigen(NV *restrict A, size_t n, NV *restrict d, NV *restrict v) {
1703 21 100         for (size_t i = 0; i < n; i++) {
1704 42 100         for (size_t j = 0; j < n; j++) v[i * n + j] = (i == j) ? 1.0 : 0.0;
    100          
1705 14           d[i] = A[i * n + i];
1706             }
1707 7           NV *restrict b = (NV*)safemalloc(n * sizeof(NV));
1708 7           NV *restrict z = (NV*)safemalloc(n * sizeof(NV));
1709 21 100         for (size_t i = 0; i < n; i++) { b[i] = d[i]; z[i] = 0.0; }
1710 14 50         for (int iter = 1; iter <= 50; iter++) {
1711 14           NV sm = 0.0;
1712 28 100         for (size_t i = 0; i < n - 1; i++) {
1713 28 100         for (size_t j = i + 1; j < n; j++) sm += fabs(A[i * n + j]);
1714             }
1715 14 100         if (sm == 0.0) break;
1716 7 50         NV tresh = (iter < 4) ? 0.2 * sm / (n * n) : 0.0;
1717 14 100         for (size_t i = 0; i < n - 1; i++) {
1718 14 100         for (size_t j = i + 1; j < n; j++) {
1719 7           NV g = 100.0 * fabs(A[i * n + j]);
1720 7 50         if (iter > 4 && fabs(d[i]) + g == fabs(d[i]) && fabs(d[j]) + g == fabs(d[j])) {
    0          
    0          
1721 0           A[i * n + j] = 0.0;
1722 7 50         } else if (fabs(A[i * n + j]) > tresh) {
1723 7           NV h = d[j] - d[i];
1724             NV t;
1725 7 50         if (fabs(h) + g == fabs(h)) {
1726 0           t = A[i * n + j] / h;
1727             } else {
1728 7           NV theta = 0.5 * h / A[i * n + j];
1729 7           t = 1.0 / (fabs(theta) + sqrt(1.0 + theta * theta));
1730 7 100         if (theta < 0.0) t = -t;
1731             }
1732 7           NV c = 1.0 / sqrt(1.0 + t * t);
1733 7           NV s = t * c;
1734 7           NV tau = s / (1.0 + c);
1735 7           NV h_t = t * A[i * n + j];
1736 7           z[i] -= h_t;
1737 7           z[j] += h_t;
1738 7           d[i] -= h_t;
1739 7           d[j] += h_t;
1740 7           A[i * n + j] = 0.0;
1741 7 50         for (size_t k = 0; k < i; k++) {
1742 0           g = A[k * n + i]; NV h_val = A[k * n + j];
1743 0           A[k * n + i] = g - s * (h_val + g * tau);
1744 0           A[k * n + j] = h_val + s * (g - h_val * tau);
1745             }
1746 7 50         for (size_t k = i + 1; k < j; k++) {
1747 0           g = A[i * n + k]; NV h_val = A[k * n + j];
1748 0           A[i * n + k] = g - s * (h_val + g * tau);
1749 0           A[k * n + j] = h_val + s * (g - h_val * tau);
1750             }
1751 7 50         for (size_t k = j + 1; k < n; k++) {
1752 0           g = A[i * n + k]; NV h_val = A[j * n + k];
1753 0           A[i * n + k] = g - s * (h_val + g * tau);
1754 0           A[j * n + k] = h_val + s * (g - h_val * tau);
1755             }
1756 21 100         for (size_t k = 0; k < n; k++) {
1757 14           g = v[k * n + i]; NV h_val = v[k * n + j];
1758 14           v[k * n + i] = g - s * (h_val + g * tau);
1759 14           v[k * n + j] = h_val + s * (g - h_val * tau);
1760             }
1761             }
1762             }
1763             }
1764 21 100         for (size_t i = 0; i < n; i++) {
1765 14           b[i] += z[i];
1766 14           d[i] = b[i];
1767 14           z[i] = 0.0;
1768             }
1769             }
1770 7           Safefree(b); Safefree(z);
1771             // Sort eigenvalues and corresponding eigenvectors in descending order
1772 14 100         for (size_t i = 0; i < n - 1; i++) {
1773 7           size_t max_k = i;
1774 7           NV max_val = d[i];
1775 14 100         for (size_t j = i + 1; j < n; j++) {
1776 7 100         if (d[j] > max_val) {
1777 6           max_val = d[j];
1778 6           max_k = j;
1779             }
1780             }
1781 7 100         if (max_k != i) {
1782 6           d[max_k] = d[i];
1783 6           d[i] = max_val;
1784 18 100         for (size_t k = 0; k < n; k++) {
1785 12           NV tmp = v[k * n + i];
1786 12           v[k * n + i] = v[k * n + max_k];
1787 12           v[k * n + max_k] = tmp;
1788             }
1789             }
1790             }
1791 7           }
1792              
1793             // --- pull a numeric value out of an SV* slot
1794 456           static int c2c_num(pTHX_ SV **restrict ep, NV *restrict out) {
1795 456 50         if (ep && *ep && SvOK(*ep) && looks_like_number(*ep)) {
    50          
    100          
    50          
1796 427           *out = SvNV(*ep);
1797 427           return 1;
1798             }
1799 29           return 0;
1800             }
1801              
1802 4           static SV* c2c_call(pTHX_ SV *restrict cv, SV *restrict rv1, SV *restrict rv2) {
1803 4           dSP;
1804 4           ENTER;
1805 4           SAVETMPS;
1806 4 50         PUSHMARK(SP);
1807 4 50         EXTEND(SP, 2);
1808 4           PUSHs(rv1);
1809 4           PUSHs(rv2);
1810 4           PUTBACK;
1811 4           unsigned int count = call_sv(cv, G_SCALAR);
1812 3           SPAGAIN;
1813 3 50         SV *restrict ret = (count > 0) ? newSVsv(POPs) : newSV(0);
1814 3           PUTBACK;
1815 3 50         FREETMPS;
1816 3           LEAVE;
1817 3           return ret;
1818             }
1819             // Mark col_names[idx] whose name equals (wname,wl) as an outer column; returns
1820             // 1 if a matching column was found, 0 otherwise.
1821 7           static int c2c_mark(SV **col_names, STRLEN *name_len, size_t ncols, const char *wname, STRLEN wl, char *is_outer) {
1822 17 100         for (size_t cc = 0; cc < ncols; cc++) {
1823 15 100         if (name_len[cc] == wl && memEQ(SvPVX(col_names[cc]), wname, wl)) { is_outer[cc] = 1; return 1; }
    100          
1824             }
1825 2           return 0;
1826             }
1827             //
1828             // filter() helpers — place this block in the C section, ABOVE the MODULE line
1829             //
1830             // Resolve the cell SV for a column in the "current row".
1831             // AoH: current row is row_hv -> hv_fetch(row_hv, col)
1832             // HoA: current row is index idx -> hv_fetch(data_hv,col) -> AV -> av_fetch(idx)
1833             typedef struct {
1834             int is_aoh;
1835             HV *restrict row_hv;
1836             HV *restrict data_hv;
1837             SSize_t idx;
1838             } filt_ctx;
1839 97           static SV* filt_cell(pTHX_ filt_ctx *restrict ctx, const char *restrict col, STRLEN clen) {
1840 97 100         if (ctx->is_aoh) {
1841 82           SV **restrict p = hv_fetch(ctx->row_hv, col, clen, 0);
1842 82 100         return (p && *p) ? *p : NULL;
    50          
1843             }
1844 15           SV **restrict cp = hv_fetch(ctx->data_hv, col, clen, 0);
1845 15 50         if (!cp || !*cp || !SvROK(*cp) || SvTYPE(SvRV(*cp)) != SVt_PVAV) return NULL;
    50          
    50          
    50          
1846 15           SV **restrict vp = av_fetch((AV*)SvRV(*cp), ctx->idx, 0);
1847 15 50         return (vp && *vp) ? *vp : NULL;
    50          
1848             }
1849             // Recursively interpret a Stats::LikeR::Pred tree against the current row.
1850 116           static bool filt_eval(pTHX_ SV *restrict pred, filt_ctx *restrict ctx) {
1851 116 50         if (!pred || !SvROK(pred) || SvTYPE(SvRV(pred)) != SVt_PVHV)
    50          
    50          
1852 0           croak("filter: malformed predicate (expected an object built with col())");
1853 116           HV *restrict h = (HV*)SvRV(pred);
1854 116           SV **restrict opp = hv_fetchs(h, "op", 0);
1855 116 50         if (!opp || !*opp) croak("filter: predicate node missing 'op'");
    50          
1856 116           const char *restrict op = SvPV_nolen(*opp);
1857 116 100         if (strEQ(op, "and") || strEQ(op, "or")) {
    100          
1858 15           SV **restrict lp = hv_fetchs(h, "l", 0);
1859 15           SV **restrict rp = hv_fetchs(h, "r", 0);
1860 15 50         bool L = filt_eval(aTHX_ (lp ? *lp : NULL), ctx);
1861 15 100         if (op[0] == 'a') return L ? filt_eval(aTHX_ (rp ? *rp : NULL), ctx) : 0; // and
    100          
    50          
    100          
1862 4 100         return L ? 1 : filt_eval(aTHX_ (rp ? *rp : NULL), ctx); // or
    50          
    100          
1863             }
1864 101 100         if (strEQ(op, "not")) {
1865 4           SV **restrict lp = hv_fetchs(h, "l", 0);
1866 4 50         return !filt_eval(aTHX_ (lp ? *lp : NULL), ctx);
1867             }
1868 97           SV **restrict cp = hv_fetchs(h, "col", 0);
1869 97           SV **restrict vp = hv_fetchs(h, "val", 0);
1870 97 50         if (!cp || !*cp) croak("filter: comparison node missing 'col'");
    50          
1871             STRLEN clen;
1872 97           const char *restrict col = SvPV(*cp, clen);
1873 97           SV *restrict cell = filt_cell(aTHX_ ctx, col, clen);
1874 97 100         if (!cell || !SvOK(cell)) return 0; // missing / undef cell never matches
    100          
1875 95 50         SV *restrict val = (vp && *vp) ? *vp : &PL_sv_undef;
    50          
1876 95 100         if (strEQ(op, ">")) return SvNV(cell) > SvNV(val);
1877 54 100         if (strEQ(op, "<")) return SvNV(cell) < SvNV(val);
1878 41 100         if (strEQ(op, ">=")) return SvNV(cell) >= SvNV(val);
1879 34 100         if (strEQ(op, "<=")) return SvNV(cell) <= SvNV(val);
1880 30 100         if (strEQ(op, "==")) return SvNV(cell) == SvNV(val);
1881 19 100         if (strEQ(op, "!=")) return SvNV(cell) != SvNV(val);
1882             {
1883             STRLEN al, bl;
1884 15           const char *restrict a = SvPV(cell, al);
1885 15           const char *restrict b = SvPV(val, bl);
1886 15           STRLEN m = al < bl ? al : bl;
1887 15 50         int c = m ? memcmp(a, b, m) : 0;
1888 15 100         if (c == 0) c = (al > bl) - (al < bl);
1889 23 100         if (strEQ(op, "eq")) return c == 0;
1890 8 100         if (strEQ(op, "ne")) return c != 0;
1891 4 50         if (strEQ(op, "lt")) return c < 0;
1892 4 50         if (strEQ(op, "gt")) return c > 0;
1893 0 0         if (strEQ(op, "le")) return c <= 0;
1894 0 0         if (strEQ(op, "ge")) return c >= 0;
1895             }
1896 0           croak("filter: unknown operator '%s' in predicate", op);
1897             return 0; // not reached
1898             }
1899             // Call a coderef predicate with $_ (and $_[0]) set to the row hashref.
1900 12           static bool filt_call(pTHX_ SV *restrict cv, SV *restrict row) {
1901 12           dSP;
1902             bool keep;
1903             int n;
1904 12           ENTER; SAVETMPS;
1905 12           SAVE_DEFSV;
1906 12           DEFSV_set(row);
1907 12 50         PUSHMARK(SP);
1908 12 50         EXTEND(SP, 1);
1909 12           PUSHs(row);
1910 12           PUTBACK;
1911 12           n = call_sv(cv, G_SCALAR);
1912 12           SPAGAIN;
1913 12 50         keep = (n > 0) ? (bool)SvTRUE(TOPs) : 0;
    100          
1914 12 50         if (n > 0) (void)POPs;
1915 12           PUTBACK;
1916 12 50         FREETMPS; LEAVE;
1917 12           return keep;
1918             }
1919              
1920 12           static int h2h_keycmp(const void *pa, const void *pb) {
1921             dTHX;
1922 12           SV *restrict const *a = (SV * const *)pa;
1923 12           SV *restrict const *b = (SV * const *)pb;
1924 12           return sv_cmp(*a, *b);
1925             }
1926             // Call a column predicate as $cv->($col_values, $col_name) and return its truth.
1927             // $col_values is an array ref of the column's DEFINED cells; $col_name is the
1928             // column key. Used so a block like sub { sd($_[0]) == 0 } can pick columns out.
1929 39           static bool cf_pred(pTHX_ SV *cv_sv, AV *a_av, AV *b_av, SV *name_sv) {
1930 39           dSP;
1931 39           bool truth = FALSE;
1932             int count;
1933 39           ENTER;
1934 39           SAVETMPS;
1935 39 50         PUSHMARK(SP);
1936 39 50         XPUSHs(sv_2mortal(newRV_inc((SV*)a_av)));
1937 39 100         if (b_av) XPUSHs(sv_2mortal(newRV_inc((SV*)b_av)));
    50          
1938 39 50         XPUSHs(sv_2mortal(newSVsv(name_sv)));
1939 39           PUTBACK;
1940 39           count = call_sv(cv_sv, G_SCALAR);
1941 39           SPAGAIN;
1942 39 50         if (count > 0) {
1943 39           SV *restrict ret = POPs; // POPs has a side effect: pop exactly once,
1944 39           truth = cBOOL(SvTRUE(ret)); // because SvTRUE() may evaluate its arg twice.
1945             }
1946 39           PUTBACK;
1947 39 50         FREETMPS;
1948 39           LEAVE;
1949 39           return truth;
1950             }
1951             /* ---------------------------------------------------------------------------
1952             * Helpers for _parse_csv_file. Place in the C section of the .xs file
1953             * (above the first MODULE line).
1954             * ------------------------------------------------------------------------- */
1955              
1956             /* save-stack destructor: closes the input handle on ANY exit, including a
1957             * croak thrown inside the row callback */
1958 547           static void S_pclose(pTHX_ void *p)
1959             {
1960 547           PerlIO_close((PerlIO*)p);
1961 547           }
1962              
1963             /* Finish the current record: push the pending field, hand the row to the
1964             * callback (streaming) or to @$data (slurp), and start a fresh row.
1965             *
1966             * Ownership: the row AV's single reference is transferred to a MORTAL RV
1967             * (newRV_noinc + sv_2mortal). On the normal path the inner FREETMPS releases
1968             * it; if the callback dies, the unwind's FREETMPS releases it just the same.
1969             * If the callback kept a copy of the ref, that copy bumped the refcount and
1970             * the row survives for the caller -- exactly the old semantics, minus the
1971             * leak and minus one SvREFCNT_dec per row. */
1972 6782           static void S_emit_row(pTHX_ AV **rowp, SV *field, bool use_cb, SV *callback, AV *data)
1973             {
1974 6782           av_push(*rowp, newSVsv(field));
1975 6782           sv_setpvs(field, "");
1976 6782 100         if (use_cb) {
1977 6780           AV *restrict row = *rowp;
1978 6780           *rowp = NULL; /* ownership leaves this function NOW */
1979 6780           dSP;
1980 6780           ENTER;
1981 6780           SAVETMPS;
1982 6780 50         PUSHMARK(SP);
1983 6780 50         XPUSHs(sv_2mortal(newRV_noinc((SV*)row)));
1984 6780           PUTBACK;
1985 6780           call_sv(callback, G_DISCARD); /* may die: nothing left to leak */
1986 6774 50         FREETMPS;
1987 6774           LEAVE;
1988             } else {
1989 2           av_push(data, newRV_noinc((SV*)*rowp));
1990 2           *rowp = NULL;
1991             }
1992 6776           *rowp = newAV();
1993 6776           }
1994              
1995             static void
1996 81           lm_append(pTHX_ char **bufp, size_t *lenp, size_t *capp, const char *s)
1997             {
1998 81           size_t slen = strlen(s);
1999 81           size_t sep = (*lenp > 0) ? 1 : 0;
2000 81           size_t need = *lenp + sep + slen + 1; /* + NUL */
2001 81 100         if (need > *capp) {
2002 38 50         size_t nc = (*capp > 0) ? *capp : 64;
2003 108 100         while (nc < need) nc *= 2;
2004 38           Renew(*bufp, nc, char);
2005 38           *capp = nc;
2006             }
2007 81           char *dst = *bufp + *lenp;
2008 81 100         if (sep) *dst++ = '+';
2009 81           memcpy(dst, s, slen);
2010 81           dst[slen] = '\0';
2011 81           *lenp += sep + slen;
2012 81           }
2013              
2014             static int
2015 12           lm_str_qsort(const void *a, const void *b)
2016             {
2017 12           return strcmp(*(const char *const *)a, *(const char *const *)b);
2018             }
2019             typedef int (*cs_cmp_fn)(pTHX_ void *restrict ctx, size_t i, size_t j);
2020              
2021             /* Sort by a named column: pre-fetched cell SVs plus a numeric/string flag. */
2022             typedef struct {
2023             SV **restrict vals; /* borrowed cell SV* per row (NULL == missing) */
2024             unsigned short numeric; /* 1 => compare with SvNV, 0 => compare with sv_cmp */
2025             } cs_col_ctx;
2026              
2027             /* Sort by a user comparator: per-row refs handed to $a/$b before each call. */
2028             typedef struct {
2029             SV **restrict rows; /* row ref per index (RV to HV) */
2030             CV *restrict cv; /* the comparator */
2031             SV *a_sv; /* scalar currently aliased to package $a */
2032             SV *b_sv; /* scalar currently aliased to package $b */
2033             } cs_code_ctx;
2034              
2035 51           static int cs_col_cmp(pTHX_ void *restrict vctx, size_t i, size_t j) {
2036 51           cs_col_ctx *restrict c = (cs_col_ctx *)vctx;
2037 51           SV *restrict av = c->vals[i];
2038 51           SV *restrict bv = c->vals[j];
2039 51 100         int a_ok = (av && SvOK(av));
    100          
2040 51 100         int b_ok = (bv && SvOK(bv));
    100          
2041 51 100         if (!a_ok || !b_ok) { /* undef/missing always sorts last */
    100          
2042 6 100         if (!a_ok && !b_ok) return 0;
    100          
2043 5 100         return a_ok ? -1 : 1;
2044             }
2045 45 100         if (c->numeric) {
2046 41           NV x = SvNV(av), y = SvNV(bv);
2047 41           return (x > y) - (x < y);
2048             }
2049 4           return sv_cmp(av, bv); /* Perl's `cmp` semantics */
2050             }
2051              
2052 24           static int cs_code_cmp(pTHX_ void *restrict vctx, size_t i, size_t j) {
2053 24           cs_code_ctx *restrict c = (cs_code_ctx *)vctx;
2054 24           dSP;
2055             size_t count;
2056             NV r;
2057             /* alias the two rows into the comparator's $a / $b */
2058 24           sv_setsv(c->a_sv, c->rows[i]);
2059 24           sv_setsv(c->b_sv, c->rows[j]);
2060 24           ENTER;
2061 24           SAVETMPS;
2062 24 50         PUSHMARK(SP);
2063             /* sort comparators read $a/$b, not @_, so we push no arguments */
2064 24           PUTBACK;
2065 24           count = call_sv((SV *)c->cv, G_SCALAR);
2066 24           SPAGAIN;
2067 24 50         if (count > 0) {
2068             /* POPs has a side effect (sp--) and SvNV is a macro that may
2069             * evaluate its argument more than once on older perls (5.10),
2070             * so capture the SV first rather than writing SvNV(POPs). */
2071 24           SV *res = POPs;
2072 24           r = SvNV(res);
2073             } else {
2074 0           r = 0.0;
2075             }
2076 24           PUTBACK;
2077 24 50         FREETMPS;
2078 24           LEAVE;
2079 24           return (r > 0) - (r < 0);
2080             }
2081              
2082             /* Stable bottom merge for the index permutation. */
2083 21           static void cs_merge(pTHX_ size_t *restrict idx, size_t *restrict tmp,
2084             size_t lo, size_t mid, size_t hi,
2085             cs_cmp_fn cmp, void *restrict ctx) {
2086 21           size_t i = lo, j = mid, k = lo;
2087 59 100         while (i < mid && j < hi) {
    100          
2088             /* `<= 0` keeps equal elements in original order => stable */
2089 38 100         if (cmp(aTHX_ ctx, idx[i], idx[j]) <= 0) tmp[k++] = idx[i++];
2090 29           else tmp[k++] = idx[j++];
2091             }
2092 35 100         while (i < mid) tmp[k++] = idx[i++];
2093 28 100         while (j < hi) tmp[k++] = idx[j++];
2094 80 100         for (size_t t = lo; t < hi; t++) idx[t] = tmp[t];
2095 21           }
2096              
2097 93           static void cs_msort(pTHX_ size_t *restrict idx, size_t *restrict tmp,
2098             size_t lo, size_t hi,
2099             cs_cmp_fn cmp, void *restrict ctx) {
2100 93 100         if (hi - lo < 2) return;
2101 37           size_t mid = lo + (hi - lo) / 2;
2102 37           cs_msort(aTHX_ idx, tmp, lo, mid, cmp, ctx);
2103 37           cs_msort(aTHX_ idx, tmp, mid, hi, cmp, ctx);
2104             /* skip the merge when the halves are already in order */
2105 37 100         if (cmp(aTHX_ ctx, idx[mid - 1], idx[mid]) <= 0) return;
2106 21           cs_merge(aTHX_ idx, tmp, lo, mid, hi, cmp, ctx);
2107             }
2108              
2109             /* Resolve $a / $b in the package where the comparator was compiled, localize
2110             * them for the duration of the sort, and point them at two fresh scalars.
2111             * Mirrors what Perl's own sort does. The save stack (ENTER must already be in
2112             * effect) restores the caller's $a/$b on scope exit, including via croak. */
2113 6           static void cs_bind_ab(pTHX_ CV *restrict cv, SV **a_out, SV **b_out) {
2114 6           HV *restrict stash = CvSTASH(cv);
2115 6 50         if (!stash) stash = PL_curstash;
2116 6 50         const char *restrict pkg = stash ? HvNAME(stash) : NULL;
    50          
    50          
    50          
    0          
    50          
    50          
2117 6 50         if (!pkg) pkg = "main";
2118 6           STRLEN plen = strlen(pkg);
2119              
2120             /* build "::a" / "::b" so the GVs land in the right stash */
2121             char *restrict buf;
2122 6           Newx(buf, plen + 4, char);
2123 6           SAVEFREEPV(buf);
2124 6           memcpy(buf, pkg, plen);
2125 6           buf[plen] = ':'; buf[plen + 1] = ':'; buf[plen + 3] = '\0';
2126              
2127 6           buf[plen + 2] = 'a';
2128 6           GV *agv = gv_fetchpv(buf, GV_ADD, SVt_PV);
2129 6           buf[plen + 2] = 'b';
2130 6           GV *bgv = gv_fetchpv(buf, GV_ADD, SVt_PV);
2131              
2132 6           SAVESPTR(GvSV(agv));
2133 6           SAVESPTR(GvSV(bgv));
2134 6           SV *a_sv = sv_newmortal();
2135 6           SV *b_sv = sv_newmortal();
2136 6           GvSV(agv) = a_sv;
2137 6           GvSV(bgv) = b_sv;
2138 6           *a_out = a_sv;
2139 6           *b_out = b_sv;
2140 6           }
2141              
2142             /* Build the sorted result in the requested shape (out_aoh = 1 => AoH, else
2143             * HoA), reading from whichever shape the input was. idx[0..n) is the sorted
2144             * permutation of original row indices. Handles all four input/output
2145             * combinations, including transposing AoH<->HoA. Returns a new owned ref. */
2146 27           static SV *cs_materialize(pTHX_ bool out_aoh, bool is_aoh, AV *restrict src_av,
2147             SV **restrict colkeys, AV **restrict colavs,
2148             size_t ncols, size_t *restrict idx, size_t n) {
2149 27 100         if (out_aoh) {
2150 17           AV *out = newAV();
2151 17 100         if (n) av_extend(out, (SSize_t)n - 1);
2152 17 100         if (is_aoh) {
2153             /* AoH -> AoH: reorder, sharing the original row hashrefs */
2154 47 100         for (size_t k = 0; k < n; k++) {
2155 34           SV **restrict rp = av_fetch(src_av, (SSize_t)idx[k], 0);
2156 34 50         SV *restrict row = (rp && *rp) ? *rp : &PL_sv_undef;
    50          
2157 34           av_push(out, SvREFCNT_inc_simple_NN(row));
2158             }
2159             } else {
2160             /* HoA -> AoH: synthesize one hashref per row (copied cells) */
2161 11 100         for (size_t k = 0; k < n; k++) {
2162 7           HV *rh = newHV();
2163 21 100         for (size_t c = 0; c < ncols; c++) {
2164 14           SV **cp = av_fetch(colavs[c], (SSize_t)idx[k], 0);
2165 14 50         hv_store_ent(rh, colkeys[c],
    50          
2166             (cp && *cp) ? newSVsv(*cp) : newSV(0), 0);
2167             }
2168 7           av_push(out, newRV_noinc((SV *)rh));
2169             }
2170             }
2171 17           return newRV_noinc((SV *)out);
2172             }
2173             /* ---- output is HoA */
2174 10           HV *restrict out = newHV();
2175 10 100         if (!is_aoh) {
2176             /* HoA -> HoA: permute every column in lockstep (copied cells) */
2177 14 100         for (size_t c = 0; c < ncols; c++) {
2178 8           AV *restrict ncol = newAV();
2179 8 50         if (n) av_extend(ncol, (SSize_t)n - 1);
2180 27 100         for (size_t k = 0; k < n; k++) {
2181 19           SV **restrict cp = av_fetch(colavs[c], (SSize_t)idx[k], 0);
2182 19 50         av_push(ncol, (cp && *cp) ? newSVsv(*cp) : newSV(0));
    50          
2183             }
2184 8           hv_store_ent(out, colkeys[c], newRV_noinc((SV *)ncol), 0);
2185             }
2186 6           return newRV_noinc((SV *)out);
2187             }
2188             /* AoH -> HoA: column set is the union of the rows' keys, ordered by
2189             * first appearance; absent cells become undef. */
2190 4           AV *restrict keylist = (AV *)sv_2mortal((SV *)newAV());
2191 4           HV *restrict seen = (HV *)sv_2mortal((SV *)newHV());
2192 11 100         for (size_t i = 0; i < n; i++) {
2193 7           SV **restrict rp = av_fetch(src_av, (SSize_t)i, 0);
2194 7 50         if (!(rp && *rp && SvROK(*rp) && SvTYPE(SvRV(*rp)) == SVt_PVHV))
    50          
    50          
    50          
2195 0           continue;
2196 7           HV *restrict rh = (HV *)SvRV(*rp);
2197             HE *restrict he;
2198 7           hv_iterinit(rh);
2199 28 100         while ((he = hv_iternext(rh))) {
2200 14           SV *restrict ksv = hv_iterkeysv(he);
2201 14 100         if (!hv_exists_ent(seen, ksv, 0)) {
2202 7           (void)hv_store_ent(seen, ksv, newSViv(1), 0);
2203 7           av_push(keylist, newSVsv(ksv));
2204             }
2205             }
2206             }
2207 4           SSize_t nk = av_len(keylist) + 1;
2208 11 100         for (SSize_t c = 0; c < nk; c++) {
2209 7           SV *restrict ksv = *av_fetch(keylist, c, 0);
2210 7           AV *restrict ncol = newAV();
2211 7 50         if (n) av_extend(ncol, (SSize_t)n - 1);
2212 24 100         for (size_t k = 0; k < n; k++) {
2213 17           SV **restrict rp = av_fetch(src_av, (SSize_t)idx[k], 0);
2214 17           SV *restrict cell = NULL;
2215 17 50         if (rp && *rp && SvROK(*rp) && SvTYPE(SvRV(*rp)) == SVt_PVHV) {
    50          
    50          
    50          
2216 17           HE *restrict he = hv_fetch_ent((HV *)SvRV(*rp), ksv, 0, 0);
2217 17 100         if (he) cell = HeVAL(he);
2218             }
2219 17 100         av_push(ncol, cell ? newSVsv(cell) : newSV(0));
2220             }
2221 7           hv_store_ent(out, ksv, newRV_noinc((SV *)ncol), 0);
2222             }
2223 4           return newRV_noinc((SV *)out);
2224             }
2225             // --- XS SECTION ---
2226             MODULE = Stats::LikeR PACKAGE = Stats::LikeR
2227              
2228             SV *aoh2hoa(data)
2229             SV *data
2230             CODE:
2231             {
2232             /* =================================================================
2233             * aoh2hoa($aoh) -- transpose an Array-of-Hashes into a
2234             * Hash-of-Arrays.
2235             *
2236             * in : arrayref of hashrefs (rows) [ {a=>1,b=>2}, {a=>3} ]
2237             * out: hashref of arrayrefs (cols) { a=>[1,3], b=>[2,undef] }
2238             *
2239             * - Columns are the union of all row keys.
2240             * - Every column has exactly scalar(@$aoh) elements; cells absent
2241             * from a given row are undef (kept as cheap holes, not SVs).
2242             * - Values are copied, so the result is independent of the input
2243             * (a value that is itself a reference is copied shallowly, just
2244             * like Perl's $col->[$i] = $row->{$k} ).
2245             * - A row that is not a hashref contributes undef to every column
2246             * at its index (skipped, not fatal).
2247             * ================================================================= */
2248             AV *restrict aoh;
2249             HV *restrict out;
2250             SSize_t n, i;
2251             HE *he;
2252              
2253 12 100         if (!SvROK(data) || SvTYPE(SvRV(data)) != SVt_PVAV)
    100          
2254 2           croak("aoh2hoa: argument must be an arrayref of hashrefs");
2255              
2256 10           aoh = (AV *)SvRV(data);
2257 10           n = av_len(aoh) + 1; /* number of rows */
2258 10           out = newHV();
2259              
2260 28 100         for (i = 0; i < n; i++) {
2261 18           SV **rp = av_fetch(aoh, i, 0);
2262             HV *row;
2263              
2264 18 50         if (!(rp && *rp && SvROK(*rp)
    50          
    100          
2265 17 50         && SvTYPE(SvRV(*rp)) == SVt_PVHV))
2266 1           continue; /* non-hashref row -> all undef */
2267              
2268 17           row = (HV *)SvRV(*rp);
2269 17           hv_iterinit(row);
2270 35 100         while ((he = hv_iternext(row))) {
2271 18           SV *ksv = hv_iterkeysv(he); /* utf8 / SV-key safe */
2272 18           HE *oute = hv_fetch_ent(out, ksv, 0, 0);
2273             AV *col;
2274              
2275 18 100         if (oute && SvROK(HeVAL(oute))
    50          
2276 7 50         && SvTYPE(SvRV(HeVAL(oute))) == SVt_PVAV) {
2277 7           col = (AV *)SvRV(HeVAL(oute));
2278             } else {
2279 11           col = newAV();
2280 11 50         if (n > 0) av_extend(col, n - 1);
2281 11           (void)hv_store_ent(out, ksv,
2282             newRV_noinc((SV *)col), 0);
2283             }
2284 18           av_store(col, i, newSVsv(HeVAL(he)));
2285             }
2286             }
2287              
2288             /* pad every column out to exactly n elements (trailing undefs) */
2289 10           hv_iterinit(out);
2290 31 100         while ((he = hv_iternext(out))) {
2291 11           AV *col = (AV *)SvRV(HeVAL(he));
2292 11 100         if (av_len(col) < n - 1)
2293 1           av_fill(col, n - 1);
2294             }
2295              
2296 10           RETVAL = newRV_noinc((SV *)out);
2297             }
2298             OUTPUT:
2299             RETVAL
2300              
2301             void
2302             csort(data, by, output=&PL_sv_undef)
2303             SV *data
2304             SV *by
2305             SV *output
2306             PREINIT:
2307             bool is_aoh, is_code, out_aoh;
2308 34           const char *restrict colname = NULL;
2309 34           STRLEN collen = 0;
2310 34           CV *restrict cmp_cv = NULL;
2311 34           AV *restrict src_av = NULL; /* AoH input */
2312 34           HV *restrict src_hv = NULL; /* HoA input */
2313 34           SSize_t n = 0;
2314 34           size_t *restrict idx = NULL, *tmp = NULL;
2315 34           SV **restrict rowrefs = NULL; /* coderef mode: row ref per index */
2316 34           SV **restrict colkeys = NULL; /* HoA: column key SVs */
2317 34           AV **restrict colavs = NULL; /* HoA: column AVs */
2318 34           size_t ncols = 0;
2319 34 100         SV *restrict result = NULL;
2320             PPCODE:
2321             {
2322             /* ---- classify $by: coderef comparator vs column name ------------ */
2323 34 100         if (SvROK(by) && SvTYPE(SvRV(by)) == SVt_PVCV) {
    100          
2324 6           is_code = 1;
2325 6           cmp_cv = (CV *)SvRV(by);
2326 28 100         } else if (SvOK(by) && !SvROK(by)) {
    100          
2327 26           is_code = 0;
2328 26           colname = SvPV(by, collen);
2329             } else {
2330 2           croak("csort: second argument must be a column name or a "
2331             "comparator code-ref using $a and $b");
2332             }
2333              
2334             /* ---- classify $data: AoH (arrayref) vs HoA (hashref) ------------ */
2335 32 100         if (!SvROK(data))
2336 1           croak("csort: first argument must be an array-ref (AoH) or "
2337             "hash-ref (HoA)");
2338 31 100         if (SvTYPE(SvRV(data)) == SVt_PVAV) {
2339 18           is_aoh = 1;
2340 18           src_av = (AV *)SvRV(data);
2341 18           n = av_len(src_av) + 1;
2342 13 50         } else if (SvTYPE(SvRV(data)) == SVt_PVHV) {
2343 13           is_aoh = 0;
2344 13           src_hv = (HV *)SvRV(data);
2345             } else {
2346 0           croak("csort: first argument must be an array-ref (AoH) or "
2347             "hash-ref (HoA)");
2348             }
2349              
2350             /* ---- resolve requested output shape (default: match input) ------ */
2351 31 100         if (!SvOK(output)) {
2352 20           out_aoh = is_aoh;
2353             } else {
2354             STRLEN ol;
2355 11           const char *restrict os = SvPV(output, ol);
2356 11 100         if (ol == 3 && toLOWER(os[0]) == 'a' && toLOWER(os[1]) == 'o'
    100          
    100          
    100          
    50          
    0          
    50          
2357 5 100         && toLOWER(os[2]) == 'h')
    50          
    50          
2358 5           out_aoh = 1;
2359 6 100         else if (ol == 3 && toLOWER(os[0]) == 'h' && toLOWER(os[1]) == 'o'
    100          
    50          
    50          
    50          
    0          
    50          
2360 5 100         && toLOWER(os[2]) == 'a')
    50          
    50          
2361 5           out_aoh = 0;
2362             else
2363 1           croak("csort: output type must be 'aoh' or 'hoa' (got '%s')", os);
2364             }
2365              
2366 30           ENTER; /* scope for SAVEFREEPV / SAVESPTR cleanups */
2367 30           SAVETMPS; /* reap transient synthesized rows here */
2368              
2369             // ---- gather HoA column metadata + validate equal lengths --------
2370 30 100         if (!is_aoh) {
2371             HE *restrict he;
2372 13           SSize_t common = -2; /* -2 = unset sentinel */
2373 13           hv_iterinit(src_hv);
2374 29 100         while ((he = hv_iternext(src_hv))) {
2375 18           SV *restrict cv = HeVAL(he);
2376 18 50         if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVAV)
    100          
    50          
2377 1 50         croak("csort: HoA value for column '%s' is not an "
2378             "array-ref", HePV(he, PL_na));
2379 17           SSize_t len = av_len((AV *)SvRV(cv)) + 1;
2380 17 100         if (common == -2) common = len;
2381 7 100         else if (len != common)
2382 1           croak("csort: HoA columns have unequal lengths "
2383             "(%" IVdf " vs %" IVdf ")",
2384             (IV)common, (IV)len);
2385 16           ncols++;
2386             }
2387 11           n = (common < 0) ? 0 : common;
2388              
2389 11 100         if (ncols) {
2390 9 50         Newx(colkeys, ncols, SV *); SAVEFREEPV(colkeys);
2391 9 50         Newx(colavs, ncols, AV *); SAVEFREEPV(colavs);
2392 9           size_t c = 0;
2393 9           hv_iterinit(src_hv);
2394 24 100         while ((he = hv_iternext(src_hv))) {
2395 15           colkeys[c] = sv_2mortal(newSVsv(hv_iterkeysv(he)));
2396 15           colavs[c] = (AV *)SvRV(HeVAL(he));
2397 15           c++;
2398             }
2399             }
2400             }
2401              
2402             /* ---- build the identity permutation (sorted in place below) ----- */
2403 28 100         Newx(idx, (size_t)(n > 0 ? n : 1), size_t); SAVEFREEPV(idx);
    50          
    100          
2404 28 100         Newx(tmp, (size_t)(n > 0 ? n : 1), size_t); SAVEFREEPV(tmp);
    50          
    100          
2405 90 100         for (size_t i = 0; i < (size_t)n; i++) idx[i] = i;
2406              
2407 28 100         if (n > 1) {
2408 20 100         if (is_code) {
2409             /* ---- comparator mode: prepare row refs + bind $a/$b -------- */
2410 6 50         Newx(rowrefs, (size_t)n, SV *); SAVEFREEPV(rowrefs);
2411            
2412 6 100         if (is_aoh) {
2413 16 100         for (size_t i = 0; i < (size_t)n; i++) {
2414 12           SV **restrict rp = av_fetch(src_av, (SSize_t)i, 0);
2415 12 50         rowrefs[i] = (rp && *rp) ? *rp : &PL_sv_undef;
    50          
2416             }
2417             } else {
2418             /* synthesize a per-row hashref view of the columns;
2419             * cells are aliased (shared) -- read-only in a comparator */
2420 8 100         for (size_t i = 0; i < (size_t)n; i++) {
2421 6           HV *restrict rh = newHV();
2422 18 100         for (size_t c = 0; c < ncols; c++) {
2423 12           SV **restrict cp = av_fetch(colavs[c], (SSize_t)i, 0);
2424 12 50         SV *restrict cell = (cp && *cp)
2425 24 50         ? SvREFCNT_inc_simple_NN(*cp) : newSV(0);
2426 12           hv_store_ent(rh, colkeys[c], cell, 0);
2427             }
2428 6           rowrefs[i] = sv_2mortal(newRV_noinc((SV *)rh));
2429             }
2430             }
2431            
2432             cs_code_ctx ctx;
2433 6           ctx.rows = rowrefs;
2434 6           ctx.cv = cmp_cv;
2435 6           cs_bind_ab(aTHX_ cmp_cv, &ctx.a_sv, &ctx.b_sv);
2436 6           cs_msort(aTHX_ idx, tmp, 0, (size_t)n, cs_code_cmp, &ctx);
2437             } else {
2438             /* ---- column mode: gather cells, detect numeric, sort ------- */
2439             SV **restrict vals;
2440 14 50         Newx(vals, (size_t)n, SV *); SAVEFREEPV(vals);
2441 14           bool found = 0;
2442 14           unsigned short numeric = 1;
2443            
2444 14 100         if (is_aoh) {
2445 36 100         for (size_t i = 0; i < (size_t)n; i++) {
2446 27           SV *restrict cell = NULL;
2447 27           SV **restrict rp = av_fetch(src_av, (SSize_t)i, 0);
2448 27 50         if (rp && *rp && SvROK(*rp)
    50          
    50          
2449 27 50         && SvTYPE(SvRV(*rp)) == SVt_PVHV) {
2450 27           SV **restrict cp = hv_fetch((HV *)SvRV(*rp),
2451             colname, collen, 0);
2452 27 100         if (cp && *cp) { cell = *cp; found = 1; }
    50          
2453             }
2454 27 100         if (cell && SvOK(cell) && !looks_like_number(cell))
    100          
    100          
2455 3           numeric = 0;
2456 27           vals[i] = cell;
2457             }
2458             } else {
2459 5           SV **colp = hv_fetch(src_hv, colname, collen, 0);
2460 5 100         if (!(colp && *colp && SvROK(*colp)
    50          
    50          
2461 4 50         && SvTYPE(SvRV(*colp)) == SVt_PVAV))
2462 1           croak("csort: column '%s' not found in HoA", colname);
2463 4           found = 1;
2464 4           AV *col = (AV *)SvRV(*colp);
2465 15 100         for (size_t i = 0; i < (size_t)n; i++) {
2466 11           SV **cp = av_fetch(col, (SSize_t)i, 0);
2467 11 50         SV *cell = (cp && *cp) ? *cp : NULL;
    50          
2468 11 50         if (cell && SvOK(cell) && !looks_like_number(cell))
    50          
    50          
2469 0           numeric = 0;
2470 11           vals[i] = cell;
2471             }
2472             }
2473 13 50         if (!found)
2474 0           croak("csort: column '%s' not found", colname);
2475            
2476             cs_col_ctx ctx;
2477 13           ctx.vals = vals;
2478 13           ctx.numeric = numeric;
2479 13           cs_msort(aTHX_ idx, tmp, 0, (size_t)n, cs_col_cmp, &ctx);
2480             }
2481             } /* end if (n > 1) */
2482              
2483             /* ---- materialize the result in the requested shape -------------- */
2484 27           result = cs_materialize(aTHX_ out_aoh, is_aoh, src_av,
2485             colkeys, colavs, ncols, idx, (size_t)n);
2486              
2487 27 100         FREETMPS; /* reap synthesized rows; restores $a/$b via the save stack at LEAVE */
2488 27           LEAVE;
2489              
2490 27 50         XPUSHs(sv_2mortal(result));
2491 27           XSRETURN(1);
2492             }
2493              
2494             SV *cfilter(data, ...)
2495             SV *data
2496             CODE:
2497             {
2498             /* 0. options. Exactly one of keep/remove is required; it is either an
2499             array ref of column names or a value predicate (CODE ref / function
2500             name). For a predicate, undef handling is:
2501             na => 'keep' (default) - the predicate sees every cell, incl undef
2502             na => 'omit' - single-column funcs (sd) get defined cells
2503             against => 'col' - two-column funcs (cor): the predicate gets
2504             ($col, $ref) over rows defined in BOTH.*/
2505 32           SV *restrict keep_sv = NULL, *restrict remove_sv = NULL;
2506 32           SV *restrict na_sv = NULL, *restrict against_sv = NULL;
2507 32 50         if ((items - 1) & 1) croak("cfilter: trailing options must be name => value pairs");
2508 78 100         for (int oi = 1; oi < items; oi += 2) {
2509             STRLEN ol;
2510 47           const char *restrict oname = SvPV(ST(oi), ol);
2511 47           SV *restrict oval = ST(oi + 1);
2512 47 100         if (ol == 4 && memEQ(oname, "keep", 4)) keep_sv = oval;
    50          
2513 18 100         else if (ol == 6 && memEQ(oname, "remove", 6)) remove_sv = oval;
    50          
2514 16 100         else if (ol == 2 && memEQ(oname, "na", 2)) na_sv = oval;
    50          
2515 7 100         else if (ol == 7 && memEQ(oname, "against", 7)) against_sv = oval;
    50          
2516 1           else croak("cfilter: unknown option '%s'", oname);
2517             }
2518 31 100         if (keep_sv && remove_sv) croak("cfilter: give either keep or remove, not both");
    100          
2519 30 100         if (!keep_sv && !remove_sv) croak("cfilter: need a keep or remove argument");
    100          
2520 29           bool removing = (remove_sv != NULL);
2521 29 100         SV *restrict sel = removing ? remove_sv : keep_sv;
2522             // classify the selector: array ref of names, or a value predicate.
2523             bool by_name;
2524 29           SV *restrict cv_sv = NULL;
2525 29 100         if (SvROK(sel) && SvTYPE(SvRV(sel)) == SVt_PVAV) by_name = TRUE;
    100          
2526 18 100         else if ((SvROK(sel) && SvTYPE(SvRV(sel)) == SVt_PVCV) || (SvOK(sel) && !SvROK(sel))) {
    100          
    50          
    100          
2527 17           by_name = FALSE;
2528 17 100         if (SvROK(sel)) cv_sv = SvRV(sel);
2529             else {
2530             STRLEN nl;
2531 1           const char *restrict name = SvPV(sel, nl);
2532 1 50         SV *restrict fq = strstr(name, "::") ? newSVpvn(name, nl) : newSVpvf("Stats::LikeR::%s", name);
2533 1           CV *restrict cv = get_cv(SvPV_nolen(fq), 0);
2534 1           SvREFCNT_dec(fq);
2535 1 50         if (!cv) croak("cfilter: unknown function '%s'", name);
2536 0           cv_sv = (SV*)cv;
2537             }
2538             }
2539 1           else croak("cfilter: keep/remove must be an array ref of column names or a code ref / function name");
2540             // decode the undef policy (predicate only).
2541 27           bool na_omit = FALSE;
2542 27 100         if (na_sv && SvOK(na_sv)) {
    50          
2543             STRLEN nl;
2544 9           const char *restrict nv = SvPV(na_sv, nl);
2545 9 100         if (nl == 4 && memEQ(nv, "omit", 4)) na_omit = TRUE;
    50          
2546 1 50         else if (nl == 4 && memEQ(nv, "keep", 4)) na_omit = FALSE;
    0          
2547 1           else croak("cfilter: na must be 'keep' or 'omit'");
2548             }
2549 26 100         if (by_name && (na_sv || against_sv)) croak("cfilter: na/against only apply to a predicate selector");
    100          
    50          
2550 25 100         if (against_sv && na_sv) croak("cfilter: give na or against, not both");
    100          
2551             // 1. detect the data shape.
2552 24 100         if (!SvROK(data)) croak("cfilter: data must be a reference");
2553 23           SV *restrict rv = SvRV(data);
2554             short int kind; // 0 = array-of-hashes, 1 = hash-of-arrays, 2 = hash-of-hashes
2555 23 100         if (SvTYPE(rv) == SVt_PVAV) kind = 0;
2556 20 50         else if (SvTYPE(rv) == SVt_PVHV) {
2557 20           HV *restrict h = (HV*)rv;
2558 20           hv_iterinit(h);
2559 20           HE *restrict fe = hv_iternext(h);
2560 20 50         if (!fe) kind = 2;
2561             else {
2562 20           SV *restrict fv = hv_iterval(h, fe);
2563 20 50         if (SvROK(fv) && SvTYPE(SvRV(fv)) == SVt_PVAV) kind = 1;
    100          
2564 2 50         else if (SvROK(fv) && SvTYPE(SvRV(fv)) == SVt_PVHV) kind = 2;
    50          
2565 0           else croak("cfilter: hash values must be array refs (HoA) or hash refs (HoH)");
2566             }
2567             }
2568 0           else croak("cfilter: data must be an array ref or hash ref");
2569             // 2. the column universe, and (predicate only) a row-aligned cell table
2570             // `cellmap`: colname -> AV of length nrows, undef in the gaps. The
2571             // alignment lets `against` pair two columns by row.
2572 23           HV *restrict universe = newHV();
2573 23           AV *restrict colnames = newAV();
2574 23 100         HV *restrict cellmap = by_name ? NULL : newHV();
2575 23           SSize_t nrows = 0;
2576 23 100         if (kind == 1) {
2577 18           HV *restrict h = (HV*)rv;
2578             HE *restrict e;
2579 18           hv_iterinit(h);
2580 72 100         while ((e = hv_iternext(h))) {
2581 54           SV *restrict val = hv_iterval(h, e);
2582 54 50         if (!SvROK(val) || SvTYPE(SvRV(val)) != SVt_PVAV) croak("cfilter: every value must be an array ref (hash of arrays)");
    50          
2583 54           SSize_t len = av_len((AV*)SvRV(val)) + 1;
2584 54 100         if (len > nrows) nrows = len;
2585             }
2586 18           hv_iterinit(h);
2587 90 100         while ((e = hv_iternext(h))) {
2588 54           SV *restrict ck = hv_iterkeysv(e);
2589 54           (void)hv_store_ent(universe, ck, newSViv(1), 0);
2590 54           av_push(colnames, newSVsv(ck));
2591 54 100         if (!by_name) {
2592 36           AV *restrict src = (AV*)SvRV(hv_iterval(h, e)), *restrict col = newAV();
2593 36 50         if (nrows > 0) av_extend(col, nrows - 1);
2594 216 100         for (SSize_t r = 0; r < nrows; r++) {
2595 180 50         SV **restrict ep = (r <= av_len(src)) ? av_fetch(src, r, 0) : NULL;
2596 180 50         av_push(col, (ep && *ep && SvOK(*ep)) ? newSVsv(*ep) : newSV(0));
    50          
    100          
2597             }
2598 36           (void)hv_store_ent(cellmap, ck, newRV_noinc((SV*)col), 0);
2599             }
2600             }
2601             } else {
2602             // row-major: collect the rows in a stable order, then build per column.
2603 5           AV *restrict rows = newAV();
2604 5 100         if (kind == 0) {
2605 3           AV *restrict a = (AV*)rv;
2606 3           SSize_t n = av_len(a) + 1;
2607 12 100         for (SSize_t r = 0; r < n; r++) {
2608 9           SV **restrict ep = av_fetch(a, r, 0);
2609 9 50         if (!ep || !*ep || !SvROK(*ep) || SvTYPE(SvRV(*ep)) != SVt_PVHV) croak("cfilter: array elements must be hash refs (array of hashes)");
    50          
    50          
    50          
2610 9           av_push(rows, newRV_inc(SvRV(*ep)));
2611             }
2612             } else {
2613 2           HV *restrict h = (HV*)rv;
2614             HE *restrict e;
2615 2           hv_iterinit(h);
2616 9 100         while ((e = hv_iternext(h))) {
2617 7           SV *restrict val = hv_iterval(h, e);
2618 7 50         if (!SvROK(val) || SvTYPE(SvRV(val)) != SVt_PVHV) croak("cfilter: every value must be a hash ref (hash of hashes)");
    50          
2619 7           av_push(rows, newRV_inc(SvRV(val)));
2620             }
2621             }
2622 5           nrows = av_len(rows) + 1;
2623             // union of columns, in first-seen order.
2624             {
2625 5           HV *restrict seen = newHV();
2626 21 100         for (SSize_t r = 0; r < nrows; r++) {
2627 16           HV *restrict row = (HV*)SvRV(*av_fetch(rows, r, 0));
2628             HE *restrict ie;
2629 16           hv_iterinit(row);
2630 72 100         while ((ie = hv_iternext(row))) {
2631 40           SV *restrict ck = hv_iterkeysv(ie);
2632 40 100         if (!hv_exists_ent(seen, ck, 0)) {
2633 14           (void)hv_store_ent(seen, ck, newSViv(1), 0);
2634 14           (void)hv_store_ent(universe, ck, newSViv(1), 0);
2635 14           av_push(colnames, newSVsv(ck));
2636             }
2637             }
2638             }
2639 5           SvREFCNT_dec((SV*)seen);
2640             }
2641 5 100         if (!by_name) {
2642 2           SSize_t nc = av_len(colnames) + 1;
2643 8 100         for (SSize_t c = 0; c < nc; c++) {
2644 6           SV *restrict ck = *av_fetch(colnames, c, 0);
2645 6           AV *restrict col = newAV();
2646 6 50         if (nrows > 0) av_extend(col, nrows - 1);
2647 36 100         for (SSize_t r = 0; r < nrows; r++) {
2648 30           HV *restrict row = (HV*)SvRV(*av_fetch(rows, r, 0));
2649 30           HE *restrict che = hv_fetch_ent(row, ck, 0, 0);
2650 30 100         SV *restrict cell = che ? HeVAL(che) : NULL;
2651 30 100         av_push(col, (cell && SvOK(cell)) ? newSVsv(cell) : newSV(0));
    50          
2652             }
2653 6           (void)hv_store_ent(cellmap, ck, newRV_noinc((SV*)col), 0);
2654             }
2655             }
2656 5           SvREFCNT_dec((SV*)rows);
2657             }
2658             // 2b. resolve the `against` reference column into its cell array.
2659 23           AV *restrict against_av = NULL;
2660 23 100         if (against_sv) {
2661 5 50         if (!SvOK(against_sv) || SvROK(against_sv)) croak("cfilter: against must be a column name (string)");
    50          
2662 5 100         if (!hv_exists_ent(universe, against_sv, 0)) croak("cfilter: against column '%s' not found in data", SvPV_nolen(against_sv));
2663 4           against_av = (AV*)SvRV(HeVAL(hv_fetch_ent(cellmap, against_sv, 0, 0)));
2664             }
2665             // 3. decide which columns to keep.
2666 22           HV *restrict keepset = newHV();
2667 22 100         if (by_name) {
2668 9           AV *restrict names = (AV*)SvRV(sel);
2669 9           HV *restrict listed = newHV();
2670 9           SSize_t n = av_len(names) + 1;
2671 21 100         for (SSize_t i = 0; i < n; i++) {
2672 13           SV **restrict ep = av_fetch(names, i, 0);
2673 13 50         if (!ep || !*ep || !SvOK(*ep)) croak("cfilter: column list contains an undefined entry");
    50          
    50          
2674 13 100         if (!hv_exists_ent(universe, *ep, 0)) croak("cfilter: column '%s' not found in data", SvPV_nolen(*ep));
2675 12           (void)hv_store_ent(listed, *ep, newSViv(1), 0);
2676             }
2677 8           SSize_t nc = av_len(colnames) + 1;
2678 31 100         for (SSize_t c = 0; c < nc; c++) {
2679 23           SV *restrict ck = *av_fetch(colnames, c, 0);
2680 23           bool in_list = cBOOL(hv_exists_ent(listed, ck, 0));
2681 23 100         if (removing ? !in_list : in_list) (void)hv_store_ent(keepset, ck, newSViv(1), 0);
    100          
2682             }
2683 8           SvREFCNT_dec((SV*)listed);
2684             } else {
2685             // predicate over the flat colnames list (never a live hash iterator
2686             // across call_sv). Apply the undef policy per column.
2687 13           SSize_t nc = av_len(colnames) + 1;
2688 52 100         for (SSize_t c = 0; c < nc; c++) {
2689 39           SV *restrict ck = *av_fetch(colnames, c, 0);
2690 39           AV *restrict cells = (AV*)SvRV(HeVAL(hv_fetch_ent(cellmap, ck, 0, 0)));
2691             bool pass;
2692 39 100         if (against_av) {
2693             // two columns, pairwise complete: rows defined in BOTH.
2694 12           AV *restrict a1 = newAV(), *restrict a2 = newAV();
2695 72 100         for (SSize_t r = 0; r < nrows; r++) {
2696 60           SV **restrict p1 = av_fetch(cells, r, 0);
2697 60           SV **restrict p2 = av_fetch(against_av, r, 0);
2698 60 50         if (p1 && *p1 && SvOK(*p1) && p2 && *p2 && SvOK(*p2)) {
    50          
    100          
    50          
    50          
    50          
2699 57           av_push(a1, newSVsv(*p1));
2700 57           av_push(a2, newSVsv(*p2));
2701             }
2702             }
2703 12           pass = cf_pred(aTHX_ cv_sv, a1, a2, ck);
2704 12           SvREFCNT_dec((SV*)a1);
2705 12           SvREFCNT_dec((SV*)a2);
2706 27 100         } else if (na_omit) {
2707             // one column, defined cells only.
2708 18           AV *restrict a1 = newAV();
2709 108 100         for (SSize_t r = 0; r < nrows; r++) {
2710 90           SV **restrict p = av_fetch(cells, r, 0);
2711 90 50         if (p && *p && SvOK(*p)) av_push(a1, newSVsv(*p));
    50          
    100          
2712             }
2713 18           pass = cf_pred(aTHX_ cv_sv, a1, NULL, ck);
2714 18           SvREFCNT_dec((SV*)a1);
2715             } else {
2716             // one column, every cell including undef.
2717 9           pass = cf_pred(aTHX_ cv_sv, cells, NULL, ck);
2718             }
2719 39 50         if (removing ? !pass : pass) (void)hv_store_ent(keepset, ck, newSViv(1), 0);
    100          
2720             }
2721             }
2722             // 4. rebuild the data in its original shape with only the kept columns.
2723             SV *restrict out;
2724 21 100         if (kind == 1) {
2725 16           HV *restrict outh = newHV(), *restrict h = (HV*)rv;
2726             HE *restrict e;
2727 16           hv_iterinit(h);
2728 64 100         while ((e = hv_iternext(h))) {
2729 48           SV *restrict ck = hv_iterkeysv(e);
2730 48 100         if (!hv_exists_ent(keepset, ck, 0)) continue;
2731 33           AV *restrict src = (AV*)SvRV(hv_iterval(h, e)), *restrict dst = newAV();
2732 33           SSize_t n = av_len(src) + 1;
2733 33 50         if (n > 0) av_extend(dst, n - 1);
2734 190 100         for (SSize_t i = 0; i < n; i++) {
2735 157           SV **restrict ep = av_fetch(src, i, 0);
2736 157 50         av_push(dst, (ep && *ep) ? newSVsv(*ep) : newSV(0));
    50          
2737             }
2738 33           (void)hv_store_ent(outh, ck, newRV_noinc((SV*)dst), 0);
2739             }
2740 16           out = (SV*)outh;
2741 5 100         } else if (kind == 2) {
2742 2           HV *restrict outh = newHV(), *restrict h = (HV*)rv;
2743             HE *restrict e;
2744 2           hv_iterinit(h);
2745 9 100         while ((e = hv_iternext(h))) {
2746 7           SV *restrict rk = hv_iterkeysv(e);
2747 7           HV *restrict row = (HV*)SvRV(hv_iterval(h, e)), *restrict nr = newHV();
2748             HE *restrict ie;
2749 7           hv_iterinit(row);
2750 23 100         while ((ie = hv_iternext(row))) {
2751 16           SV *restrict ck = hv_iterkeysv(ie);
2752 16 100         if (!hv_exists_ent(keepset, ck, 0)) continue;
2753 5           (void)hv_store_ent(nr, ck, newSVsv(HeVAL(ie)), 0);
2754             }
2755 7           (void)hv_store_ent(outh, rk, newRV_noinc((SV*)nr), 0);
2756             }
2757 2           out = (SV*)outh;
2758             } else {
2759 3           AV *restrict outa = newAV(), *restrict a = (AV*)rv;
2760 3           SSize_t n = av_len(a) + 1;
2761 12 100         for (SSize_t r = 0; r < n; r++) {
2762 9           HV *restrict row = (HV*)SvRV(*av_fetch(a, r, 0)), *restrict nr = newHV();
2763             HE *restrict ie;
2764 9           hv_iterinit(row);
2765 33 100         while ((ie = hv_iternext(row))) {
2766 24           SV *restrict ck = hv_iterkeysv(ie);
2767 24 100         if (!hv_exists_ent(keepset, ck, 0)) continue;
2768 9           (void)hv_store_ent(nr, ck, newSVsv(HeVAL(ie)), 0);
2769             }
2770 9           av_push(outa, newRV_noinc((SV*)nr));
2771             }
2772 3           out = (SV*)outa;
2773             }
2774             // 5. tidy up the scratch tables (the result keeps its own copies).
2775 21           SvREFCNT_dec((SV*)universe);
2776 21           SvREFCNT_dec((SV*)colnames);
2777 21           SvREFCNT_dec((SV*)keepset);
2778 21 100         if (cellmap) SvREFCNT_dec((SV*)cellmap);
2779 21           RETVAL = newRV_noinc(out);
2780             }
2781             OUTPUT:
2782             RETVAL
2783              
2784             SV *hoh2hoa(data, ...)
2785             SV *data
2786             CODE:
2787             {
2788             // 0. parse trailing name => value options (done before any allocation so
2789             // option/usage errors can't leak). undef.val sets the fill for a
2790             // missing key or an undef cell (default: undef). row.names, if given,
2791             // adds a column of that name holding the sorted row labels.
2792 20           SV *restrict fill = NULL; // NULL => fill gaps with undef
2793 20           SV *restrict rn_sv = NULL; // NULL => do not emit a row-names column
2794 20 100         if ((items - 1) & 1) croak("hoh2hoa: trailing options must be name => value pairs");
2795 27 100         for (int oi = 1; oi < items; oi += 2) {
2796             STRLEN ol;
2797 10           const char *restrict oname = SvPV(ST(oi), ol);
2798 10           SV *restrict oval = ST(oi + 1);
2799 10 100         if (ol == 9 && memEQ(oname, "undef.val", 9)) fill = SvOK(oval) ? oval : NULL;
    100          
    100          
2800 5 100         else if (ol == 9 && memEQ(oname, "row.names", 9)) {
    50          
2801 4 50         if (SvOK(oval) && !SvROK(oval)) rn_sv = oval;
    100          
2802 1           else croak("hoh2hoa: row.names must be a column name (string)");
2803             }
2804 1           else croak("hoh2hoa: unknown option '%s'", oname);
2805             }
2806             // 1. the input must be a hash ref (a hash of hashes).
2807 17 100         if (!SvROK(data) || SvTYPE(SvRV(data)) != SVt_PVHV) croak("hoh2hoa: data must be a hash ref (hash of hashes)");
    100          
2808 15           HV *restrict in_hv = (HV*)SvRV(data);
2809             // 2. these cross the section boundaries (gather -> build -> cleanup).
2810 15           HV *restrict out_hv = newHV(); // the result: column name -> array ref
2811 15           AV *restrict rows_av = newAV(); // outer keys, sorted into the row order
2812 15           AV *restrict cols_av = newAV(); // union of inner keys (column names)
2813 15           HV *restrict seen = newHV(); // membership test while taking the union
2814             // 3. collect the outer keys (row labels) and sort for a stable row order.
2815             {
2816             HE *restrict e;
2817 15           hv_iterinit(in_hv);
2818 39 100         while ((e = hv_iternext(in_hv))) {
2819 25           SV *restrict rv = hv_iterval(in_hv, e);
2820 25 50         if (!SvROK(rv) || SvTYPE(SvRV(rv)) != SVt_PVHV) croak("hoh2hoa: every value must be a hash ref (hash of hashes)");
    100          
2821 24           av_push(rows_av, newSVsv(hv_iterkeysv(e)));
2822             }
2823             }
2824 14           SSize_t nrows = av_len(rows_av) + 1;
2825 14 100         if (nrows > 1) qsort(AvARRAY(rows_av), (size_t)nrows, sizeof(SV*), h2h_keycmp);
2826             // 4. discover the union of inner keys. Each new column gets an empty array
2827             // in the result straight away so step 5 can just push into it.
2828             {
2829             HE *restrict e;
2830 14           hv_iterinit(in_hv);
2831 38 100         while ((e = hv_iternext(in_hv))) {
2832 24           HV *restrict row = (HV*)SvRV(hv_iterval(in_hv, e));
2833             HE *restrict ie;
2834 24           hv_iterinit(row);
2835 88 100         while ((ie = hv_iternext(row))) {
2836 40           SV *restrict ck = hv_iterkeysv(ie);
2837 40 100         if (!hv_exists_ent(seen, ck, 0)) {
2838 26           (void)hv_store_ent(seen, ck, &PL_sv_yes, 0);
2839 26           av_push(cols_av, newSVsv(ck));
2840 26           (void)hv_store_ent(out_hv, ck, newRV_noinc((SV*)newAV()), 0);
2841             }
2842             }
2843             }
2844             }
2845 14           SSize_t ncols = av_len(cols_av) + 1;
2846             // 5. walk the rows in sorted order; for every column push the cell (a copy)
2847             // or the fill value, so each column ends up exactly nrows long.
2848 38 100         for (SSize_t r = 0; r < nrows; r++) {
2849 24           SV *restrict rk = *av_fetch(rows_av, r, 0);
2850 24           HE *restrict rhe = hv_fetch_ent(in_hv, rk, 0, 0);
2851 24           HV *restrict row = (HV*)SvRV(HeVAL(rhe));
2852 75 100         for (SSize_t c = 0; c < ncols; c++) {
2853 51           SV *restrict ck = *av_fetch(cols_av, c, 0);
2854 51           HE *restrict che = hv_fetch_ent(row, ck, 0, 0);
2855 51 100         SV *restrict src = che ? HeVAL(che) : NULL;
2856 51 100         SV *restrict cell = (src && SvOK(src)) ? newSVsv(src) : (fill ? newSVsv(fill) : newSV(0));
    100          
    100          
2857 51           HE *restrict colhe = hv_fetch_ent(out_hv, ck, 0, 0);
2858 51           av_push((AV*)SvRV(HeVAL(colhe)), cell);
2859             }
2860             }
2861             // 6. optional row-names column: the sorted labels under the requested name.
2862 14 100         if (rn_sv) {
2863 3 100         if (hv_exists_ent(out_hv, rn_sv, 0)) croak("hoh2hoa: row.names column '%s' collides with an existing column", SvPV_nolen(rn_sv));
2864 2           AV *restrict rn_av = newAV();
2865 4 100         for (SSize_t r = 0; r < nrows; r++) av_push(rn_av, newSVsv(*av_fetch(rows_av, r, 0)));
2866 2           (void)hv_store_ent(out_hv, rn_sv, newRV_noinc((SV*)rn_av), 0);
2867             }
2868             // 7. tidy up the scratch structures (the result keeps its own copies).
2869 13           SvREFCNT_dec((SV*)rows_av);
2870 13           SvREFCNT_dec((SV*)cols_av);
2871 13           SvREFCNT_dec((SV*)seen);
2872 13           RETVAL = newRV_noinc((SV*)out_hv);
2873             }
2874             OUTPUT:
2875             RETVAL
2876              
2877             void filter(df, pred)
2878             SV *df
2879             SV *pred
2880             PPCODE:
2881             {
2882 30 50         if (!df || !SvROK(df))
    100          
2883 1           croak("filter: first argument must be a HASH or ARRAY reference (a data frame)");
2884 29 50         bool is_code = (pred && SvROK(pred) && SvTYPE(SvRV(pred)) == SVt_PVCV);
    100          
    100          
2885 29 100         if (!is_code && (!pred || !SvROK(pred) || SvTYPE(SvRV(pred)) != SVt_PVHV))
    50          
    100          
    50          
2886 1           croak("filter: second argument must be a CODE ref or a predicate built with col()");
2887 28           SV *restrict ref = SvRV(df);
2888             SV *restrict result;
2889 28 100         if (SvTYPE(ref) == SVt_PVAV) {
2890             // ----- Array of Hashes: keep matching row hashrefs (shared, not copied) -----
2891 23           AV *restrict in = (AV*)ref;
2892 23           AV *restrict out = newAV();
2893 23           SSize_t n = av_len(in) + 1, i;
2894 23           filt_ctx ctx; ctx.is_aoh = 1; ctx.data_hv = NULL; ctx.idx = 0;
2895 104 100         for (i = 0; i < n; i++) {
2896 82           SV **restrict rp = av_fetch(in, i, 0);
2897 82 50         if (!rp || !*rp || !SvROK(*rp) || SvTYPE(SvRV(*rp)) != SVt_PVHV) {
    50          
    100          
    50          
2898 1           SvREFCNT_dec((SV*)out);
2899 1           croak("filter: array data frame must hold HASH references; element %ld is not one", (long)i);
2900             }
2901             bool keep;
2902 81 100         if (is_code) keep = filt_call(aTHX_ pred, *rp);
2903 73           else { ctx.row_hv = (HV*)SvRV(*rp); keep = filt_eval(aTHX_ pred, &ctx); }
2904 81 100         if (keep) av_push(out, SvREFCNT_inc_simple_NN(*rp));
2905             }
2906 22           result = newRV_noinc((SV*)out);
2907 5 50         } else if (SvTYPE(ref) == SVt_PVHV) {
2908             // ----- Hash of Arrays: keep matching row indices across every column -----
2909 5           HV *restrict in = (HV*)ref;
2910 5           I32 ncols = hv_iterinit(in);
2911 5 50         if (ncols <= 0) {
2912 0           result = newRV_noinc((SV*)newHV());
2913             } else {
2914 5           char **restrict names = (char**)safemalloc(ncols * sizeof(char*));
2915 5           STRLEN *restrict nlens = (STRLEN*)safemalloc(ncols * sizeof(STRLEN));
2916 5           AV **restrict inav = (AV**)safemalloc(ncols * sizeof(AV*));
2917 5           AV **restrict outav = (AV**)safemalloc(ncols * sizeof(AV*));
2918 5           HV *restrict out = newHV();
2919 5           SSize_t maxrows = 0, i;
2920 5           I32 c = 0, cc;
2921             HE *restrict e;
2922 17 100         while ((e = hv_iternext(in)) && c < ncols) {
    50          
2923             STRLEN klen;
2924 13 50         char *restrict k = HePV(e, klen);
2925 13           SV *restrict v = HeVAL(e);
2926 13 50         if (!v || !SvROK(v) || SvTYPE(SvRV(v)) != SVt_PVAV) {
    100          
    50          
2927 1           safefree(names); safefree(nlens); safefree(inav); safefree(outav);
2928 1           SvREFCNT_dec((SV*)out);
2929 1           croak("filter: hash data frame must hold ARRAY references (a hash of arrays); column '%s' is not one", k);
2930             }
2931 12           AV *restrict a = (AV*)SvRV(v);
2932 12           SSize_t len = av_len(a) + 1;
2933 12 100         if (len > maxrows) maxrows = len;
2934 12           names[c] = k; nlens[c] = klen; inav[c] = a;
2935 12           outav[c] = newAV();
2936 12           hv_store(out, k, klen, newRV_noinc((SV*)outav[c]), 0);
2937 12           c++;
2938             }
2939 4           filt_ctx ctx; ctx.is_aoh = 0; ctx.row_hv = NULL; ctx.data_hv = in;
2940 20 100         for (i = 0; i < maxrows; i++) {
2941             bool keep;
2942 16 100         if (is_code) {
2943 4           HV *restrict rowh = newHV();
2944 16 100         for (cc = 0; cc < ncols; cc++) {
2945 12           SV **restrict vp = av_fetch(inav[cc], i, 0);
2946 12 50         hv_store(rowh, names[cc], nlens[cc], newSVsv((vp && *vp) ? *vp : &PL_sv_undef), 0);
    50          
2947             }
2948 4           SV *restrict rowrv = newRV_noinc((SV*)rowh);
2949 4           keep = filt_call(aTHX_ pred, rowrv);
2950 4           SvREFCNT_dec(rowrv);
2951             } else {
2952 12           ctx.idx = i;
2953 12           keep = filt_eval(aTHX_ pred, &ctx);
2954             }
2955 16 100         if (keep) {
2956 28 100         for (cc = 0; cc < ncols; cc++) {
2957 21           SV **restrict vp = av_fetch(inav[cc], i, 0);
2958 21 50         av_push(outav[cc], newSVsv((vp && *vp) ? *vp : &PL_sv_undef));
    50          
2959             }
2960             }
2961             }
2962 4           safefree(names); safefree(nlens); safefree(inav); safefree(outav);
2963 4           result = newRV_noinc((SV*)out);
2964             }
2965             } else {
2966 0           croak("filter: unsupported data frame; expected an array of hashes (AoH) or a hash of arrays (HoA)");
2967             }
2968 26           ST(0) = sv_2mortal(result);
2969 26           XSRETURN(1);
2970             }
2971              
2972             SV *col2col(data, cmd, cols = &PL_sv_undef, ...)
2973             SV *data
2974             SV *cmd
2975             SV *cols
2976             CODE:
2977             {
2978             // Only these cross the section boundaries (build -> loop -> cleanup);
2979             // everything else is declared at its point of use just below.
2980 51           SV *restrict cv_sv = NULL;
2981 51           size_t ncols = 0, nrows = 0;
2982 51           AV *restrict names_av = newAV();
2983 51           NV **restrict col_val = NULL;
2984 51           char **restrict col_def = NULL;
2985 51           short int na_mode = 0; // 0 = pairwise, 1 = omit, 2 = keep; see section 0
2986 51           bool skip_errors = TRUE; // skip.errors (default true): trap a croaking block, store its message
2987             // 0. options. They may be given either as trailing name => value pairs
2988             // (after the positional cols), or - so no placeholder is needed when
2989             // there is no column restriction - as a single hash ref in cols's
2990             // place, e.g. col2col($data, 'cor', { 'skip.errors' => 1 }).
2991             // `na` controls how undef is handled when one column is paired with
2992             // another:
2993             // 'pairwise' (default) - a row counts for the (a,b) pair only if
2994             // BOTH columns are defined there, so the block gets two equal
2995             // length, aligned columns. This is what paired stats (cor) want.
2996             // 'omit' - each column independently drops its own undef values,
2997             // so the two columns may differ in length. This is what unpaired
2998             // tests (t_test, kruskal_test) want: a gap in one column must not
2999             // throw away a good value in the other.
3000             // 'keep' - every row passes through and undef reaches the block.
3001             // rm.undef / rm.na (bool) remain as aliases: true => 'pairwise' (the
3002             // old default), false => 'keep'.
3003             // skip.errors (bool, default true): a block that croaks for a pair
3004             // does not abort col2col; instead the first line of its error message
3005             // is stored as that cell's value, so the result shows which
3006             // (outer => inner) pair failed and why. Set it false to make a croak
3007             // propagate and abort the whole call instead.
3008 51           SV *restrict cols_eff = cols;
3009 51           bool na_set = FALSE, rm_set = FALSE;
3010             #define C2C_DECODE_OPT(ONAME, OL, OVAL) do { \
3011             if ((OL) == 2 && memEQ((ONAME), "na", 2)) { \
3012             STRLEN vl_; const char *restrict nv_ = SvPV((OVAL), vl_); \
3013             if (vl_ == 8 && memEQ(nv_, "pairwise", 8)) na_mode = 0; \
3014             else if (vl_ == 4 && memEQ(nv_, "omit", 4)) na_mode = 1; \
3015             else if (vl_ == 4 && memEQ(nv_, "keep", 4)) na_mode = 2; \
3016             else croak("col2col: na must be 'pairwise', 'omit' or 'keep'"); \
3017             na_set = TRUE; \
3018             } else if (((OL) == 8 && memEQ((ONAME), "rm.undef", 8)) || ((OL) == 5 && memEQ((ONAME), "rm.na", 5))) { \
3019             na_mode = cBOOL(SvTRUE((OVAL))) ? 0 : 2; rm_set = TRUE; \
3020             } else if ((OL) == 11 && memEQ((ONAME), "skip.errors", 11)) { \
3021             skip_errors = cBOOL(SvTRUE((OVAL))); \
3022             } else croak("col2col: unknown option '%s'", (ONAME)); \
3023             } while (0)
3024 51 100         if (SvROK(cols) && SvTYPE(SvRV(cols)) == SVt_PVHV) {
    100          
3025             // options supplied as a hash ref instead of cols: no column restriction
3026 6           HV *restrict oh = (HV*)SvRV(cols);
3027             HE *restrict he;
3028 6 100         if (items > 3) croak("col2col: an options hash ref must be the last argument");
3029 5           hv_iterinit(oh);
3030 8 100         while ((he = hv_iternext(oh))) {
3031             STRLEN ol;
3032 5 50         const char *restrict oname = HePV(he, ol);
3033 5           SV *restrict oval = HeVAL(he);
3034 5 100         C2C_DECODE_OPT(oname, ol, oval);
    50          
    50          
    0          
    50          
    50          
    0          
    0          
    50          
    0          
    100          
    50          
    0          
    100          
    50          
3035             }
3036 3           cols_eff = &PL_sv_undef;
3037 45 100         } else if (items > 3) {
3038 18 100         if ((items - 3) & 1) croak("col2col: trailing options must be name => value pairs");
3039 33 100         for (int oi = 3; oi < items; oi += 2) {
3040             STRLEN ol;
3041 18           const char *restrict oname = SvPV(ST(oi), ol);
3042 18           SV *restrict oval = ST(oi + 1);
3043 18 100         C2C_DECODE_OPT(oname, ol, oval);
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
3044             }
3045             }
3046 45 100         if (na_set && rm_set) croak("col2col: give na or rm.undef, not both");
    100          
3047             #undef C2C_DECODE_OPT
3048             // 1. resolve the command: a CODE block or a function name. Either way
3049             // we end up with the CV to call as $cv->($col_a, $col_b).
3050 44 100         if (SvROK(cmd) && SvTYPE(SvRV(cmd)) == SVt_PVCV) cv_sv = SvRV(cmd);
    100          
3051 4 100         else if (SvOK(cmd) && !SvROK(cmd)) {
    100          
3052             STRLEN nl;
3053 2           const char *restrict name = SvPV(cmd, nl);
3054 2 50         SV *restrict fq = strstr(name, "::") ? newSVpvn(name, nl) : newSVpvf("Stats::LikeR::%s", name);
3055 2           CV *restrict cv = get_cv(SvPV_nolen(fq), 0);
3056 2           SvREFCNT_dec(fq);
3057 2 100         if (!cv) croak("col2col: unknown function '%s'", name);
3058 1           cv_sv = (SV*)cv;
3059 2           } else croak("col2col: command must be a CODE ref or a function name");
3060             // 2. detect the data shape and build per-column value/defined tables.
3061 41 100         if (!SvROK(data)) croak("col2col: data must be a reference");
3062             {
3063 40           SV *restrict rv = SvRV(data);
3064             short int kind;
3065 40 100         if (SvTYPE(rv) == SVt_PVAV) kind = 1;
3066 38 50         else if (SvTYPE(rv) == SVt_PVHV) {
3067 38           HV *restrict h = (HV*)rv;
3068 38           hv_iterinit(h);
3069 38           HE *restrict e = hv_iternext(h);
3070 38 50         if (!e) croak("col2col: empty data hash");
3071 38           SV *restrict first = hv_iterval(h, e);
3072 38 50         if (SvROK(first) && SvTYPE(SvRV(first)) == SVt_PVAV) kind = 0;
    100          
3073 1 50         else if (SvROK(first) && SvTYPE(SvRV(first)) == SVt_PVHV) kind = 2;
    50          
3074 0           else croak("col2col: hash values must be array refs (HoA) or hash refs (HoH)");
3075             }
3076 0           else croak("col2col: data must be an array ref or hash ref");
3077 40 100         if (kind == 0) {
3078             // hash of arrays: names = keys, rows = longest column.
3079 37           HV *restrict h = (HV*)rv;
3080 37           AV **restrict src = NULL;
3081             HE *restrict e;
3082 37           hv_iterinit(h);
3083 129 100         while ((e = hv_iternext(h))) {
3084 92           SV *restrict val = hv_iterval(h, e);
3085 92 50         if (!SvROK(val) || SvTYPE(SvRV(val)) != SVt_PVAV) continue;
    50          
3086 92           av_push(names_av, newSVsv(hv_iterkeysv(e)));
3087 92           AV *restrict a = (AV*)SvRV(val);
3088 92           size_t len = (size_t)(av_len(a) + 1);
3089 92 100         if (len > nrows) nrows = len;
3090 92 50         Renew(src, av_len(names_av) + 1, AV*);
3091 92           src[av_len(names_av)] = a;
3092             }
3093 37           ncols = (size_t)(av_len(names_av) + 1);
3094 37 50         Newxz(col_val, ncols ? ncols : 1, NV*);
    50          
    50          
3095 37 50         Newxz(col_def, ncols ? ncols : 1, char*);
    50          
    50          
3096 129 100         for (size_t cc = 0; cc < ncols; cc++) {
3097 92 50         Newxz(col_val[cc], nrows ? nrows : 1, NV);
    50          
    50          
3098 92 50         Newxz(col_def[cc], nrows ? nrows : 1, char);
3099 92           AV *restrict a = src[cc];
3100 518 100         for (size_t r = 0; r < nrows; r++) {
3101             NV v;
3102 426 100         if (c2c_num(aTHX_ av_fetch(a, (SSize_t)r, 0), &v)) { col_val[cc][r] = v; col_def[cc][r] = 1; }
3103             }
3104             }
3105 37           Safefree(src);
3106             } else {
3107             // row-major (array of hashes / hash of hashes): union of keys.
3108 3           HV **restrict row_hv = NULL;
3109 3 100         if (kind == 1) {
3110 2           AV *restrict a = (AV*)rv;
3111 2           nrows = (size_t)(av_len(a) + 1);
3112 2 50         Newxz(row_hv, nrows ? nrows : 1, HV*);
    50          
    50          
3113 10 100         for (size_t r = 0; r < nrows; r++) {
3114 8           SV **restrict ep = av_fetch(a, (SSize_t)r, 0);
3115 8 50         if (ep && *ep && SvROK(*ep) && SvTYPE(SvRV(*ep)) == SVt_PVHV) row_hv[r] = (HV*)SvRV(*ep);
    50          
    100          
    50          
3116             }
3117             } else {
3118 1           HV *restrict h = (HV*)rv;
3119             HE *restrict e;
3120 1           size_t r = 0;
3121 1 50         nrows = (size_t)HvKEYS(h);
3122 1 50         Newxz(row_hv, nrows ? nrows : 1, HV*);
    50          
    50          
3123 1           hv_iterinit(h);
3124 6 100         while ((e = hv_iternext(h)) && r < nrows) {
    50          
3125 5           SV *restrict val = hv_iterval(h, e);
3126 5 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) row_hv[r] = (HV*)SvRV(val);
    50          
3127 5           r++;
3128             }
3129             }
3130             {
3131 3           HV *restrict seen = newHV();
3132 16 100         for (size_t r = 0; r < nrows; r++) {
3133 13 100         if (!row_hv[r]) continue;
3134             HE *restrict e;
3135 10           hv_iterinit(row_hv[r]);
3136 40 100         while ((e = hv_iternext(row_hv[r]))) {
3137             STRLEN kl;
3138 30 50         char *restrict k = HePV(e, kl);
3139 30 100         if (!hv_exists(seen, k, kl)) { (void)hv_store(seen, k, kl, &PL_sv_yes, 0); av_push(names_av, newSVsv(hv_iterkeysv(e))); }
3140             }
3141             }
3142 3           SvREFCNT_dec((SV*)seen);
3143             }
3144 3           ncols = (size_t)(av_len(names_av) + 1);
3145 3 100         Newxz(col_val, ncols ? ncols : 1, NV*);
    50          
    100          
3146 3 100         Newxz(col_def, ncols ? ncols : 1, char*);
    50          
    100          
3147 9 100         for (size_t cc = 0; cc < ncols; cc++) {
3148             STRLEN kl;
3149 6           char *restrict k = SvPV(*av_fetch(names_av, (SSize_t)cc, 0), kl);
3150 6 50         Newxz(col_val[cc], nrows ? nrows : 1, NV);
    50          
    50          
3151 6 50         Newxz(col_def[cc], nrows ? nrows : 1, char);
3152 36 100         for (size_t r = 0; r < nrows; r++) {
3153             NV v;
3154 30 50         if (!row_hv[r]) continue;
3155 30 50         if (c2c_num(aTHX_ hv_fetch(row_hv[r], k, kl, 0), &v)) { col_val[cc][r] = v; col_def[cc][r] = 1; }
3156             }
3157             }
3158 3           Safefree(row_hv);
3159             }
3160             }
3161 40 100         if (ncols == 0) croak("col2col: no usable columns found");
3162             // 3. flatten the column names for fast hv_store keys in the loop.
3163             SV **restrict col_names;
3164             STRLEN *restrict name_len;
3165 39 50         Newx(col_names, ncols, SV*);
3166 39 50         Newx(name_len, ncols, STRLEN);
3167 137 100         for (size_t cc = 0; cc < ncols; cc++) {
3168 98           col_names[cc] = *av_fetch(names_av, (SSize_t)cc, 0);
3169 98           (void)SvPV(col_names[cc], name_len[cc]);
3170             }
3171             // 3b. decide which columns may be col_a (the outer/"from" side). With no
3172             // restriction every column qualifies; a name or list narrows it.
3173             char *restrict is_outer;
3174 39           Newxz(is_outer, ncols, char);
3175 39 100         if (!SvOK(cols_eff)) {
3176 118 100         for (size_t cc = 0; cc < ncols; cc++) is_outer[cc] = 1;
3177             }
3178 6 100         else if (SvROK(cols_eff) && SvTYPE(SvRV(cols_eff)) == SVt_PVAV) {
    50          
3179 2           AV *restrict want = (AV*)SvRV(cols_eff);
3180 2           SSize_t n = av_len(want) + 1;
3181 5 100         for (SSize_t i = 0; i < n; i++) {
3182 4           SV **restrict ep = av_fetch(want, i, 0);
3183             STRLEN wl;
3184             const char *restrict wname;
3185 4 50         if (!ep || !*ep || !SvOK(*ep)) croak("col2col: column list contains an undefined entry");
    50          
    50          
3186 4           wname = SvPV(*ep, wl);
3187 4 100         if (!c2c_mark(col_names, name_len, ncols, wname, wl, is_outer)) croak("col2col: column '%s' not found in data", wname);
3188             }
3189 3 50         } else if (!SvROK(cols_eff)) {
3190             STRLEN wl;
3191 3           const char *restrict wname = SvPV(cols_eff, wl);
3192 3 100         if (!c2c_mark(col_names, name_len, ncols, wname, wl, is_outer)) croak("col2col: column '%s' not found in data", wname);
3193 0           } else croak("col2col: cols must be a column name or an array ref of names");
3194             // 4. each selected column vs every other column. The two columns reach
3195             // the block as @_ = ($col_a, $col_b); how undef is handled depends on
3196             // na (section 0): 'pairwise' drops a row missing in either side (equal
3197             // aligned lengths, for cor); 'omit' drops each column's own undef
3198             // independently (lengths may differ, for t_test / kruskal_test);
3199             // 'keep' passes every row through with undef in the gaps.
3200 37           HV *restrict out_hv = newHV();
3201 126 100         for (size_t a = 0; a < ncols; a++) {
3202             HV *restrict inner;
3203 90 100         if (!is_outer[a]) continue;
3204 86           inner = newHV();
3205 306 100         for (size_t b = 0; b < ncols; b++) {
3206             AV *restrict ca, *restrict cb;
3207             SV *restrict rv1, *restrict rv2, *restrict res;
3208 221 100         if (a == b) continue;
3209 135           ca = newAV();
3210 135           cb = newAV();
3211 135 100         if (na_mode == 0) { // pairwise complete: keep rows defined in both
3212 644 100         for (size_t r = 0; r < nrows; r++)
3213 528 100         if (col_def[a][r] && col_def[b][r]) { av_push(ca, newSVnv(col_val[a][r])); av_push(cb, newSVnv(col_val[b][r])); }
    100          
3214 19 100         } else if (na_mode == 1) { // omit: each column drops its own undef (lengths may differ)
3215 44 100         for (size_t r = 0; r < nrows; r++) if (col_def[a][r]) av_push(ca, newSVnv(col_val[a][r]));
    100          
3216 44 100         for (size_t r = 0; r < nrows; r++) if (col_def[b][r]) av_push(cb, newSVnv(col_val[b][r]));
    100          
3217             } else { // keep: every row, undef passed through
3218 66 100         for (size_t r = 0; r < nrows; r++) {
3219 55 100         av_push(ca, col_def[a][r] ? newSVnv(col_val[a][r]) : newSV(0));
3220 55 100         av_push(cb, col_def[b][r] ? newSVnv(col_val[b][r]) : newSV(0));
3221             }
3222             }
3223 135           rv1 = newRV_noinc((SV*)ca);
3224 135           rv2 = newRV_noinc((SV*)cb);
3225 135 100         if (av_len(ca) < 0 || av_len(cb) < 0) {
    100          
3226 2           res = newSV(0); // a column had no usable values for this pair
3227 133 100         } else if (!skip_errors) {
3228 4           res = c2c_call(aTHX_ cv_sv, rv1, rv2); // a croak here propagates
3229             } else {
3230             // skip.errors: run the block under eval; on a croak keep the
3231             // first line of its message as this cell so the caller sees
3232             // which pair failed and why instead of the whole call dying.
3233 129           dSP;
3234             int n;
3235 129           ENTER; SAVETMPS;
3236 129 50         PUSHMARK(SP);
3237 129 50         XPUSHs(rv1); XPUSHs(rv2);
    50          
3238 129           PUTBACK;
3239 129           n = call_sv(cv_sv, G_SCALAR | G_EVAL);
3240 129           SPAGAIN;
3241 129 50         if (SvTRUE(ERRSV)) {
    100          
3242             STRLEN el;
3243 8 50         const char *restrict ep = SvPV(ERRSV, el);
3244 8           STRLEN ll = 0; // length of the first line only
3245 132 50         while (ll < el && ep[ll] != '\n' && ep[ll] != '\r') ll++;
    100          
    50          
3246 8           res = newSVpvn(ep, ll);
3247 8 50         if (n > 0) (void)POPs; // discard the undef G_SCALAR leaves
3248             } else {
3249 121 50         res = (n > 0) ? newSVsv(POPs) : newSV(0);
3250             }
3251 129           PUTBACK;
3252 129 50         FREETMPS; LEAVE;
3253             }
3254 134           (void)hv_store(inner, SvPVX(col_names[b]), (I32)name_len[b], res, 0);
3255 134           SvREFCNT_dec(rv1);
3256 134           SvREFCNT_dec(rv2);
3257             }
3258 85           (void)hv_store(out_hv, SvPVX(col_names[a]), (I32)name_len[a], newRV_noinc((SV*)inner), 0);
3259             }
3260             // 5. tidy up.
3261 125 100         for (size_t cc = 0; cc < ncols; cc++) { Safefree(col_val[cc]); Safefree(col_def[cc]); }
3262 36           Safefree(col_val); Safefree(col_def); Safefree(col_names);
3263 36           Safefree(name_len); Safefree(is_outer); SvREFCNT_dec((SV*)names_av);
3264 36           RETVAL = newRV_noinc((SV*)out_hv);
3265             }
3266             OUTPUT:
3267             RETVAL
3268              
3269             SV *
3270             oneway_test(data_ref, ...)
3271             SV *data_ref
3272             PREINIT:
3273 20           HV *restrict in_hv = NULL;
3274 20           AV *restrict in_av = NULL;
3275             HE *restrict he;
3276 20           bool var_equal = 0;
3277 20           const char *restrict formula_str = NULL;
3278 20           const char *restrict factor_name = "Group";
3279 20           char *lhs = NULL, *rhs = NULL;
3280 20           NV *restrict flat = NULL;
3281 20           size_t *restrict sizes = NULL;
3282 20           char **gnames = NULL;
3283 20           NV *restrict gmeans = NULL;
3284 20           size_t k = 0;
3285 20           IV total_n = 0;
3286             OneWayResult res;
3287             HV *restrict ret_hv;
3288             char errbuf[512];
3289             CODE:
3290             {
3291             /* ---- parse named arguments ---- */
3292 24 100         for (I32 ai = 1; ai + 1 < items; ai += 2) {
3293 4           const char *restrict key = SvPV_nolen(ST(ai));
3294 4           SV *restrict val = ST(ai + 1);
3295 4 50         if (strEQ(key, "var_equal") || strEQ(key, "var.equal"))
    50          
3296 0           var_equal = SvTRUE(val) ? 1 : 0;
3297 4 50         else if (strEQ(key, "formula"))
3298 4           formula_str = SvPV_nolen(val);
3299             }
3300              
3301             /* ---- validate data_ref: must be an ARRAY or HASH reference ---- */
3302 20 100         if (!SvROK(data_ref))
3303 1           croak("oneway_test: first argument must be a hash or array reference");
3304 19           SV *restrict rv = SvRV(data_ref);
3305 19 100         if (SvTYPE(rv) == SVt_PVHV) in_hv = (HV *)rv;
3306 7 50         else if (SvTYPE(rv) == SVt_PVAV) in_av = (AV *)rv;
3307 0           else croak("oneway_test: first argument must be a hash or array reference");
3308              
3309 19 100         if (in_av) {
3310             /* ---- MODE 3: array of arrays (AoA) ---- */
3311 7 50         if (formula_str != NULL)
3312 0           croak("oneway_test: formula mode is not supported with an array of arrays");
3313              
3314 7           k = (size_t)(av_len(in_av) + 1); /* +1 inside the signed math */
3315 7 100         if (k < 2)
3316 2           croak("oneway_test: need at least 2 groups, got %zu", k);
3317              
3318 5 50         Newx(sizes, k, size_t);
3319 5 50         Newxz(gnames, k, char *); /* zeroed: safe to free on error */
3320              
3321             /* first pass: validate, sizes, total_n, synthesised names */
3322 9 100         for (size_t g = 0; g < k; g++) {
3323 7           SV **restrict val = av_fetch(in_av, (I32)g, 0);
3324 7 50         if (!val || !*val || !SvROK(*val) || SvTYPE(SvRV(*val)) != SVt_PVAV) {
    50          
    50          
    50          
3325 0           snprintf(errbuf, sizeof errbuf, "index %zu is not an array reference", g);
3326 3           goto fail;
3327             }
3328 7           IV len = av_len((AV *)SvRV(*val)) + 1;
3329 7 100         if (len < 2) {
3330 3           snprintf(errbuf, sizeof errbuf, "index %zu has fewer than 2 observations", g);
3331 3           goto fail;
3332             }
3333 4           sizes[g] = (size_t)len;
3334 4           total_n += len;
3335             char buf[64];
3336 4           snprintf(buf, sizeof buf, "Index %zu", g);
3337 4           gnames[g] = savepv(buf); /* perl-managed copy */
3338             }
3339              
3340             /* second pass: fill flat, validating each cell */
3341 2 50         Newx(flat, (size_t)total_n, NV);
3342 2           size_t offset = 0;
3343 4 100         for (size_t g = 0; g < k; g++) {
3344 3           AV *restrict av = (AV *)SvRV(*av_fetch(in_av, (I32)g, 0));
3345 3           IV len = av_len(av) + 1;
3346 18 100         for (IV i = 0; i < len; i++) {
3347 16           SV **restrict svp = av_fetch(av, i, 0);
3348 16 50         if (!svp || !*svp || !SvOK(*svp) || !looks_like_number(*svp)) {
    50          
    100          
    50          
3349 1           snprintf(errbuf, sizeof errbuf,
3350             "index %zu, observation %ld is undefined or non-numeric",
3351             g, (long)i);
3352 1           goto fail;
3353             }
3354 15           flat[offset++] = SvNV(*svp);
3355             }
3356             }
3357             }
3358 12 100         else if (formula_str != NULL) {
3359             /* ---- MODE 2: formula "response ~ factor" ---- */
3360 4 100         if (!parse_formula(formula_str, &lhs, &rhs))
3361 1           croak("oneway_test: cannot parse formula '%s' — expected 'response ~ factor'",
3362             formula_str);
3363 3           factor_name = rhs; /* freed after output */
3364              
3365 3           SV **restrict resp_svp = hv_fetch(in_hv, lhs, (I32)strlen(lhs), 0);
3366 3 100         if (!resp_svp || !*resp_svp || !SvROK(*resp_svp)
    50          
    50          
3367 2 50         || SvTYPE(SvRV(*resp_svp)) != SVt_PVAV) {
3368 1           snprintf(errbuf, sizeof errbuf,
3369             "formula LHS '%s' not found as an array ref in the hash", lhs);
3370 1           goto fail; /* was leaking lhs/rhs */
3371             }
3372 2           SV **restrict fact_svp = hv_fetch(in_hv, rhs, (I32)strlen(rhs), 0);
3373 2 50         if (!fact_svp || !*fact_svp || !SvROK(*fact_svp)
    50          
    50          
3374 2 50         || SvTYPE(SvRV(*fact_svp)) != SVt_PVAV) {
3375 0           snprintf(errbuf, sizeof errbuf,
3376             "formula RHS '%s' not found as an array ref in the hash", rhs);
3377 0           goto fail; /* was leaking lhs/rhs */
3378             }
3379              
3380 2           AV *restrict resp_av = (AV *)SvRV(*resp_svp);
3381 2           AV *restrict label_av = (AV *)SvRV(*fact_svp);
3382 2           IV n = av_len(resp_av) + 1;
3383 2 50         Newx(flat, (size_t)(n > 0 ? n : 0), NV);
3384 2 50         Newx(sizes, (size_t)(n > 0 ? n : 0), size_t); /* k <= n upper bound */
3385              
3386 2 100         if (!build_groups_from_formula(aTHX_ resp_av, label_av,
3387             flat, sizes, &k, &gnames, errbuf, sizeof errbuf))
3388 1           goto fail; /* errbuf already set; fail frees all */
3389              
3390 3 100         for (size_t g = 0; g < k; g++) total_n += (IV)sizes[g];
3391             }
3392             else {
3393             /* ---- MODE 1: hash of groups { label => \@obs, ... } ---- */
3394 8 50         k = (size_t)HvUSEDKEYS(in_hv); /* robust count, not iterinit's */
3395 8 50         if (k < 2)
3396 0           croak("oneway_test: need at least 2 groups, got %zu", k);
3397              
3398 8 50         Newx(sizes, k, size_t);
3399 8 50         Newxz(gnames, k, char *);
3400              
3401             /* first pass: validate, sizes, total_n, key strings */
3402 8           hv_iterinit(in_hv);
3403 20 100         for (size_t g = 0; (he = hv_iternext(in_hv)) != NULL; g++) {
3404 14           SV *restrict val = HeVAL(he);
3405 14 100         if (!SvROK(val) || SvTYPE(SvRV(val)) != SVt_PVAV) {
    50          
3406 3           snprintf(errbuf, sizeof errbuf,
3407 1 50         "value for group '%s' is not an array ref", HePV(he, PL_na));
3408 2           goto fail;
3409             }
3410 13           IV len = av_len((AV *)SvRV(val)) + 1;
3411 13 100         if (len < 2) {
3412 3           snprintf(errbuf, sizeof errbuf,
3413 1 50         "group '%s' has fewer than 2 observations", HePV(he, PL_na));
3414 1           goto fail;
3415             }
3416 12           sizes[g] = (size_t)len;
3417 12           total_n += len;
3418             STRLEN klen;
3419 12 50         const char *kstr = HePV(he, klen);
3420 12           gnames[g] = savepvn(kstr, klen); /* keeps embedded NULs */
3421             }
3422              
3423             /* second pass: fill flat in the same iteration order, validating */
3424 6 50         Newx(flat, (size_t)total_n, NV);
3425 6           size_t offset = 0;
3426 6           hv_iterinit(in_hv);
3427 14 100         while ((he = hv_iternext(in_hv)) != NULL) {
3428 10           AV *restrict av = (AV *)SvRV(HeVAL(he));
3429 10           IV len = av_len(av) + 1;
3430 60 100         for (IV i = 0; i < len; i++) {
3431 52           SV **restrict svp = av_fetch(av, i, 0);
3432 52 50         if (!svp || !*svp || !SvOK(*svp) || !looks_like_number(*svp)) {
    50          
    100          
    100          
3433 6           snprintf(errbuf, sizeof errbuf,
3434             "group '%s', observation %ld is undefined or non-numeric",
3435 2 50         HePV(he, PL_na), (long)i);
3436 2           goto fail;
3437             }
3438 50           flat[offset++] = SvNV(*svp);
3439             }
3440             }
3441             }
3442              
3443             /* ---- per-group means from flat (computed before the arithmetic) ---- */
3444 6 50         Newx(gmeans, k, NV);
3445             {
3446 6           size_t offset = 0;
3447 18 100         for (size_t g = 0; g < k; g++) {
3448 12           NV sum = 0.0;
3449 78 100         for (size_t i = 0; i < sizes[g]; i++) sum += flat[offset + i];
3450 12           gmeans[g] = sum / (NV)sizes[g];
3451 12           offset += sizes[g];
3452             }
3453             }
3454              
3455 6           res = c_oneway_test(flat, sizes, k, var_equal);
3456 6           Safefree(flat); flat = NULL;
3457              
3458             /* ---- build the return hash ---- */
3459 6           ret_hv = (HV *)sv_2mortal((SV *)newHV());
3460             {
3461 6           HV *restrict g_hv = newHV();
3462 6           hv_stores(g_hv, "Df", newSVnv(res.num_df));
3463 6           hv_stores(g_hv, "Sum Sq", newSVnv(res.ss_between));
3464 6           hv_stores(g_hv, "Mean Sq", newSVnv(res.ms_between));
3465 6           hv_stores(g_hv, "F value", newSVnv(res.statistic));
3466 6           hv_stores(g_hv, "Pr(>F)", newSVnv(res.p_value));
3467 6           hv_store(ret_hv, factor_name, (I32)strlen(factor_name),
3468             newRV_noinc((SV *)g_hv), 0);
3469             }
3470             {
3471 6           HV *restrict r_hv = newHV();
3472 6           hv_stores(r_hv, "Df", newSVnv(res.denom_df));
3473 6           hv_stores(r_hv, "Sum Sq", newSVnv(res.ss_within));
3474 6           hv_stores(r_hv, "Mean Sq", newSVnv(res.ms_within));
3475 6           hv_stores(ret_hv, "Residuals", newRV_noinc((SV *)r_hv));
3476             }
3477             {
3478 6           HV *restrict gs_hv = newHV();
3479 6           HV *restrict mean_hv = newHV();
3480 6           HV *restrict size_hv = newHV();
3481 18 100         for (size_t g = 0; g < k; g++) {
3482 12           const char *restrict gn = gnames[g];
3483 12           I32 gnl = (I32)strlen(gn);
3484 12           hv_store(mean_hv, gn, gnl, newSVnv(gmeans[g]), 0);
3485 12           hv_store(size_hv, gn, gnl, newSViv((IV)sizes[g]), 0);
3486             }
3487 6           hv_stores(gs_hv, "mean", newRV_noinc((SV *)mean_hv));
3488 6           hv_stores(gs_hv, "size", newRV_noinc((SV *)size_hv));
3489 6           hv_stores(ret_hv, "group_stats", newRV_noinc((SV *)gs_hv));
3490             }
3491              
3492             /* ---- normal cleanup ---- */
3493 6           Safefree(gmeans);
3494 6           Safefree(sizes);
3495 18 100         for (size_t g = 0; g < k; g++) Safefree(gnames[g]);
3496 6           Safefree(gnames);
3497 6 100         if (lhs) Safefree(lhs);
3498 6 100         if (rhs) Safefree(rhs);
3499              
3500 6           RETVAL = newRV_inc((SV *)ret_hv);
3501             }
3502              
3503             if (0) {
3504 10           fail:
3505             /* single cleanup point for every error after an allocation */
3506 10 100         if (flat) Safefree(flat);
3507 10 100         if (sizes) Safefree(sizes);
3508 10 100         if (gnames) {
3509 24 100         for (size_t g = 0; g < k; g++) if (gnames[g]) Safefree(gnames[g]);
    100          
3510 8           Safefree(gnames);
3511             }
3512 10 50         if (gmeans) Safefree(gmeans);
3513 10 100         if (lhs) Safefree(lhs);
3514 10 100         if (rhs) Safefree(rhs);
3515 10           croak("oneway_test: %s", errbuf);
3516             }
3517             OUTPUT:
3518             RETVAL
3519              
3520             SV* ks_test(...)
3521             CODE:
3522             {
3523             /* NOTE: these may legitimately alias (e.g. ks_test(\@a, \@a)), so no
3524             * `restrict` here — only the private C buffers below get it. */
3525 43           SV *restrict x_sv = NULL, *restrict y_sv = NULL;
3526 43           short int exact = -1;
3527 43           const char *restrict alternative = "two.sided";
3528 43           int arg_idx = 0;
3529              
3530             /* Leading positional 'x' (array ref). */
3531 43 100         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
3532 37           x_sv = ST(arg_idx);
3533 37           arg_idx++;
3534             }
3535              
3536             /* Optional positional 'y':
3537             * - an ARRAY ref -> 2-sample (keys are never array refs, so safe)
3538             * - a STRING -> 1-sample CDF name, BUT only if consuming it leaves
3539             * an even number of trailing args. Otherwise the
3540             * "string" is really a named-argument key (e.g.
3541             * "exact", "alternative") and must not be eaten here.
3542             * (Fix #1) */
3543 43 100         if (arg_idx < items) {
3544 41 100         if (SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    50          
3545 26           y_sv = ST(arg_idx);
3546 26           arg_idx++;
3547 15 50         } else if (SvPOK(ST(arg_idx)) && (((items - arg_idx) % 2) == 1)) {
    100          
3548 8           y_sv = ST(arg_idx); /* positional 1-sample CDF, e.g. "pnorm" */
3549 8           arg_idx++;
3550             }
3551             }
3552              
3553             /* Named arguments (key => value pairs). */
3554 61 100         for (; arg_idx < items; arg_idx += 2) {
3555 21           const char *restrict key = SvPV_nolen(ST(arg_idx));
3556             SV *restrict val;
3557 21 100         if (arg_idx + 1 >= items) /* Fix #2: no value -> would read off stack */
3558 2           croak("ks_test: argument '%s' is missing a value", key);
3559 19           val = ST(arg_idx + 1);
3560 19 100         if (strEQ(key, "x")) x_sv = val;
3561 17 100         else if (strEQ(key, "y")) y_sv = val;
3562 12 100         else if (strEQ(key, "exact")) {
3563 5 50         if (!SvOK(val)) exact = -1;
3564 5           else exact = SvTRUE(val) ? 1 : 0;
3565             }
3566 7 100         else if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
3567 1           else croak("ks_test: unknown argument '%s'", key);
3568             }
3569              
3570 40 100         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV) {
    50          
    50          
3571 4           croak("ks_test: 'x' is a required argument and must be an ARRAY reference");
3572             }
3573              
3574 36           bool is_two_sided = strEQ(alternative, "two.sided") ? 1 : 0;
3575 36           bool is_greater = strEQ(alternative, "greater") ? 1 : 0;
3576 36           bool is_less = strEQ(alternative, "less") ? 1 : 0;
3577              
3578 36 100         if (!is_two_sided && !is_greater && !is_less) {
    100          
    100          
3579 2           croak("ks_test: alternative must be 'two.sided', 'less', or 'greater'");
3580             }
3581              
3582 34           AV *x_av = (AV *)SvRV(x_sv);
3583 34           size_t nx = (size_t)(av_len(x_av) + 1);
3584 34 100         if (nx == 0) croak("Not enough 'x' observations");
3585              
3586             /* Extract 'x' to a C array (numeric elements only). */
3587 33           NV *restrict x_data = (NV *)safemalloc(nx * sizeof(NV));
3588 33           size_t valid_nx = 0;
3589 497 100         for (size_t i = 0; i < nx; i++) {
3590 464           SV **el = av_fetch(x_av, i, 0);
3591 464 50         if (el && *el && (SvNIOK(*el) || (SvOK(*el) && looks_like_number(*el)))) {
    50          
    100          
    100          
    100          
3592 456           x_data[valid_nx++] = SvNV(*el); /* SvNIOK shortcut avoids string parse */
3593             }
3594             }
3595             /* Fix #4: guard before any path can divide by valid_nx. */
3596 33 100         if (valid_nx < 1) {
3597 2           Safefree(x_data);
3598 2           croak("Not enough non-missing 'x' observations");
3599             }
3600              
3601 31           NV statistic = 0.0, p_value = 0.0;
3602 31           const char *method_desc = "";
3603              
3604             /* ----------------------------- TWO SAMPLE ----------------------------- */
3605 52 100         if (y_sv && SvROK(y_sv) && SvTYPE(SvRV(y_sv)) == SVt_PVAV) {
    100          
    50          
3606 23           AV *y_av = (AV *)SvRV(y_sv);
3607 23           size_t ny = (size_t)(av_len(y_av) + 1);
3608 23 50         NV *restrict y_data = (NV *)safemalloc((ny ? ny : 1) * sizeof(NV));
3609 23           size_t valid_ny = 0;
3610 344 100         for (size_t i = 0; i < ny; i++) {
3611 321           SV **el = av_fetch(y_av, i, 0);
3612 321 50         if (el && *el && (SvNIOK(*el) || (SvOK(*el) && looks_like_number(*el)))) {
    50          
    100          
    50          
    100          
3613 315           y_data[valid_ny++] = SvNV(*el);
3614             }
3615             }
3616 23 100         if (valid_ny < 1) {
3617 2           Safefree(x_data); Safefree(y_data);
3618 2           croak("Not enough non-missing observations for KS test");
3619             }
3620              
3621             NV d, d_plus, d_minus;
3622 21           calc_2sample_stats(x_data, valid_nx, y_data, valid_ny, &d, &d_plus, &d_minus);
3623 21 100         if (is_greater) statistic = d_plus;
3624 19 100         else if (is_less) statistic = d_minus;
3625 17           else statistic = d;
3626              
3627             /* Decide exact vs asymptotic. Use a double product so the threshold
3628             * comparison itself can't overflow size_t. */
3629 21           double mn = (double)valid_nx * (double)valid_ny;
3630             bool use_exact;
3631 21 100         if (exact == 1) use_exact = TRUE;
3632 19 50         else if (exact == 0) use_exact = FALSE;
3633 19           else use_exact = (mn < 10000.0);
3634              
3635             /* Fix #6: cap the cost of a *forced* exact run. */
3636 21 50         if (use_exact && mn > KS_EXACT_MAX_PRODUCT) {
    50          
3637 0           warn("ks_test: sample sizes too large for an exact p-value; using asymptotic");
3638 0           use_exact = FALSE;
3639             }
3640              
3641             /* Tie detection is only needed for the exact path. Both arrays are
3642             * already sorted by calc_2sample_stats(), so detect ties with an O(N)
3643             * merge instead of concatenate + re-sort. (Speed/RAM improvement.) */
3644 21 50         if (use_exact) {
3645 21           bool has_ties = FALSE;
3646 21           size_t a = 0, b = 0;
3647 21           NV prev = 0; bool have_prev = FALSE;
3648 696 100         while (a < valid_nx || b < valid_ny) {
    100          
3649 623 100         NV v = (b >= valid_ny || (a < valid_nx && x_data[a] <= y_data[b]))
    100          
3650 1300 100         ? x_data[a++] : y_data[b++];
3651 677 100         if (have_prev && v == prev) { has_ties = TRUE; break; }
    100          
3652 675           prev = v; have_prev = TRUE;
3653             }
3654 21 100         if (has_ties) {
3655 2           warn("ks_test: cannot compute exact p-value with ties; falling back to asymptotic");
3656 2           use_exact = FALSE;
3657             }
3658             }
3659              
3660 21 100         if (use_exact) {
3661 19           method_desc = "Two-sample Kolmogorov-Smirnov exact test";
3662 19           NV q = (0.5 + floor(statistic * valid_nx * valid_ny - 1e-7))
3663 19           / ((NV)valid_nx * (NV)valid_ny);
3664             /* One-sided 'less' uses the D+ routine directly; correct when
3665             * valid_nx == valid_ny and a documented approximation otherwise. */
3666 19           p_value = psmirnov_exact_uniq_upper(q, valid_nx, valid_ny, is_two_sided);
3667             } else {
3668 2           method_desc = "Two-sample Kolmogorov-Smirnov test (asymptotic)";
3669             /* Overflow-safe scaling: cast each operand to NV before multiplying. */
3670 2           NV z = statistic * sqrt(((NV)valid_nx * (NV)valid_ny)
3671 2           / ((NV)valid_nx + (NV)valid_ny));
3672 2 50         if (is_two_sided) p_value = K2l(z, 0, 1e-9);
3673 0           else p_value = exp(-2.0 * z * z);
3674             }
3675 21           Safefree(y_data);
3676             // 1 SAMPLE
3677 12 100         } else if (y_sv && SvPOK(y_sv)) {
    50          
3678 6           const char *restrict dist = SvPV_nolen(y_sv);
3679 6 100         if (strEQ(dist, "pnorm")) {
3680 4           qsort(x_data, valid_nx, sizeof(NV), compare_NVs);
3681 4           NV max_d = 0.0, max_d_plus = 0.0, max_d_minus = 0.0;
3682 63 100         for (size_t i = 0; i < valid_nx; i++) {
3683 59           NV cdf_obs_low = (NV)i / valid_nx;
3684 59           NV cdf_obs_high = (NV)(i + 1) / valid_nx;
3685 59           NV cdf_theor = approx_pnorm(x_data[i]);
3686 59           NV diff1 = cdf_obs_low - cdf_theor;
3687 59           NV diff2 = cdf_obs_high - cdf_theor;
3688 59 50         if (diff1 > max_d_plus) max_d_plus = diff1;
3689 59 100         if (diff2 > max_d_plus) max_d_plus = diff2;
3690 59 100         if (-diff1 > max_d_minus) max_d_minus = -diff1;
3691 59 50         if (-diff2 > max_d_minus) max_d_minus = -diff2;
3692 59 100         if (fabs(diff1) > max_d) max_d = fabs(diff1);
3693 59 100         if (fabs(diff2) > max_d) max_d = fabs(diff2);
3694             }
3695 4 50         if (is_greater) statistic = max_d_plus;
3696 4 50         else if (is_less) statistic = max_d_minus;
3697 4           else statistic = max_d;
3698              
3699 4 100         bool use_exact = (exact == -1) ? (valid_nx < 100) : (exact == 1);
3700 4 100         if (use_exact) {
3701 3           method_desc = "One-sample Kolmogorov-Smirnov exact test";
3702 3 50         if (is_two_sided) {
3703 3           p_value = 1.0 - K2x(valid_nx, statistic);
3704             } else {
3705 0           warn("exact 1-sample 1-sided KS test not implemented; using asymptotic");
3706 0           NV z = statistic * sqrt((NV)valid_nx);
3707 0           p_value = exp(-2.0 * z * z);
3708             }
3709             } else {
3710 1           method_desc = "One-sample Kolmogorov-Smirnov test (asymptotic)";
3711 1           NV z = statistic * sqrt((NV)valid_nx);
3712 1 50         if (is_two_sided) p_value = K2l(z, 0, 1e-6);
3713 0           else p_value = exp(-2.0 * z * z);
3714             }
3715             } else {
3716 2           Safefree(x_data);
3717 2           croak("ks_test: Unsupported 1-sample distribution '%s'. Use arrays for 2-sample.", dist);
3718             }
3719             } else {
3720 2           Safefree(x_data);
3721 2           croak("ks_test: Invalid arguments for 'y'.");
3722             }
3723              
3724 25           Safefree(x_data);
3725 25 50         if (p_value > 1.0) p_value = 1.0;
3726 25 50         if (p_value < 0.0) p_value = 0.0;
3727              
3728 25           HV *restrict res = newHV();
3729 25           hv_stores(res, "statistic", newSVnv(statistic));
3730 25           hv_stores(res, "p_value", newSVnv(p_value));
3731 25           hv_stores(res, "method", newSVpv(method_desc, 0));
3732 25           hv_stores(res, "alternative", newSVpv(alternative, 0));
3733 25           RETVAL = newRV_noinc((SV *)res);
3734             }
3735             OUTPUT:
3736             RETVAL
3737              
3738             SV* wilcox_test(...)
3739             CODE:
3740             {
3741 10           SV *restrict x_sv = NULL, *restrict y_sv = NULL;
3742 10           bool paired = FALSE, correct = TRUE;
3743 10           NV mu = 0.0;
3744 10           short int exact = -1;
3745 10           const char *restrict alternative = "two.sided";
3746 10           int arg_idx = 0;
3747             // 1. Shift first positional argument as 'x' if it's an array reference
3748 10 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
3749 2           x_sv = ST(arg_idx);
3750 2           arg_idx++;
3751             }
3752             // 2. Shift second positional argument as 'y' if it's an array reference
3753 10 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
3754 2           y_sv = ST(arg_idx);
3755 2           arg_idx++;
3756             }
3757             // Ensure the remaining arguments form complete key-value pairs
3758 10 50         if ((items - arg_idx) % 2 != 0) {
3759 0           croak("Usage: wilcox_test(\\@x, [\\@y], key => value, ...)");
3760             }
3761             // --- Parse named arguments from the remaining flat stack ---
3762 30 100         for (; arg_idx < items; arg_idx += 2) {
3763 20           const char *restrict key = SvPV_nolen(ST(arg_idx));
3764 20           SV *restrict val = ST(arg_idx + 1);
3765 20 100         if (strEQ(key, "x")) x_sv = val;
3766 13 100         else if (strEQ(key, "y")) y_sv = val;
3767 6 100         else if (strEQ(key, "paired")) paired = SvTRUE(val);
3768 3 50         else if (strEQ(key, "correct")) correct = SvTRUE(val);
3769 3 100         else if (strEQ(key, "mu")) mu = SvNV(val);
3770 2 50         else if (strEQ(key, "exact")) {
3771 0 0         if (!SvOK(val)) exact = -1;
3772 0           else exact = SvTRUE(val) ? 1 : 0;
3773             }
3774 2 50         else if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
3775 0           else croak("wilcox_test: unknown argument '%s'", key);
3776             }
3777             // FIX 1: validate 'alternative' rather than silently falling through to two-sided
3778 10 100         if (strNE(alternative, "two.sided") && strNE(alternative, "less") && strNE(alternative, "greater"))
    100          
    50          
3779 0           croak("wilcox_test: 'alternative' must be one of 'two.sided', 'less', 'greater'");
3780             // --- Validate required / types ---
3781 10 100         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
    50          
3782 1           croak("wilcox_test: 'x' is a required argument and must be an ARRAY reference");
3783 9           AV *restrict x_av = (AV*)SvRV(x_sv);
3784 9           size_t nx = av_len(x_av) + 1;
3785 9 50         if (nx == 0) croak("Not enough 'x' observations");
3786              
3787 9           AV *restrict y_av = NULL;
3788 9           size_t ny = 0;
3789 9 100         if (y_sv && SvROK(y_sv) && SvTYPE(SvRV(y_sv)) == SVt_PVAV) {
    50          
    50          
3790 8           y_av = (AV*)SvRV(y_sv);
3791 8           ny = av_len(y_av) + 1;
3792             }
3793 9           NV p_value = 0.0, statistic = 0.0;
3794 9           const char *restrict method_desc = "";
3795 9           bool use_exact = FALSE;
3796             // --- TWO SAMPLE (Mann-Whitney) ---
3797 14 100         if (ny > 0 && !paired) {
    100          
3798 5           RankInfo *restrict ri = (RankInfo *)safemalloc((nx + ny) * sizeof(RankInfo));
3799 5           size_t valid_nx = 0, valid_ny = 0;
3800 33 100         for (size_t i = 0; i < nx; i++) {
3801 28           SV**restrict el = av_fetch(x_av, i, 0);
3802 28 50         if (el && SvOK(*el) && looks_like_number(*el)) {
    50          
    50          
3803 28           ri[valid_nx].val = SvNV(*el) - mu; // R subtracts mu from x
3804 28           ri[valid_nx].idx = 1;
3805 28           valid_nx++;
3806             }
3807             }
3808 33 100         for (size_t i = 0; i < ny; i++) {
3809 28           SV**restrict el = av_fetch(y_av, i, 0);
3810 28 50         if (el && SvOK(*el) && looks_like_number(*el)) {
    50          
    50          
3811 28           ri[valid_nx + valid_ny].val = SvNV(*el);
3812 28           ri[valid_nx + valid_ny].idx = 2;
3813 28           valid_ny++;
3814             }
3815             }
3816 5 50         if (valid_nx == 0) { Safefree(ri); croak("not enough (non-missing) 'x' observations"); }
3817 5 50         if (valid_ny == 0) { Safefree(ri); croak("not enough 'y' observations"); }
3818 5           size_t total_n = valid_nx + valid_ny;
3819 5           bool has_ties = 0;
3820 5           NV tie_adj = rank_and_count_ties(ri, total_n, &has_ties);
3821 5           NV w_rank_sum = 0.0;
3822 61 100         for (size_t i = 0; i < total_n; i++) if (ri[i].idx == 1) w_rank_sum += ri[i].rank;
    100          
3823 5           statistic = w_rank_sum - (NV)valid_nx * (valid_nx + 1.0) / 2.0;
3824 5 50         if (exact == 1) use_exact = TRUE;
3825 5 50         else if (exact == 0) use_exact = FALSE;
3826 5 50         else use_exact = (valid_nx < 50 && valid_ny < 50 && !has_ties);
    50          
    100          
3827 5 100         if (use_exact && has_ties) {
    50          
3828 0           warn("wilcox_test: cannot compute exact p-value with ties; falling back to approximation");
3829 0           use_exact = FALSE;
3830             }
3831 5 100         if (use_exact) {
3832 2           method_desc = "Wilcoxon rank sum exact test";
3833 2           NV p_less = exact_pwilcox(statistic, valid_nx, valid_ny);
3834 2           NV p_greater = 1.0 - exact_pwilcox(statistic - 1.0, valid_nx, valid_ny);
3835              
3836 2 100         if (strcmp(alternative, "less") == 0) p_value = p_less;
3837 1 50         else if (strcmp(alternative, "greater") == 0) p_value = p_greater;
3838             else {
3839 0 0         NV p = (p_less < p_greater) ? p_less : p_greater;
3840 0           p_value = 2.0 * p;
3841             }
3842             } else {
3843 3 50         method_desc = correct ? "Wilcoxon rank sum test with continuity correction" : "Wilcoxon rank sum test";
3844 3           NV mean_w = (NV)valid_nx * valid_ny / 2.0; // FIX 4: was 'exp' (shadowed libm exp)
3845 3           NV var = ((NV)valid_nx * valid_ny / 12.0) * ((total_n + 1.0) - tie_adj / ((NV)total_n * (total_n - 1.0)));
3846 3           NV z = statistic - mean_w;
3847 3           NV CORRECTION = 0.0;
3848 3 50         if (correct) {
3849             // FIX 3: sign(z)*0.5, so z == 0 -> 0 (not -0.5)
3850 3 50         if (strcmp(alternative, "two.sided") == 0) CORRECTION = (z > 0) ? 0.5 : (z < 0) ? -0.5 : 0.0;
    100          
    50          
3851 0 0         else if (strcmp(alternative, "greater") == 0) CORRECTION = 0.5;
3852 0 0         else if (strcmp(alternative, "less") == 0) CORRECTION = -0.5;
3853             }
3854             // FIX 2: guard against degenerate (all-tied) variance instead of dividing by zero
3855 3 50         if (var <= 0.0) {
3856 0           warn("wilcox_test: zero variance (all values tied); p-value is undefined");
3857 0           p_value = 1.0;
3858             } else {
3859 3           z = (z - CORRECTION) / sqrt(var);
3860 3 50         if (strcmp(alternative, "less") == 0) p_value = approx_pnorm(z);
3861 3 50         else if (strcmp(alternative, "greater") == 0) p_value = 1.0 - approx_pnorm(z);
3862 3           else p_value = 2.0 * approx_pnorm(-fabs(z));
3863             }
3864             }
3865 5           Safefree(ri);
3866             } else { // --- 1 SAMPLE / PAIRED ---
3867 4 100         if (paired && (!y_av || nx != ny)) croak("'x' and 'y' must have the same length for paired test");
    50          
    100          
3868 3           NV *restrict diffs = (NV *)safemalloc(nx * sizeof(NV));
3869 3           size_t n_nz = 0;
3870 3           bool has_zeroes = FALSE;
3871 26 100         for (size_t i = 0; i < nx; i++) {
3872 23           SV**restrict x_el = av_fetch(x_av, i, 0);
3873 23 50         if (!x_el || !SvOK(*x_el) || !looks_like_number(*x_el)) continue;
    50          
    50          
3874 23           NV dx = SvNV(*x_el);
3875              
3876 23 100         if (paired) {
3877 18           SV**restrict y_el = av_fetch(y_av, i, 0);
3878 18 50         if (!y_el || !SvOK(*y_el) || !looks_like_number(*y_el)) continue;
    50          
    50          
3879 18           NV dy = SvNV(*y_el);
3880 18           NV d = dx - dy - mu;
3881 18 50         if (d == 0.0) has_zeroes = TRUE; // Drop exact zeroes
3882 18           else diffs[n_nz++] = d;
3883             } else {
3884 5           NV d = dx - mu;
3885 5 50         if (d == 0.0) has_zeroes = TRUE;
3886 5           else diffs[n_nz++] = d;
3887             }
3888             }
3889 3 50         if (n_nz == 0) {
3890 0           Safefree(diffs);
3891 0           croak("not enough (non-missing) observations");
3892             }
3893 3           RankInfo *restrict ri = (RankInfo *)safemalloc(n_nz * sizeof(RankInfo));
3894 26 100         for (size_t i = 0; i < n_nz; i++) {
3895 23           ri[i].val = fabs(diffs[i]);
3896 23           ri[i].idx = (diffs[i] > 0);
3897             }
3898 3           bool has_ties = 0;
3899 3           NV tie_adj = rank_and_count_ties(ri, n_nz, &has_ties);
3900 3           statistic = 0.0;
3901 26 100         for (size_t i = 0; i < n_nz; i++) {
3902 23 100         if (ri[i].idx) statistic += ri[i].rank;
3903             }
3904 3 50         if (exact == 1) use_exact = TRUE;
3905 3 50         else if (exact == 0) use_exact = FALSE;
3906 3 50         else use_exact = (n_nz < 50 && !has_ties);
    50          
3907 3 50         if (use_exact && has_ties) {
    50          
3908 0           warn("cannot compute exact p-value with ties; falling back to approximation");
3909 0           use_exact = FALSE;
3910             }
3911 3 50         if (use_exact && has_zeroes) {
    50          
3912 0           warn("cannot compute exact p-value with zeroes; falling back to approximation");
3913 0           use_exact = FALSE;
3914             }
3915 3 50         if (use_exact) {
3916 3           method_desc = "Wilcoxon signed rank exact test"; // FIX 5: was an identical-branch ternary
3917 3           NV p_less = exact_psignrank(statistic, n_nz);
3918 3           NV p_greater = 1.0 - exact_psignrank(statistic - 1.0, n_nz);
3919              
3920 3 50         if (strcmp(alternative, "less") == 0) p_value = p_less;
3921 3 50         else if (strcmp(alternative, "greater") == 0) p_value = p_greater;
3922             else {
3923 3 50         NV p = (p_less < p_greater) ? p_less : p_greater;
3924 3           p_value = 2.0 * p;
3925             }
3926             } else {
3927 0 0         method_desc = correct ? "Wilcoxon signed rank test with continuity correction" : "Wilcoxon signed rank test";
3928 0           NV mean_v = (NV)n_nz * (n_nz + 1.0) / 4.0; // FIX 4: was 'exp'
3929 0           NV var = (n_nz * (n_nz + 1.0) * (2.0 * n_nz + 1.0) / 24.0) - (tie_adj / 48.0);
3930 0           NV z = statistic - mean_v;
3931 0           NV CORRECTION = 0.0;
3932 0 0         if (correct) {
3933             // FIX 3: sign(z)*0.5
3934 0 0         if (strcmp(alternative, "two.sided") == 0) CORRECTION = (z > 0) ? 0.5 : (z < 0) ? -0.5 : 0.0;
    0          
    0          
3935 0 0         else if (strcmp(alternative, "greater") == 0) CORRECTION = 0.5;
3936 0 0         else if (strcmp(alternative, "less") == 0) CORRECTION = -0.5;
3937             }
3938              
3939             // FIX 2: guard against degenerate variance
3940 0 0         if (var <= 0.0) {
3941 0           warn("wilcox_test: zero variance (all values tied); p-value is undefined");
3942 0           p_value = 1.0;
3943             } else {
3944 0           z = (z - CORRECTION) / sqrt(var);
3945 0 0         if (strcmp(alternative, "less") == 0) p_value = approx_pnorm(z);
3946 0 0         else if (strcmp(alternative, "greater") == 0) p_value = 1.0 - approx_pnorm(z);
3947 0           else p_value = 2.0 * approx_pnorm(-fabs(z));
3948             }
3949             }
3950 3           Safefree(ri); Safefree(diffs);
3951             }
3952 8 50         if (p_value > 1.0) p_value = 1.0;
3953 8           HV *restrict res = newHV();
3954 8           hv_stores(res, "statistic", newSVnv(statistic));
3955 8           hv_stores(res, "p_value", newSVnv(p_value));
3956 8           hv_stores(res, "method", newSVpv(method_desc, 0));
3957 8           hv_stores(res, "alternative", newSVpv(alternative, 0));
3958 8           RETVAL = newRV_noinc((SV*)res);
3959             }
3960             OUTPUT:
3961             RETVAL
3962              
3963             SV* chisq_test(data_ref)
3964             SV* data_ref;
3965             CODE:
3966             {
3967             // 1. Input Validation & Data Matrix Construction
3968 16 100         if (!SvROK(data_ref)) {
3969 3           croak("Input must be a reference");
3970             }
3971              
3972 13           svtype input_type = SvTYPE(SvRV(data_ref));
3973 13 100         if (input_type != SVt_PVAV && input_type != SVt_PVHV) {
    100          
3974 1           croak("Input must be an array reference or a hash reference");
3975             }
3976              
3977 12           NV **restrict obs_matrix = NULL;
3978 12           NV *restrict obs_array = NULL;
3979 12           AV*restrict row_keys = NULL;
3980 12           AV*restrict col_keys = NULL;
3981 12           unsigned int r = 0, c = 0;
3982 12           bool is_2d = 0;
3983              
3984 12 100         if (input_type == SVt_PVAV) {
3985 8           AV*restrict obs_av = (AV*)SvRV(data_ref);
3986 8 50         r = av_top_index(obs_av) + 1;
3987 8 100         if (r > 0) {
3988 7           SV**restrict first_elem = av_fetch(obs_av, 0, 0);
3989 7 50         if (first_elem && SvROK(*first_elem) && SvTYPE(SvRV(*first_elem)) == SVt_PVAV) {
    100          
    50          
3990 4           is_2d = 1;
3991 4 50         c = av_top_index((AV*)SvRV(*first_elem)) + 1;
3992 4           obs_matrix = (NV**)safemalloc(r * sizeof(NV*));
3993 12 100         for (unsigned int i = 0; i < r; i++) {
3994 8           obs_matrix[i] = (NV*)safecalloc(c, sizeof(NV));
3995 8           SV**restrict row_sv = av_fetch(obs_av, i, 0);
3996 8 50         if (row_sv && SvROK(*row_sv)) {
    50          
3997 8           AV*restrict row_av = (AV*)SvRV(*row_sv);
3998 28 100         for (unsigned int j = 0; j < c; j++) {
3999 20           SV**restrict val_sv = av_fetch(row_av, j, 0);
4000 20 50         if (val_sv) obs_matrix[i][j] = SvNV(*val_sv);
4001             }
4002             }
4003             }
4004             } else {
4005 3           c = r;
4006 3           r = 1;
4007 3           obs_array = (NV*)safemalloc(c * sizeof(NV));
4008 9 100         for (unsigned int j = 0; j < c; j++) {
4009 7           SV**restrict val_sv = av_fetch(obs_av, j, 0);
4010 7 50         if (val_sv) obs_array[j] = SvNV(*val_sv);
4011             }
4012             }
4013             }
4014 4 50         } else if (input_type == SVt_PVHV) {
4015 4           HV*restrict obs_hv = (HV*)SvRV(data_ref);
4016 4           row_keys = newAV();
4017 4           col_keys = newAV();
4018              
4019             HE*restrict first_entry;
4020 4           hv_iterinit(obs_hv);
4021 4           first_entry = hv_iternext(obs_hv);
4022              
4023 4 100         if (first_entry) {
4024 3           SV*restrict first_val = hv_iterval(obs_hv, first_entry);
4025 4 100         if (SvROK(first_val) && SvTYPE(SvRV(first_val)) == SVt_PVHV) {
    50          
4026 1           is_2d = 1;
4027 1           HV*restrict col_idx_map = newHV();
4028 1           hv_iterinit(obs_hv);
4029             HE*restrict row_entry;
4030 3 100         while ((row_entry = hv_iternext(obs_hv))) {
4031 2           av_push(row_keys, newSVsv(hv_iterkeysv(row_entry)));
4032 2           r++;
4033 2           SV*restrict inner_sv = hv_iterval(obs_hv, row_entry);
4034 2 50         if (SvROK(inner_sv) && SvTYPE(SvRV(inner_sv)) == SVt_PVHV) {
    50          
4035 2           HV*restrict inner_hv = (HV*)SvRV(inner_sv);
4036             HE*restrict col_entry;
4037 2           hv_iterinit(inner_hv);
4038 8 100         while ((col_entry = hv_iternext(inner_hv))) {
4039 4           SV*restrict col_key = hv_iterkeysv(col_entry);
4040 4 100         if (!hv_exists_ent(col_idx_map, col_key, 0)) {
4041 2           hv_store_ent(col_idx_map, col_key, newSViv(c), 0);
4042 2           av_push(col_keys, newSVsv(col_key));
4043 2           c++;
4044             }
4045             }
4046             }
4047             }
4048              
4049 1           obs_matrix = (NV**)safemalloc(r * sizeof(NV*));
4050 3 100         for (unsigned int i = 0; i < r; i++) {
4051 2           obs_matrix[i] = (NV*)safecalloc(c, sizeof(NV));
4052 2           SV**restrict row_key_sv = av_fetch(row_keys, i, 0);
4053            
4054             // FIX 1: Extract HE* instead of SV**
4055 2           HE* inner_he = hv_fetch_ent(obs_hv, *row_key_sv, 0, 0);
4056 2 50         if (inner_he) {
4057 2           SV*restrict inner_sv = HeVAL(inner_he);
4058 2 50         if (SvROK(inner_sv)) {
4059 2           HV*restrict inner_hv = (HV*)SvRV(inner_sv);
4060 6 100         for (unsigned int j = 0; j < c; j++) {
4061 4           SV**restrict col_key_sv = av_fetch(col_keys, j, 0);
4062            
4063             // FIX 2: Extract HE* instead of SV**
4064 4           HE*restrict val_he = hv_fetch_ent(inner_hv, *col_key_sv, 0, 0);
4065 4 50         if (val_he) {
4066 4           obs_matrix[i][j] = SvNV(HeVAL(val_he));
4067             }
4068             }
4069             }
4070             }
4071             }
4072 1           SvREFCNT_dec(col_idx_map);
4073             } else {
4074             // 1D Hash Handling
4075 2           hv_iterinit(obs_hv);
4076             HE*restrict row_entry;
4077 6 100         while ((row_entry = hv_iternext(obs_hv))) {
4078 4           av_push(col_keys, newSVsv(hv_iterkeysv(row_entry)));
4079 4           c++;
4080             }
4081 2           obs_array = (NV*)safemalloc(c * sizeof(NV));
4082 5 100         for (unsigned int j = 0; j < c; j++) {
4083 4           SV**restrict col_key_sv = av_fetch(col_keys, j, 0);
4084             // FIX 3: Extract HE* instead of SV**
4085 4           HE*restrict val_he = hv_fetch_ent(obs_hv, *col_key_sv, 0, 0);
4086 4 50         if (val_he) {
4087 4           obs_array[j] = SvNV(HeVAL(val_he));
4088             }
4089             }
4090             }
4091             }
4092             }
4093              
4094 10 100         if ((is_2d && (r == 0 || c == 0)) || (!is_2d && c == 0)) {
    50          
    50          
    100          
    100          
4095 2           croak("Empty data structure");
4096             }
4097              
4098             // 2. Perform Math Algorithm
4099 8           NV stat = 0.0, grand_total = 0.0;
4100 8           unsigned int df = 0;
4101 8 100         bool yates = (is_2d && r == 2 && c == 2) ? 1 : 0;
    50          
    100          
4102 8           SV*restrict expected_ref = NULL;
4103              
4104 8 100         if (is_2d) {
4105 5           NV *restrict row_sum = (NV*)safemalloc(r * sizeof(NV));
4106 5           NV *restrict col_sum = (NV*)safemalloc(c * sizeof(NV));
4107 15 100         for(unsigned int i=0; i
4108 17 100         for(unsigned int j=0; j
4109              
4110 15 100         for (unsigned int i = 0; i < r; i++) {
4111 34 100         for (unsigned int j = 0; j < c; j++) {
4112 24           NV val = obs_matrix[i][j];
4113 24           row_sum[i] += val;
4114 24           col_sum[j] += val;
4115 24           grand_total += val;
4116             }
4117             }
4118              
4119 5 100         if (input_type == SVt_PVAV) {
4120 4           AV*restrict expected_av = newAV();
4121 12 100         for (unsigned int i = 0; i < r; i++) {
4122 8           AV*restrict exp_row = newAV();
4123 28 100         for (unsigned int j = 0; j < c; j++) {
4124 20           NV E = (row_sum[i] * col_sum[j]) / grand_total;
4125 20           NV O = obs_matrix[i][j];
4126 20           av_push(exp_row, newSVnv(E));
4127 20 100         if (yates) {
4128 8           NV abs_diff = fabs(O - E);
4129 8 50         NV y_corr = (abs_diff > 0.5) ? 0.5 : abs_diff;
4130 8           NV diff = abs_diff - y_corr;
4131 8           stat += (diff * diff) / E;
4132             } else {
4133 12           stat += ((O - E) * (O - E)) / E;
4134             }
4135             }
4136 8           av_push(expected_av, newRV_noinc((SV*)exp_row));
4137             }
4138 4           expected_ref = newRV_noinc((SV*)expected_av);
4139             } else { // SVt_PVHV
4140 1           HV*restrict expected_hv = newHV();
4141 3 100         for (unsigned int i = 0; i < r; i++) {
4142 2           HV*restrict exp_row = newHV();
4143 6 100         for (unsigned int j = 0; j < c; j++) {
4144 4           NV E = (row_sum[i] * col_sum[j]) / grand_total;
4145 4           NV O = obs_matrix[i][j];
4146 4           SV**restrict col_key_sv = av_fetch(col_keys, j, 0);
4147 4           hv_store_ent(exp_row, *col_key_sv, newSVnv(E), 0);
4148              
4149 4 50         if (yates) {
4150 4           NV abs_diff = fabs(O - E);
4151 4 50         NV y_corr = (abs_diff > 0.5) ? 0.5 : abs_diff;
4152 4           NV diff = abs_diff - y_corr;
4153 4           stat += (diff * diff) / E;
4154             } else {
4155 0           stat += ((O - E) * (O - E)) / E;
4156             }
4157             }
4158 2           SV**restrict row_key_sv = av_fetch(row_keys, i, 0);
4159 2           hv_store_ent(expected_hv, *row_key_sv, newRV_noinc((SV*)exp_row), 0);
4160             }
4161 1           expected_ref = newRV_noinc((SV*)expected_hv);
4162             }
4163 5           safefree(row_sum); safefree(col_sum);
4164 5           df = (r - 1) * (c - 1);
4165             } else {
4166 12 100         for (unsigned int j = 0; j < c; j++) {
4167 9           grand_total += obs_array[j];
4168             }
4169 3           NV E = grand_total / (NV)c;
4170              
4171 3 100         if (input_type == SVt_PVAV) {
4172 2           AV*restrict expected_av = newAV();
4173 8 100         for (unsigned int j = 0; j < c; j++) {
4174 6           NV O = obs_array[j];
4175 6           av_push(expected_av, newSVnv(E));
4176 6           stat += ((O - E) * (O - E)) / E;
4177             }
4178 2           expected_ref = newRV_noinc((SV*)expected_av);
4179             } else { // SVt_PVHV
4180 1           HV*restrict expected_hv = newHV();
4181 4 100         for (unsigned int j = 0; j < c; j++) {
4182 3           NV O = obs_array[j];
4183 3           SV**restrict col_key_sv = av_fetch(col_keys, j, 0);
4184 3           hv_store_ent(expected_hv, *col_key_sv, newSVnv(E), 0);
4185 3           stat += ((O - E) * (O - E)) / E;
4186             }
4187 1           expected_ref = newRV_noinc((SV*)expected_hv);
4188             }
4189 3           df = c - 1;
4190             }
4191              
4192             // Memory Cleanup for Matrices/Arrays
4193 8 100         if (obs_matrix) {
4194 15 100         for (unsigned int i = 0; i < r; i++) {
4195 10           safefree(obs_matrix[i]);
4196             }
4197 5           safefree(obs_matrix);
4198             }
4199 8 100         if (obs_array) safefree(obs_array);
4200 8 100         if (row_keys) SvREFCNT_dec(row_keys);
4201 8 100         if (col_keys) SvREFCNT_dec(col_keys);
4202              
4203 8           NV p_val = get_p_value(stat, df);
4204              
4205             // 3. Build the top-level results Hash (mimicking R's htest structure)
4206 8           HV*restrict results = newHV();
4207              
4208 8           HV*restrict statistic_hv = newHV();
4209 8           hv_store(statistic_hv, "X-squared", 9, newSVnv(stat), 0);
4210 8           hv_store(results, "statistic", 9, newRV_noinc((SV*)statistic_hv), 0);
4211              
4212 8           HV*restrict parameter_hv = newHV();
4213 8           hv_store(parameter_hv, "df", 2, newSViv(df), 0);
4214 8           hv_store(results, "parameter", 9, newRV_noinc((SV*)parameter_hv), 0);
4215              
4216 8           hv_store(results, "p.value", 7, newSVnv(p_val), 0);
4217 8           hv_store(results, "expected", 8, expected_ref, 0);
4218 8           hv_store(results, "observed", 8, SvREFCNT_inc(data_ref), 0);
4219              
4220 8 100         if (input_type == SVt_PVAV) {
4221 6           hv_store(results, "data.name", 9, newSVpv("Perl ArrayRef", 0), 0);
4222             } else {
4223 2           hv_store(results, "data.name", 9, newSVpv("Perl HashRef", 0), 0);
4224             }
4225              
4226 8 100         if (is_2d) {
4227 5 100         if (yates) {
4228 3           hv_store(results, "method", 6, newSVpv("Pearson's Chi-squared test with Yates' continuity correction", 0), 0);
4229             } else {
4230 2           hv_store(results, "method", 6, newSVpv("Pearson's Chi-squared test", 0), 0);
4231             }
4232             } else {
4233 3           hv_store(results, "method", 6, newSVpv("Chi-squared test for given probabilities", 0), 0);
4234             }
4235              
4236 8           RETVAL = newRV_noinc((SV*)results);
4237             }
4238             OUTPUT:
4239             RETVAL
4240              
4241             PROTOTYPES: ENABLE
4242              
4243             void write_table(...)
4244             PPCODE:
4245             {
4246 65           SV *restrict data_sv = NULL;
4247 65           SV *restrict file_sv = NULL;
4248 65           unsigned int arg_idx = 0;
4249             // Mimic the Perl shift logic
4250 65 100         if (arg_idx < items && SvROK(ST(arg_idx))) {
    100          
4251 63           int type = SvTYPE(SvRV(ST(arg_idx)));
4252 63 100         if (type == SVt_PVHV || type == SVt_PVAV) {
    50          
4253 63           data_sv = ST(arg_idx);
4254 63           arg_idx++;
4255             }
4256             }
4257             // Only consume a positional file argument if it is a plain string that is
4258             // NOT one of the named option keys. Otherwise write_table(data=>..., file=>...)
4259             // would grab the literal string "data" as the filename.
4260 65 100         if (arg_idx < items) {
4261 63           SV *restrict cand = ST(arg_idx);
4262 63 50         if (SvOK(cand) && !SvROK(cand)) {
    50          
4263 63           const char *restrict k = SvPV_nolen(cand);
4264 63 100         if (!(strEQ(k, "data") || strEQ(k, "file") || strEQ(k, "col.names") ||
    100          
    50          
4265 61 50         strEQ(k, "row.names") || strEQ(k, "sep") || strEQ(k, "delim") ||
    100          
    50          
4266 60 50         strEQ(k, "undef.val"))) {
4267 60           file_sv = cand;
4268 60           arg_idx++;
4269             }
4270             }
4271             }
4272 65           const char *restrict sep = ",";
4273 65           bool explicit_sep = 0; // Track if delimiter was manually specified
4274             // CHANGED: default undef cells to a true empty value ("") instead of NULL.
4275             // With print_string_row emitting zero-length fields bare (no quotes), an
4276             // undef cell now prints as nothing at all: a,,c -- not a,'',c or a,"",c.
4277             // 'undef.val' => 'NA' (etc.) still overrides this.
4278 65           const char *restrict undef_val = "";
4279 65           SV *restrict row_names_sv = sv_2mortal(newSViv(1));
4280 65           SV *restrict col_names_sv = NULL;
4281             // Read the remaining Hash-style arguments
4282 145 100         for (; arg_idx < items; arg_idx += 2) {
4283 83 100         if (arg_idx + 1 >= items) croak("write_table: Odd number of arguments passed");
4284 81           const char *restrict key = SvPV_nolen(ST(arg_idx));
4285 81           SV *restrict val = ST(arg_idx + 1);
4286 81 100         if (strEQ(key, "data")) data_sv = val;
4287 80 100         else if (strEQ(key, "col.names")) col_names_sv = val;
4288 64 100         else if (strEQ(key, "file")) file_sv = val;
4289 62 100         else if (strEQ(key, "row.names")) row_names_sv = val;
4290             // Check for either "sep" or "delim" and mark as explicitly provided
4291 43 100         else if (strEQ(key, "sep") || strEQ(key, "delim")) {
    100          
4292 18           sep = SvPV_nolen(val);
4293 18           explicit_sep = 1;
4294             }
4295             // FIX: 'undef.val' => undef used to call SvPV_nolen(&PL_sv_undef)
4296             // (warning + empty string by accident); make it explicit.
4297 25 100         else if (strEQ(key, "undef.val")) undef_val = SvOK(val) ? SvPV_nolen(val) : "";
    100          
4298 1           else croak("write_table: Unknown arguments passed: %s", key);
4299             }
4300 62 100         if (!data_sv || !SvROK(data_sv)) {
    50          
4301 1           croak("write_table: 'data' must be a HASH or ARRAY reference\n");
4302             }
4303 61           SV *restrict data_ref = SvRV(data_sv);
4304 61 100         if (SvTYPE(data_ref) != SVt_PVHV && SvTYPE(data_ref) != SVt_PVAV) {
    50          
4305 0           croak("write_table: 'data' must be a HASH or ARRAY reference\n");
4306             }
4307 61 100         if (!file_sv || !SvOK(file_sv)) croak("write_table: file name missing\n");
    50          
4308 60           const char *restrict file = SvPV_nolen(file_sv);
4309             // Auto-detect separator from file extension if not overridden
4310 60 100         if (!explicit_sep) {
4311 42           size_t file_len = strlen(file);
4312 42 50         if (file_len >= 4) {
4313 42           const char *restrict ext = file + file_len - 4;
4314 42 100         if (strEQ(ext, ".tsv") || strEQ(ext, ".TSV")) {
    50          
4315 3           sep = "\t";
4316 39 50         } else if (strEQ(ext, ".csv") || strEQ(ext, ".CSV")) {
    0          
4317 39           sep = ",";
4318             }
4319             }
4320             }
4321 60 100         if (col_names_sv && SvOK(col_names_sv)) {
    50          
4322 16 100         if (!SvROK(col_names_sv) || SvTYPE(SvRV(col_names_sv)) != SVt_PVAV) {
    50          
4323 2           croak("write_table: 'col.names' must be an ARRAY reference\n");
4324             }
4325             }
4326 58           bool is_hoh = 0, is_hoa = 0, is_aoh = 0, is_flat_hash = 0;
4327 58           AV *restrict rows_av = NULL;
4328             // Validate Input Structures & Homogeneity
4329 58 100         if (SvTYPE(data_ref) == SVt_PVHV) {
4330 48           HV *restrict hv = (HV*)data_ref;
4331 48 100         if (hv_iterinit(hv) == 0) XSRETURN_EMPTY;
4332 47           HE *restrict entry = hv_iternext(hv);
4333 47           SV *restrict first_val = hv_iterval(hv, entry);
4334              
4335 47 50         if (!first_val) {
4336 0           croak("write_table: Invalid hash entry\n");
4337             }
4338             // Check if top level values are scalars (Flat Hash)
4339 47 100         if (!SvROK(first_val)) {
4340 10           is_flat_hash = 1;
4341             } else {
4342 37           int first_type = SvTYPE(SvRV(first_val));
4343 37 100         if (first_type != SVt_PVHV && first_type != SVt_PVAV) {
    50          
4344 0           croak("write_table: Data values must be either all HASHes, all ARRAYs, or all scalars\n");
4345             }
4346 37           is_hoh = (first_type == SVt_PVHV);
4347 37           is_hoa = (first_type == SVt_PVAV);
4348             }
4349 47           hv_iterinit(hv);
4350 145 100         while ((entry = hv_iternext(hv))) {
4351 100           SV *restrict val = hv_iterval(hv, entry);
4352 100 100         if (is_flat_hash) {
4353 28 50         if (val && SvROK(val)) {
    50          
4354 0           croak("write_table: Mixed data types detected. Ensure all values are scalars for a flat hash.\n");
4355             }
4356             } else {
4357 72 50         if (!val || !SvROK(val) || SvTYPE(SvRV(val)) != (is_hoh ? SVt_PVHV : SVt_PVAV)) {
    100          
    100          
    100          
4358 2 100         croak("write_table: Mixed data types detected. Ensure all values are %s references.\n", is_hoh ? "HASH" : "ARRAY");
4359             }
4360             }
4361             }
4362 45 100         if (is_hoh) { // Rows are only explicitly pre-gathered for HOH
4363 11           rows_av = newAV();
4364 11           hv_iterinit(hv);
4365 28 100         while ((entry = hv_iternext(hv))) {
4366 17           av_push(rows_av, newSVsv(hv_iterkeysv(entry)));
4367             }
4368             }
4369             } else {
4370 10           AV *restrict av = (AV*)data_ref;
4371 10 100         if (av_len(av) < 0) XSRETURN_EMPTY;
4372 9           SV **restrict first_ptr = av_fetch(av, 0, 0);
4373 9 50         if (!first_ptr || !*first_ptr || !SvROK(*first_ptr) || SvTYPE(SvRV(*first_ptr)) != SVt_PVHV) {
    50          
    100          
    50          
4374 1 50         if (first_ptr && *first_ptr && SvROK(*first_ptr))
    50          
    50          
4375 0           croak("write_table: For ARRAY data, every element must be a HASH reference "
4376             "(Array of Hashes); element 0 is a reference of type '%s'\n",
4377             sv_reftype(SvRV(*first_ptr), 0));
4378 1 50         else if (first_ptr && *first_ptr && SvOK(*first_ptr))
    50          
    50          
4379 1           croak("write_table: For ARRAY data, every element must be a HASH reference "
4380             "(Array of Hashes); element 0 is a non-reference scalar (value: '%s')\n",
4381             SvPV_nolen(*first_ptr));
4382             else
4383 0           croak("write_table: For ARRAY data, every element must be a HASH reference "
4384             "(Array of Hashes); element 0 is undef\n");
4385             }
4386             // FIX: i was size_t while av_len() returns SSize_t; keep both signed.
4387 34 100         for (SSize_t i = 0; i <= av_len(av); i++) {
4388 26           SV **restrict ptr = av_fetch(av, i, 0);
4389 26 50         if (!ptr || !*ptr || !SvROK(*ptr) || SvTYPE(SvRV(*ptr)) != SVt_PVHV) {
    50          
    50          
    50          
4390 0           croak("write_table: Mixed data types detected in Array of Hashes. All elements must be HASH references.\n");
4391             }
4392             }
4393 8           is_aoh = 1;
4394             }
4395 53           PerlIO *restrict fh = PerlIO_open(file, "w");
4396 53 100         if (!fh) {
4397             // FIX: rows_av was leaked here when the open failed on HoH input.
4398 1 50         if (rows_av) SvREFCNT_dec(rows_av);
4399 1           croak("write_table: Could not open '%s' for writing", file);
4400             }
4401 52           AV *restrict headers_av = newAV();
4402 52 50         bool inc_rownames = (row_names_sv && SvTRUE(row_names_sv)) ? 1 : 0;
    100          
4403 52           const char *restrict rownames_col = NULL;
4404             // ----- Hash of Hashes -----
4405 52 100         if (is_hoh) {
4406 12 100         if (col_names_sv && SvOK(col_names_sv)) {
    50          
4407 2           AV *restrict c_av = (AV*)SvRV(col_names_sv);
4408             // FIX: i was size_t; av_len() == -1 on an empty col.names array
4409             // converted to SIZE_MAX and looped (effectively) forever.
4410 5 100         for (SSize_t i = 0; i <= av_len(c_av); i++) {
4411 3           SV **restrict c = av_fetch(c_av, i, 0);
4412 3 50         if (c && SvOK(*c)) av_push(headers_av, newSVsv(*c));
    50          
4413             }
4414             } else {
4415 8           HV *restrict col_map = newHV();
4416 8           hv_iterinit((HV*)data_ref);
4417             HE *restrict entry;
4418 20 100         while ((entry = hv_iternext((HV*)data_ref))) {
4419 12           HV *restrict inner = (HV*)SvRV(hv_iterval((HV*)data_ref, entry));
4420 12           hv_iterinit(inner);
4421             HE *restrict inner_entry;
4422 70031 100         while ((inner_entry = hv_iternext(inner))) {
4423 70019           hv_store_ent(col_map, hv_iterkeysv(inner_entry), newSViv(1), 0);
4424             }
4425             }
4426 8           unsigned num_cols = hv_iterinit(col_map);
4427             // FIX (UTF-8 safety): keep the key SVs (flags intact) and sort
4428             // them with sv_cmp instead of round-tripping through char*.
4429 70022 100         for (unsigned i = 0; i < num_cols; i++) {
4430 70014           HE *restrict ce = hv_iternext(col_map);
4431 70014           av_push(headers_av, newSVsv(hv_iterkeysv(ce)));
4432             }
4433 8 100         if (num_cols > 1)
4434 5           sortsv(AvARRAY(headers_av), num_cols, Perl_sv_cmp);
4435 8           SvREFCNT_dec(col_map);
4436             }
4437 10           size_t num_headers = (size_t)(av_len(headers_av) + 1);
4438 10           const char **restrict header_row = safemalloc((num_headers + 1) * sizeof(char*));
4439 10           size_t h_idx = 0;
4440 10 50         if (inc_rownames) header_row[h_idx++] = "";
4441             // FIX: loop index was 'unsigned short int' -- silently wraps (and
4442             // loops forever) past 65535 columns. Use size_t like everywhere else.
4443 70027 100         for (size_t i = 0; i < num_headers; i++) {
4444 70017           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)i, 0);
4445 70017 50         header_row[h_idx++] = (h_ptr && SvOK(*h_ptr)) ? SvPV_nolen(*h_ptr) : "";
    50          
4446             }
4447 10           print_string_row(aTHX_ fh, header_row, h_idx, sep);
4448 10           safefree(header_row);
4449 10           size_t num_rows = (size_t)(av_len(rows_av) + 1);
4450             // FIX (UTF-8/NUL safety): sort the key SVs themselves and look rows
4451             // up by SV (hv_fetch_ent) so UTF-8-flagged or NUL-containing outer
4452             // keys still match. sortsv+sv_cmp is plain string order, as before.
4453 10           sortsv(AvARRAY(rows_av), num_rows, Perl_sv_cmp);
4454 10           HV *restrict data_hv = (HV*)data_ref;
4455 10           const char **restrict row_data = safemalloc((num_headers + 1) * sizeof(char*));
4456 24 100         for (size_t i = 0; i < num_rows; i++) {
4457 16           size_t d_idx = 0;
4458 16           SV *restrict row_key_sv = *av_fetch(rows_av, (SSize_t)i, 0);
4459 16 50         if (inc_rownames) row_data[d_idx++] = SvPV_nolen(row_key_sv);
4460 16           HE *restrict inner_he = hv_fetch_ent(data_hv, row_key_sv, 0, 0);
4461 16 50         SV *restrict inner_sv = inner_he ? HeVAL(inner_he) : NULL;
4462 16 50         HV *restrict inner_hv = (inner_sv && SvROK(inner_sv)) ? (HV*)SvRV(inner_sv) : NULL;
    50          
4463 70047 100         for (size_t j = 0; j < num_headers; j++) {
4464 70033           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)j, 0);
4465 70033 50         SV *restrict h_sv = (h_ptr && SvOK(*h_ptr)) ? *h_ptr : NULL;
    50          
4466             // FIX (UTF-8/NUL safety): fetch by SV, not by raw bytes
4467 70033 50         HE *restrict cell_he = (inner_hv && h_sv) ? hv_fetch_ent(inner_hv, h_sv, 0, 0) : NULL;
    50          
4468 70033 100         SV *restrict cell_sv = cell_he ? HeVAL(cell_he) : NULL;
4469 70033 100         if (cell_sv && SvOK(cell_sv)) {
    100          
4470 70022 100         if (SvROK(cell_sv)) {
4471 2           PerlIO_close(fh);
4472 2           safefree(row_data);
4473 2 50         if (headers_av) SvREFCNT_dec(headers_av);
4474 2 50         if (rows_av) SvREFCNT_dec(rows_av);
4475 2           croak("write_table: Cannot write nested reference types to table\n");
4476             }
4477 70020           row_data[d_idx++] = SvPV_nolen(cell_sv);
4478             } else {
4479 11           row_data[d_idx++] = undef_val;
4480             }
4481             }
4482 14           print_string_row(aTHX_ fh, row_data, d_idx, sep);
4483             }
4484 8           safefree(row_data);
4485             // ----- Flat Hash -----
4486 42 100         } else if (is_flat_hash) {
4487 10           HV *restrict data_hv = (HV*)data_ref;
4488 11 100         if (col_names_sv && SvOK(col_names_sv)) {
    50          
4489 1           AV *restrict c_av = (AV*)SvRV(col_names_sv);
4490 1 50         for (SSize_t i = 0; i <= av_len(c_av); i++) {
4491 0           SV **restrict c = av_fetch(c_av, i, 0);
4492 0 0         if (c && SvOK(*c)) av_push(headers_av, newSVsv(*c));
    0          
4493             }
4494             } else {
4495             // FIX (UTF-8 safety): keep the key SVs (flags intact) and sort
4496             // them with sv_cmp instead of round-tripping through char*.
4497 9           unsigned int num_cols = hv_iterinit(data_hv);
4498 34 100         for (unsigned int i = 0; i < num_cols; i++) {
4499 25           HE *restrict ce = hv_iternext(data_hv);
4500 25           av_push(headers_av, newSVsv(hv_iterkeysv(ce)));
4501             }
4502 9 50         if (num_cols > 1)
4503 9           sortsv(AvARRAY(headers_av), num_cols, Perl_sv_cmp);
4504             }
4505 10           size_t num_headers = (size_t)(av_len(headers_av) + 1);
4506 10           const char **restrict header_row = safemalloc((num_headers + 1) * sizeof(char*));
4507 10           size_t h_idx = 0;
4508 10 100         if (inc_rownames) header_row[h_idx++] = "";
4509 35 100         for (size_t i = 0; i < num_headers; i++) {
4510 25           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)i, 0);
4511 25 50         header_row[h_idx++] = (h_ptr && SvOK(*h_ptr)) ? SvPV_nolen(*h_ptr) : "";
    50          
4512             }
4513 10           print_string_row(aTHX_ fh, header_row, h_idx, sep);
4514 10           safefree(header_row);
4515 10           const char **restrict row_data = safemalloc((num_headers + 1) * sizeof(char*));
4516 10           size_t d_idx = 0;
4517             // Give the single row a default numeric identifier if row names are on
4518 10 100         if (inc_rownames) row_data[d_idx++] = "1";
4519 35 100         for (size_t j = 0; j < num_headers; j++) {
4520 25           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)j, 0);
4521 25 50         SV *restrict h_sv = (h_ptr && SvOK(*h_ptr)) ? *h_ptr : NULL;
    50          
4522             // FIX (UTF-8/NUL safety): fetch by SV, not by raw bytes
4523 25 50         HE *restrict val_he = h_sv ? hv_fetch_ent(data_hv, h_sv, 0, 0) : NULL;
4524 25 50         SV *restrict val_sv = val_he ? HeVAL(val_he) : NULL;
4525             // FIX: a flat-hash cell holding a reference was stringified
4526             // (e.g. ARRAY(0x...)) instead of croaking like every other shape.
4527 25 50         if (val_sv && SvOK(val_sv)) {
    50          
4528 25 50         if (SvROK(val_sv)) {
4529 0           PerlIO_close(fh);
4530 0           safefree(row_data);
4531 0 0         if (headers_av) SvREFCNT_dec(headers_av);
4532 0           croak("write_table: Cannot write nested reference types to table\n");
4533             }
4534 25           row_data[d_idx++] = SvPV_nolen(val_sv);
4535             } else {
4536 0           row_data[d_idx++] = undef_val;
4537             }
4538             }
4539 10           print_string_row(aTHX_ fh, row_data, d_idx, sep);
4540 10           safefree(row_data);
4541             // ----- Hash of Arrays -----
4542 32 100         } else if (is_hoa) {
4543 24           HV *restrict data_hv = (HV*)data_ref;
4544 24           size_t max_rows = 0;
4545 24           hv_iterinit(data_hv);
4546             HE *restrict entry;
4547 75 100         while ((entry = hv_iternext(data_hv))) {
4548 51           AV *restrict arr = (AV*)SvRV(hv_iterval(data_hv, entry));
4549 51           size_t len = (size_t)(av_len(arr) + 1);
4550 51 100         if (len > max_rows) max_rows = len;
4551             }
4552 32 100         if (col_names_sv && SvOK(col_names_sv)) {
    50          
4553 8           AV *restrict c_av = (AV*)SvRV(col_names_sv);
4554             // FIX: size_t vs av_len() == -1 (empty col.names looped forever)
4555 24 100         for (SSize_t i = 0; i <= av_len(c_av); i++) {
4556 16           SV **restrict c = av_fetch(c_av, i, 0);
4557 16 50         if (c && SvOK(*c)) av_push(headers_av, newSVsv(*c));
    100          
4558             }
4559             } else {
4560             // FIX (UTF-8 safety): keep the key SVs (flags intact) and sort
4561             // them with sv_cmp instead of round-tripping through char*.
4562 16           unsigned int num_cols = hv_iterinit(data_hv);
4563 51 100         for (unsigned int i = 0; i < num_cols; i++) {
4564 35           HE *restrict ce = hv_iternext(data_hv);
4565 35           av_push(headers_av, newSVsv(hv_iterkeysv(ce)));
4566             }
4567 16 100         if (num_cols > 1)
4568 14           sortsv(AvARRAY(headers_av), num_cols, Perl_sv_cmp);
4569             }
4570 24 100         if (av_len(headers_av) < 0) {
4571             // FIX: this croak leaked the open filehandle and headers_av.
4572 1           PerlIO_close(fh);
4573 1           SvREFCNT_dec(headers_av);
4574 1           croak("Could not get headers in write_table");
4575             }
4576 23 100         if (inc_rownames && contains_nondigit(aTHX_ row_names_sv)) {
    100          
4577 1           rownames_col = SvPV_nolen(row_names_sv);
4578 1           AV *restrict filtered_headers = newAV();
4579             // FIX: size_t vs av_len() (same wrap as above if headers empty)
4580 3 100         for (SSize_t i = 0; i <= av_len(headers_av); i++) {
4581 2           SV **restrict h_ptr = av_fetch(headers_av, i, 0);
4582 2 50         if (!h_ptr || !*h_ptr) continue;
    50          
4583 2           SV *restrict h_sv = *h_ptr;
4584             // FIX (UTF-8 safety): sv_eq, not strcmp on raw bytes
4585 2 100         if (!sv_eq(h_sv, row_names_sv)) {
4586 1           av_push(filtered_headers, newSVsv(h_sv));
4587             }
4588             }
4589 1           SvREFCNT_dec(headers_av);
4590 1           headers_av = filtered_headers;
4591             }
4592 23           size_t num_headers = (size_t)(av_len(headers_av) + 1);
4593 23           const char **restrict header_row = safemalloc((num_headers + 1) * sizeof(char*));
4594 23           size_t h_idx = 0;
4595 23 100         if (inc_rownames) header_row[h_idx++] = "";
4596 72 100         for (size_t i = 0; i < num_headers; i++) {
4597 49           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)i, 0);
4598 49 50         header_row[h_idx++] = (h_ptr && SvOK(*h_ptr)) ? SvPV_nolen(*h_ptr) : "";
    50          
4599             }
4600 23           print_string_row(aTHX_ fh, header_row, h_idx, sep);
4601 23           safefree(header_row);
4602 23           const char **restrict row_data = safemalloc((num_headers + 1) * sizeof(char*));
4603             // FIX: numeric row labels used savepv() + safefree() every row; a
4604             // stack buffer reused per row does the same job with no allocation
4605             // (and removes the const-away cast in the old safefree call).
4606             char rn_buf[32];
4607 87 100         for (size_t i = 0; i < max_rows; i++) {
4608 64           size_t d_idx = 0;
4609 64 100         if (inc_rownames) {
4610 46 100         if (rownames_col) {
4611             // FIX (UTF-8 safety): fetch the row-name column by SV
4612 2           HE *restrict rn_arr_he = hv_fetch_ent(data_hv, row_names_sv, 0, 0);
4613 2 50         SV *restrict rn_arr_sv = rn_arr_he ? HeVAL(rn_arr_he) : NULL;
4614 4 50         if (rn_arr_sv && SvROK(rn_arr_sv)) {
    50          
4615 2           AV *restrict rn_arr = (AV*)SvRV(rn_arr_sv);
4616 2           SV **restrict rn_val_ptr = av_fetch(rn_arr, (SSize_t)i, 0);
4617 2 50         if (rn_val_ptr && SvOK(*rn_val_ptr)) {
    50          
4618 2 50         if (SvROK(*rn_val_ptr)) {
4619 0           PerlIO_close(fh);
4620 0           safefree(row_data);
4621 0 0         if (headers_av) SvREFCNT_dec(headers_av);
4622 0           croak("write_table: Cannot write nested reference types to table\n");
4623             }
4624 2           row_data[d_idx++] = SvPV_nolen(*rn_val_ptr);
4625             } else {
4626 0           row_data[d_idx++] = undef_val;
4627             }
4628             } else {
4629 0           row_data[d_idx++] = undef_val;
4630             }
4631             } else {
4632 44           snprintf(rn_buf, sizeof(rn_buf), "%lu", (unsigned long)(i + 1));
4633 44           row_data[d_idx++] = rn_buf;
4634             }
4635             }
4636 218 100         for (size_t j = 0; j < num_headers; j++) {
4637 154           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)j, 0);
4638 154 50         SV *restrict h_sv = (h_ptr && SvOK(*h_ptr)) ? *h_ptr : NULL;
    50          
4639             // FIX (UTF-8/NUL safety): fetch by SV, not by raw bytes
4640 154 50         HE *restrict arr_he = h_sv ? hv_fetch_ent(data_hv, h_sv, 0, 0) : NULL;
4641 154 100         SV *restrict arr_sv = arr_he ? HeVAL(arr_he) : NULL;
4642 304 100         if (arr_sv && SvROK(arr_sv)) {
    50          
4643 150           AV *restrict arr = (AV*)SvRV(arr_sv);
4644 150           SV **restrict cell_ptr = av_fetch(arr, (SSize_t)i, 0);
4645 150 100         if (cell_ptr && SvOK(*cell_ptr)) {
    100          
4646 100 50         if (SvROK(*cell_ptr)) {
4647 0           PerlIO_close(fh);
4648 0           safefree(row_data);
4649 0 0         if (headers_av) SvREFCNT_dec(headers_av);
4650 0           croak("write_table: Cannot write nested reference types to table\n");
4651             }
4652 100           row_data[d_idx++] = SvPV_nolen(*cell_ptr);
4653             } else {
4654 50           row_data[d_idx++] = undef_val;
4655             }
4656             } else {
4657 4           row_data[d_idx++] = undef_val;
4658             }
4659             }
4660 64           print_string_row(aTHX_ fh, row_data, d_idx, sep);
4661             }
4662 23           safefree(row_data);
4663 8 50         } else if (is_aoh) { // ----- Array of Hashes
4664 8           AV *restrict data_av = (AV*)data_ref;
4665 8           size_t num_rows = (size_t)(av_len(data_av) + 1);
4666 11 100         if (col_names_sv && SvOK(col_names_sv)) {
    50          
4667 3           AV *restrict c_av = (AV*)SvRV(col_names_sv);
4668             // FIX: size_t vs av_len() == -1 (empty col.names looped forever)
4669 5 100         for (SSize_t i = 0; i <= av_len(c_av); i++) {
4670 2           SV **restrict c = av_fetch(c_av, i, 0);
4671 2 50         if (c && SvOK(*c)) av_push(headers_av, newSVsv(*c));
    50          
4672             }
4673             } else {
4674 5           HV *restrict col_map = newHV();
4675 25 100         for (size_t i = 0; i < num_rows; i++) {
4676 20           SV **restrict row_ptr = av_fetch(data_av, (SSize_t)i, 0);
4677 20 50         if (row_ptr && SvROK(*row_ptr)) {
    50          
4678 20           HV *restrict row_hv = (HV*)SvRV(*row_ptr);
4679 20           hv_iterinit(row_hv);
4680             HE *restrict entry;
4681 51 100         while ((entry = hv_iternext(row_hv))) {
4682 31           hv_store_ent(col_map, hv_iterkeysv(entry), newSViv(1), 0);
4683             }
4684             }
4685             }
4686 5           unsigned num_cols = hv_iterinit(col_map);
4687             // FIX (UTF-8 safety): keep the key SVs (flags intact) and sort
4688             // them with sv_cmp instead of round-tripping through char*.
4689 19 100         for (unsigned int i = 0; i < num_cols; i++) {
4690 14           HE *restrict ce = hv_iternext(col_map);
4691 14           av_push(headers_av, newSVsv(hv_iterkeysv(ce)));
4692             }
4693 5 100         if (num_cols > 1)
4694 4           sortsv(AvARRAY(headers_av), num_cols, Perl_sv_cmp);
4695 5           SvREFCNT_dec(col_map);
4696             }
4697 8 100         if (inc_rownames && contains_nondigit(aTHX_ row_names_sv)) {
    100          
4698 1           rownames_col = SvPV_nolen(row_names_sv);
4699 1           AV *restrict filtered_headers = newAV();
4700             // FIX: size_t vs av_len() (same wrap as above if headers empty)
4701 1 50         for (SSize_t i = 0; i <= av_len(headers_av); i++) {
4702 0           SV **restrict h_ptr = av_fetch(headers_av, i, 0);
4703 0 0         if (!h_ptr || !*h_ptr) continue;
    0          
4704 0           SV *restrict h_sv = *h_ptr;
4705             // FIX (UTF-8 safety): sv_eq, not strcmp on raw bytes
4706 0 0         if (!sv_eq(h_sv, row_names_sv)) {
4707 0           av_push(filtered_headers, newSVsv(h_sv));
4708             }
4709             }
4710 1           SvREFCNT_dec(headers_av);
4711 1           headers_av = filtered_headers;
4712             }
4713 8           size_t num_headers = (size_t)(av_len(headers_av) + 1);
4714 8           const char **restrict header_row = safemalloc((num_headers + 1) * sizeof(char*));
4715 8           size_t h_idx = 0;
4716 8 100         if (inc_rownames) header_row[h_idx++] = "";
4717 24 100         for (size_t i = 0; i < num_headers; i++) {
4718 16           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)i, 0);
4719 16 50         header_row[h_idx++] = (h_ptr && SvOK(*h_ptr)) ? SvPV_nolen(*h_ptr) : "";
    50          
4720             }
4721 8           print_string_row(aTHX_ fh, header_row, h_idx, sep);
4722 8           safefree(header_row);
4723 8           const char **restrict row_data = safemalloc((num_headers + 1) * sizeof(char*));
4724             char rn_buf[32]; // FIX: replaces per-row savepv/safefree (see HoA)
4725 34 100         for (size_t i = 0; i < num_rows; i++) {
4726 26           size_t d_idx = 0;
4727 26           SV **restrict row_ptr = av_fetch(data_av, (SSize_t)i, 0);
4728 26 50         HV *restrict row_hv = (row_ptr && SvROK(*row_ptr)) ? (HV*)SvRV(*row_ptr) : NULL;
    50          
4729 26 100         if (inc_rownames) {
4730 21 100         if (rownames_col) {
4731             // FIX (UTF-8 safety): fetch the row-name cell by SV
4732 2 50         HE *restrict rn_he = row_hv ? hv_fetch_ent(row_hv, row_names_sv, 0, 0) : NULL;
4733 2 50         SV *restrict rn_sv = rn_he ? HeVAL(rn_he) : NULL;
4734 2 50         if (rn_sv && SvOK(rn_sv)) {
    50          
4735 2 50         if (SvROK(rn_sv)) {
4736 0           PerlIO_close(fh);
4737 0           safefree(row_data);
4738 0 0         if (headers_av) SvREFCNT_dec(headers_av);
4739 0           croak("write_table: Cannot write nested reference types to table\n");
4740             }
4741 2           row_data[d_idx++] = SvPV_nolen(rn_sv);
4742             } else {
4743 0           row_data[d_idx++] = undef_val;
4744             }
4745             } else {
4746 19           snprintf(rn_buf, sizeof(rn_buf), "%lu", (unsigned long)(i + 1));
4747 19           row_data[d_idx++] = rn_buf;
4748             }
4749             }
4750 65 100         for (size_t j = 0; j < num_headers; j++) {
4751 39           SV **restrict h_ptr = av_fetch(headers_av, (SSize_t)j, 0);
4752 39 50         SV *restrict h_sv = (h_ptr && SvOK(*h_ptr)) ? *h_ptr : NULL;
    50          
4753             // FIX (UTF-8/NUL safety): fetch by SV, not by raw bytes
4754 39 50         HE *restrict cell_he = (row_hv && h_sv) ? hv_fetch_ent(row_hv, h_sv, 0, 0) : NULL;
    50          
4755 39 100         SV *restrict cell_sv = cell_he ? HeVAL(cell_he) : NULL;
4756 39 100         if (cell_sv && SvOK(cell_sv)) {
    100          
4757 34 50         if (SvROK(cell_sv)) {
4758 0           PerlIO_close(fh);
4759 0           safefree(row_data);
4760 0 0         if (headers_av) SvREFCNT_dec(headers_av);
4761 0           croak("write_table: Cannot write nested reference types to table\n");
4762             }
4763 34           row_data[d_idx++] = SvPV_nolen(cell_sv);
4764             } else {
4765 5           row_data[d_idx++] = undef_val;
4766             }
4767             }
4768 26           print_string_row(aTHX_ fh, row_data, d_idx, sep);
4769             }
4770 8           safefree(row_data);
4771             }
4772 49 50         if (headers_av) SvREFCNT_dec(headers_av);
4773 49 100         if (rows_av) SvREFCNT_dec(rows_av);
4774 49           PerlIO_close(fh);
4775 49           XSRETURN_EMPTY;
4776             }
4777              
4778             SV* _parse_csv_file(char* file, const char* sep_str, const char* comment_str, SV* callback = &PL_sv_undef)
4779             PREINIT:
4780             /* Declarations only -- C declarations cost nothing. ALLOCATIONS are
4781             * deferred into CODE, after every croak-able validation, so that no
4782             * error path can leak. (The old version allocated current_row, field,
4783             * and data in INIT: the open-failure croak leaked all three, and a die
4784             * inside the callback leaked those plus line_sv plus the open handle.) */
4785             PerlIO *restrict fp;
4786 548           AV *restrict data = NULL;
4787 548           AV *current_row = NULL;
4788 548           SV *restrict field = NULL;
4789 548           SV *restrict line_sv = NULL;
4790 548           bool in_quotes = 0, post_quote = 0, use_cb = 0;
4791             size_t sep_len, comment_len;
4792 548           char sep0 = 0;
4793             CODE:
4794             /* ---- validation: nothing is allocated yet, so croaks are leak-free */
4795 548 100         if (SvOK(callback)) {
4796 547 100         if (SvROK(callback) && SvTYPE(SvRV(callback)) == SVt_PVCV)
    50          
4797 546           use_cb = 1;
4798             else
4799             /* FIX: a defined non-CODE callback used to be silently ignored
4800             * (falling back to slurp mode); now it is an error. */
4801 1           croak("_parse_csv_file: callback must be a CODE reference");
4802             }
4803 547 50         sep_len = sep_str ? strlen(sep_str) : 0;
4804 547 50         comment_len = comment_str ? strlen(comment_str) : 0;
4805 547 50         sep0 = sep_len ? sep_str[0] : 0;
4806 547           fp = PerlIO_open(file, "r");
4807 547 50         if (!fp)
4808 0           croak("Could not open file '%s'", file);
4809             /* ---- from here on, a die inside the callback must not leak anything:
4810             * tie every long-lived resource to the save stack, which croak unwinds */
4811 547           ENTER;
4812 547           SAVEDESTRUCTOR_X(S_pclose, fp); /* fp closes on normal LEAVE or die */
4813 547           line_sv = newSV(128);
4814 547           SAVEFREESV(line_sv);
4815 547           field = newSVpvs("");
4816 547           SAVEFREESV(field);
4817 547 100         if (!use_cb)
4818 1           data = newAV(); /* slurp mode runs no perl code: no die can reach it */
4819 547           current_row = newAV(); /* covered by the ownership dance in S_emit_row */
4820             /* The wrapper strips a leading comment marker from the HEADER itself, so
4821             * the first content line must reach the callback even when it begins with
4822             * the comment string. Comment-skipping therefore starts only after the
4823             * first row has been emitted. (In the old code the header-strip logic in
4824             * read_table was dead: the parser ate any '#'-prefixed header first.) */
4825 547           bool seen_first = 0;
4826 7330 100         while (sv_gets(line_sv, fp, 0) != NULL) {
4827 6789           char *restrict line = SvPVX(line_sv);
4828 6789           size_t len = SvCUR(line_sv);
4829             // chomp \n and a preceding \r (CRLF)
4830 6789 50         if (len && line[len-1] == '\n') {
    100          
4831 6788           len--;
4832 6788 100         if (len && line[len-1] == '\r')
    100          
4833 4930           len--;
4834             }
4835 6789 100         if (!in_quotes) {
4836             // skip blank / whitespace-only lines
4837 6785           size_t k = 0;
4838 6790 100         while (k < len && (line[k] == ' ' || line[k] == '\t'))
    100          
    100          
4839 5           k++;
4840 6785 100         if (k == len)
4841 2           continue;
4842             // skip comment lines -- but never the first content line
4843 6783 100         if (seen_first && comment_len && len >= comment_len
    50          
    50          
4844 6236 100         && memcmp(line, comment_str, comment_len) == 0)
4845 1           continue;
4846             }
4847             // ---- core parser: chunked copies instead of per-char appends
4848             {
4849 6786           size_t i = 0;
4850 105835 100         while (i < len) {
4851 105806 100         if (in_quotes) {
4852             /* Everything up to the next quote is literal -- including
4853             * \r, which the old parser wrongly stripped inside quotes
4854             * (breaking round-trips of values like "x\ry"). */
4855 14896           const char *restrict q = (const char *)memchr(line + i, '"', len - i);
4856 14896 100         if (!q) {
4857 4           sv_catpvn(field, line + i, len - i);
4858 4           i = len;
4859 4           break;
4860             }
4861             {
4862 14892           size_t run = (size_t)(q - (line + i));
4863 14892 100         if (run)
4864 14884           sv_catpvn(field, line + i, run);
4865 14892           i += run; /* i is now at the quote */
4866             }
4867 14892 100         if (i + 1 < len && line[i+1] == '"') {
    100          
4868 6           sv_catpvn(field, "\"", 1); /* "" -> literal " */
4869 6           i += 2;
4870             } else {
4871 14886           in_quotes = 0;
4872 14886           post_quote = 1;
4873 14886           i += 1;
4874             }
4875             } else {
4876             /* copy a run of ordinary bytes in one shot */
4877 90910           size_t start = i;
4878 293981 100         while (i < len) {
4879 287228           const char c = line[i];
4880 287228 100         if (c == '"' || c == '\r')
    50          
4881             break;
4882 272342 100         if (c == sep0 && sep_len && (len - i) >= sep_len
    50          
    50          
4883 69271 50         && (sep_len == 1
4884 0 0         || memcmp(line + i, sep_str, sep_len) == 0))
4885             break;
4886 203071           i++;
4887             }
4888 90910 100         if (i > start)
4889 61133           sv_catpvn(field, line + start, i - start);
4890 90910 100         if (i >= len)
4891 6753           break;
4892             {
4893 84157           const char c = line[i];
4894 84157 100         if (c == '"') {
4895             /* lenient: a quote after a closed quote is dropped,
4896             * matching the old parser */
4897 14886 50         if (!post_quote)
4898 14886           in_quotes = 1;
4899 14886           i++;
4900 69271 50         } else if (c == '\r') {
4901 0           i++; /* stray CR outside quotes: ignored, as before */
4902             } else {
4903             /* separator */
4904 69271           av_push(current_row, newSVsv(field));
4905 69271           sv_setpvs(field, "");
4906 69271           post_quote = 0;
4907 69271           i += sep_len;
4908             }
4909             }
4910             }
4911             }
4912             }
4913 6786 100         if (in_quotes) {
4914             /* open quote at EOL: logical record continues on the next line */
4915 4           sv_catpvn(field, "\n", 1);
4916             } else {
4917 6782           post_quote = 0;
4918 6782           S_emit_row(aTHX_ ¤t_row, field, use_cb, callback, data);
4919 6776           seen_first = 1;
4920             }
4921             }
4922 541 50         if (in_quotes) {/* EOF with an unterminated quote: flush the trailing record */
4923 0           S_emit_row(aTHX_ ¤t_row, field, use_cb, callback, data);
4924             }
4925 541           SvREFCNT_dec((SV*)current_row);// the spare row S_emit_row left behind
4926 541           LEAVE;// closes fp, frees line_sv and field
4927 541 100         if (use_cb) {
4928 540           RETVAL = newSV(0); // fresh undef; mortalizing immortal &PL_sv_undef underflows it on perl<5.18
4929             } else {
4930 1           RETVAL = newRV_noinc((SV*)data);
4931             }
4932             OUTPUT:
4933             RETVAL
4934              
4935             SV* cov(SV* x_sv, SV* y_sv, const char* method = "pearson")
4936             CODE:
4937             {
4938             // 1. Validate inputs are Array References
4939 4 50         if (!SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV) {
    50          
4940 0           croak("cov: first argument 'x' must be an ARRAY reference");
4941             }
4942 4 50         if (!SvROK(y_sv) || SvTYPE(SvRV(y_sv)) != SVt_PVAV) {
    50          
4943 0           croak("cov: second argument 'y' must be an ARRAY reference");
4944             }
4945              
4946             // 2. Validate method argument
4947 4 100         if (strcmp(method, "pearson") != 0 &&
4948 2 100         strcmp(method, "spearman") != 0 &&
4949 1 50         strcmp(method, "kendall") != 0) {
4950 0           croak("cov: unknown method '%s' (use 'pearson', 'spearman', or 'kendall')", method);
4951             }
4952              
4953 4           AV *restrict x_av = (AV*)SvRV(x_sv);
4954 4           AV *restrict y_av = (AV*)SvRV(y_sv);
4955 4           size_t nx = av_len(x_av) + 1;
4956 4           size_t ny = av_len(y_av) + 1;
4957              
4958 4 50         if (nx != ny) {
4959 0           croak("cov: incompatible dimensions (x has %lu, y has %lu)",
4960             (unsigned long)nx, (unsigned long)ny);
4961             }
4962              
4963             // 3. Extract Valid Pairwise Data
4964             // Allocate temporary C arrays for numeric processing
4965 4           NV *restrict x_val = (NV*)safemalloc(nx * sizeof(NV));
4966 4           NV *restrict y_val = (NV*)safemalloc(nx * sizeof(NV));
4967 4           size_t n = 0;
4968              
4969 24 100         for (size_t i = 0; i < nx; i++) {
4970 20           SV **restrict x_tv = av_fetch(x_av, i, 0);
4971 20           SV **restrict y_tv = av_fetch(y_av, i, 0);
4972              
4973             // Extract numeric values, defaulting to NAN for missing/invalid data
4974 20 50         NV xv = (x_tv && SvOK(*x_tv) && looks_like_number(*x_tv)) ? SvNV(*x_tv) : NAN;
    50          
    50          
4975 20 50         NV yv = (y_tv && SvOK(*y_tv) && looks_like_number(*y_tv)) ? SvNV(*y_tv) : NAN;
    50          
    50          
4976              
4977             // Pairwise complete observations (skips NAs seamlessly like R)
4978 20 50         if (!isnan(xv) && !isnan(yv)) {
    50          
4979 20           x_val[n] = xv;
4980 20           y_val[n] = yv;
4981 20           n++;
4982             }
4983             }
4984              
4985             // 4. Handle edge cases where data is too sparse
4986 4 50         if (n < 2) {
4987 0           Safefree(x_val); Safefree(y_val);
4988 0           RETVAL = newSVnv(NAN);
4989             } else {
4990 4           NV ans = 0.0;
4991             // 5. Algorithm routing
4992 4 100         if (strcmp(method, "kendall") == 0) {
4993             // R's default cov(..., method="kendall") iterates the full n x n space
4994 6 100         for (size_t i = 0; i < n; i++) {
4995 30 100         for (size_t j = 0; j < n; j++) {
4996 25           int sx = (x_val[i] > x_val[j]) - (x_val[i] < x_val[j]);
4997 25           int sy = (y_val[i] > y_val[j]) - (y_val[i] < y_val[j]);
4998 25           ans += (NV)(sx * sy);
4999             }
5000             }
5001             } else {
5002 3           NV mean_x = 0.0, mean_y = 0.0, cov_sum = 0.0;
5003 3 100         if (strcmp(method, "spearman") == 0) {
5004             // Spearman: Rank the data first, then run standard covariance
5005 1           NV *restrict rx = (NV*)safemalloc(n * sizeof(NV));
5006 1           NV *restrict ry = (NV*)safemalloc(n * sizeof(NV));
5007             // Uses your existing rank_data() helper from LikeR.xs
5008 1           rank_data(x_val, rx, n);
5009 1           rank_data(y_val, ry, n);
5010 6 100         for (size_t i = 0; i < n; i++) {
5011 5           NV dx = rx[i] - mean_x;
5012 5           mean_x += dx / (i + 1);
5013 5           NV dy = ry[i] - mean_y;
5014 5           mean_y += dy / (i + 1);
5015 5           cov_sum += dx * (ry[i] - mean_y);
5016             }
5017 1           Safefree(rx); Safefree(ry);
5018             } else {
5019             // Pearson: Welford's Single-Pass Covariance Algorithm
5020 12 100         for (size_t i = 0; i < n; i++) {
5021 10           NV dx = x_val[i] - mean_x;
5022 10           mean_x += dx / (i + 1);
5023 10           NV dy = y_val[i] - mean_y;
5024 10           mean_y += dy / (i + 1);
5025 10           cov_sum += dx * (y_val[i] - mean_y);
5026             }
5027             }
5028              
5029             // Unbiased Sample Covariance (N - 1) for Pearson & Spearman
5030 3           ans = cov_sum / (n - 1);
5031             }
5032 4           Safefree(x_val); Safefree(y_val);
5033 4           RETVAL = newSVnv(ans);
5034             }
5035             }
5036             OUTPUT:
5037             RETVAL
5038              
5039             SV *glm(...)
5040             CODE:
5041             {
5042 11           const char *restrict formula = NULL;
5043 11           SV *restrict data_sv = NULL;
5044 11           const char *restrict family_str = "gaussian";
5045             char f_cpy[512];
5046             char *restrict src, *restrict dst, *restrict tilde, *restrict lhs, *restrict rhs, *restrict chunk;
5047              
5048 11           char **restrict terms = NULL, **restrict uniq_terms = NULL, **restrict exp_terms = NULL;
5049 11           bool *restrict is_dummy = NULL;
5050 11           char **restrict dummy_base = NULL, **restrict dummy_level = NULL;
5051 11           unsigned int term_cap = 64, exp_cap = 64, num_terms = 0, num_uniq = 0, p = 0, p_exp = 0;
5052 11           size_t n = 0, valid_n = 0, i;
5053 11           bool has_intercept = TRUE, converged = FALSE, boundary = FALSE;
5054 11           unsigned int iter = 0, max_iter = 25, final_rank = 0, df_res = 0;
5055 11           NV deviance_old = 0.0, deviance_new = 0.0, null_dev = 0.0, aic = 0.0;
5056 11           NV dispersion = 0.0, epsilon = 1e-8;
5057              
5058 11           char **restrict row_names = NULL;
5059 11           char **restrict valid_row_names = NULL;
5060 11           HV **restrict row_hashes = NULL;
5061 11           HV *restrict data_hoa = NULL;
5062 11           SV *restrict ref = NULL;
5063              
5064 11           NV *restrict X = NULL, *restrict Y = NULL, *restrict mu = NULL, *restrict eta = NULL;
5065 11           NV *restrict W = NULL, *restrict Z = NULL, *restrict beta = NULL, *restrict beta_old = NULL;
5066 11           bool *restrict aliased = NULL;
5067 11           NV *restrict XtWX = NULL, *restrict XtWZ = NULL;
5068              
5069             HV *restrict res_hv, *restrict coef_hv, *restrict fitted_hv, *restrict resid_hv, *restrict summary_hv;
5070             AV *restrict terms_av;
5071             HE *restrict entry;
5072              
5073 11 50         if (items % 2 != 0) croak("Usage: glm(formula => 'am ~ wt + hp', data => \\%mtcars)");
5074              
5075 42 100         for (unsigned short i_arg = 0; i_arg < items; i_arg += 2) {
5076 31           const char *restrict key = SvPV_nolen(ST(i_arg));
5077 31           SV *restrict val = ST(i_arg + 1);
5078 31 100         if (strEQ(key, "formula")) formula = SvPV_nolen(val);
5079 20 100         else if (strEQ(key, "data")) data_sv = val;
5080 9 50         else if (strEQ(key, "family")) family_str = SvPV_nolen(val);
5081 0           else croak("glm: unknown argument '%s'", key);
5082             }
5083 11 50         if (!formula) croak("glm: formula is required");
5084 11 50         if (!data_sv || !SvROK(data_sv)) croak("glm: data is required and must be a reference");
    50          
5085              
5086 11           bool is_binomial = (strcmp(family_str, "binomial") == 0);
5087 11           bool is_gaussian = (strcmp(family_str, "gaussian") == 0);
5088 11 100         if (!is_binomial && !is_gaussian) croak("glm: unsupported family '%s'", family_str);
    50          
5089              
5090 11           Newx(terms, term_cap, char*); Newx(uniq_terms, term_cap, char*);
5091 11           Newx(exp_terms, exp_cap, char*); Newx(is_dummy, exp_cap, bool);
5092 11           Newx(dummy_base, exp_cap, char*); Newx(dummy_level, exp_cap, char*);
5093              
5094 11           src = (char*restrict)formula; dst = f_cpy;
5095 161 100         while (*src && (dst - f_cpy < 511)) { if (!isspace(*src)) { *dst++ = *src; } src++; }
    100          
    50          
5096 11           *dst = '\0';
5097              
5098 11           tilde = strchr(f_cpy, '~');
5099 11 50         if (!tilde) croak("glm: invalid formula, missing '~'");
5100 11           *tilde = '\0';
5101 11           lhs = f_cpy;
5102 11           rhs = tilde + 1;
5103             char *restrict minus_one;
5104 11 100         if ((minus_one = strstr(rhs, "-1")) != NULL) {
5105 1           has_intercept = FALSE;
5106 1           memmove(
5107 1           minus_one, minus_one + 2, strlen(minus_one + 2) + 1
5108             );
5109             }
5110 11           char *restrict minus1 = strstr(rhs, "-1");
5111 11 50         if (minus1) {
5112 0           has_intercept = FALSE;
5113 0           memmove(
5114 0           minus1, minus1 + 2, strlen(minus1 + 2) + 1
5115             );
5116             }
5117 11 100         if (has_intercept) terms[num_terms++] = savepv("Intercept");
5118              
5119 11           chunk = strtok(rhs, "+");
5120 29 100         while (chunk != NULL) {
5121 18 50         if (num_terms >= term_cap - 3) {
5122 0           term_cap *= 2;
5123 0           Renew(terms, term_cap, char*); Renew(uniq_terms, term_cap, char*);
5124             }
5125 18 50         if (strcmp(chunk, "1") == 0 || strcmp(chunk, "-1") == 0) {
    50          
5126 0           chunk = strtok(NULL, "+");
5127 0           continue;
5128             }
5129 18           char *restrict star = strchr(chunk, '*');
5130 18 50         if (star) {
5131 0           *star = '\0';
5132 0           char *restrict left = chunk; char *restrict right = star + 1;
5133 0 0         char *restrict c_l = strchr(left, '^'); if (c_l && strncmp(left, "I(", 2) != 0) *c_l = '\0';
    0          
5134 0 0         char *restrict c_r = strchr(right, '^'); if (c_r && strncmp(right, "I(", 2) != 0) *c_r = '\0';
    0          
5135 0           terms[num_terms++] = savepv(left);
5136 0           terms[num_terms++] = savepv(right);
5137 0           size_t inter_len = strlen(left) + strlen(right) + 2;
5138 0           terms[num_terms] = (char*)safemalloc(inter_len);
5139 0           snprintf(terms[num_terms++], inter_len, "%s:%s", left, right);
5140             } else {
5141 18           char *restrict c_chunk = strchr(chunk, '^');
5142 18 50         if (c_chunk && strncmp(chunk, "I(", 2) != 0) *c_chunk = '\0';
    0          
5143 18           terms[num_terms++] = savepv(chunk);
5144             }
5145 18           chunk = strtok(NULL, "+");
5146             }
5147              
5148 39 100         for (i = 0; i < num_terms; i++) {
5149 28           bool found = FALSE;
5150 52 100         for (size_t j = 0; j < num_uniq; j++) {
5151 24 50         if (strcmp(terms[i], uniq_terms[j]) == 0) { found = TRUE; break; }
5152             }
5153 28 50         if (!found) uniq_terms[num_uniq++] = savepv(terms[i]);
5154             }
5155 11           p = num_uniq;
5156 11           ref = SvRV(data_sv);
5157 11 50         if (SvTYPE(ref) == SVt_PVHV) {
5158 11           HV*restrict hv = (HV*)ref;
5159 11 50         if (hv_iterinit(hv) == 0) croak("glm: Data hash is empty");
5160 11           entry = hv_iternext(hv);
5161 11 50         if (entry) {
5162 11           SV*restrict val = hv_iterval(hv, entry);
5163 11 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) {
    100          
5164 6           data_hoa = hv;
5165 6           n = av_len((AV*)SvRV(val)) + 1;
5166 6 50         Newx(row_names, n, char*);
5167 6           {
5168             /* Row labels: use an explicit row-names column if the
5169             * caller supplied one (R carries these as "row.names");
5170             * otherwise fall back to 1-based integer labels. */
5171             static const char *const rn_keys[] =
5172             { "row.names", "_row", "rownames", ".rownames" };
5173 6           AV *restrict rn_av = NULL;
5174 26 100         for (size_t k = 0; k < sizeof rn_keys / sizeof rn_keys[0]; k++) {
5175 21           SV **restrict rn = hv_fetch(hv, rn_keys[k],
5176             (I32)strlen(rn_keys[k]), 0);
5177 21 100         if (rn && *rn && SvROK(*rn)
    50          
    50          
5178 1 50         && SvTYPE(SvRV(*rn)) == SVt_PVAV) {
5179 1           rn_av = (AV*)SvRV(*rn);
5180 1           break;
5181             }
5182             }
5183 140 100         for (i = 0; i < n; i++) {
5184 134           SV **restrict nm = rn_av
5185 134 100         ? av_fetch(rn_av, (SSize_t)i, 0) : NULL;
5186 134 100         if (nm && *nm && SvOK(*nm)) {
    50          
    50          
5187 3           STRLEN l; const char *restrict s = SvPV(*nm, l);
5188 3           row_names[i] = savepvn(s, l);
5189             } else {
5190             char buf[32];
5191 131           snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i + 1));
5192 131           row_names[i] = savepv(buf);
5193             }
5194             }
5195             }
5196 5 50         } else if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) {
    50          
5197 5           n = hv_iterinit(hv);
5198 5 50         Newx(row_names, n, char*); Newx(row_hashes, n, HV*);
    50          
5199 5           i = 0;
5200 165 100         while ((entry = hv_iternext(hv))) {
5201             I32 len;
5202 160           row_names[i] = savepv(hv_iterkey(entry, &len));
5203 160           row_hashes[i] = (HV*)SvRV(hv_iterval(hv, entry));
5204 160           i++;
5205             }
5206 0           } else croak("glm: Hash values must be ArrayRefs (HoA) or HashRefs (HoH)");
5207             }
5208 0 0         } else if (SvTYPE(ref) == SVt_PVAV) {
5209 0           AV*restrict av = (AV*)ref;
5210 0           n = av_len(av) + 1;
5211 0 0         Newx(row_names, n, char*); Newx(row_hashes, n, HV*);
    0          
5212 0 0         for (i = 0; i < n; i++) {
5213 0           SV**restrict val = av_fetch(av, i, 0);
5214 0 0         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVHV) {
    0          
    0          
5215 0           HV *restrict rh = (HV*)SvRV(*val);
5216 0           row_hashes[i] = rh;
5217             /* Row label: a "row.names" (etc.) field on the row, else int. */
5218             {
5219             static const char *const rn_keys[] =
5220             { "row.names", "_row", "rownames", ".rownames" };
5221 0           SV **restrict nm = NULL;
5222 0 0         for (size_t k = 0; k < sizeof rn_keys / sizeof rn_keys[0]; k++) {
5223 0           nm = hv_fetch(rh, rn_keys[k], (I32)strlen(rn_keys[k]), 0);
5224 0 0         if (nm && *nm && SvOK(*nm)) break;
    0          
    0          
5225 0           nm = NULL;
5226             }
5227 0 0         if (nm && *nm && SvOK(*nm)) {
    0          
    0          
5228 0           STRLEN l; const char *restrict s = SvPV(*nm, l);
5229 0           row_names[i] = savepvn(s, l);
5230             } else {
5231             char buf[32];
5232 0           snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i + 1));
5233 0           row_names[i] = savepv(buf);
5234             }
5235             }
5236             } else {
5237 0 0         for (size_t k = 0; k < i; k++) Safefree(row_names[k]);
5238 0           Safefree(row_names); Safefree(row_hashes);
5239 0           croak("glm: Array values must be HashRefs (AoH)");
5240             }
5241             }
5242 0           } else croak("glm: Data must be an Array or Hash reference");
5243 39 100         for (size_t j = 0; j < p; j++) {
5244 28 50         if (p_exp + 32 >= exp_cap) {
5245 0           exp_cap *= 2;
5246 0           Renew(exp_terms, exp_cap, char*); Renew(is_dummy, exp_cap, bool);
5247 0           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
5248             }
5249 28 100         if (strcmp(uniq_terms[j], "Intercept") == 0) {
5250 10           exp_terms[p_exp] = savepv("Intercept"); is_dummy[p_exp] = FALSE; p_exp++; continue;
5251             }
5252 18 100         if (is_column_categorical(aTHX_ data_hoa, row_hashes, n, uniq_terms[j])) {
5253 1           char **restrict levels = NULL; size_t num_levels = 0, levels_cap = 8;
5254 1 50         Newx(levels, levels_cap, char*);
5255 61 100         for (i = 0; i < n; i++) {
5256 60           char*restrict str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, uniq_terms[j]);
5257 60 50         if (str_val) {
5258 60           bool found = FALSE;
5259 90 100         for (size_t l = 0; l < num_levels; l++) {
5260 88 100         if (strcmp(levels[l], str_val) == 0) { found = TRUE; break; }
5261             }
5262 60 100         if (!found) {
5263 2 50         if (num_levels >= levels_cap) { levels_cap *= 2; Renew(levels, levels_cap, char*); }
    0          
5264 2           levels[num_levels++] = savepv(str_val);
5265             }
5266 60           Safefree(str_val);
5267             }
5268             }
5269 1 50         if (num_levels > 0) {
5270 2 100         for (size_t l1 = 0; l1 < num_levels - 1; l1++) {
5271 2 100         for (size_t l2 = l1 + 1; l2 < num_levels; l2++) {
5272 1 50         if (strcmp(levels[l1], levels[l2]) > 0) {
5273 1           char *restrict tmp = levels[l1]; levels[l1] = levels[l2]; levels[l2] = tmp;
5274             }
5275             }
5276             }
5277 2 100         for (size_t l = 1; l < num_levels; l++) {
5278 1 50         if (p_exp >= exp_cap) {
5279 0           exp_cap *= 2;
5280 0           Renew(exp_terms, exp_cap, char*); Renew(is_dummy, exp_cap, bool);
5281 0           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
5282             }
5283 1           size_t t_len = strlen(uniq_terms[j]) + strlen(levels[l]) + 1;
5284 1           exp_terms[p_exp] = (char*)safemalloc(t_len);
5285 1           snprintf(exp_terms[p_exp], t_len, "%s%s", uniq_terms[j], levels[l]);
5286 1           is_dummy[p_exp] = TRUE; dummy_base[p_exp] = savepv(uniq_terms[j]); dummy_level[p_exp] = savepv(levels[l]);
5287 1           p_exp++;
5288             }
5289 3 100         for (size_t l = 0; l < num_levels; l++) Safefree(levels[l]);
5290 1           Safefree(levels);
5291             } else {
5292 0           Safefree(levels); exp_terms[p_exp] = savepv(uniq_terms[j]); is_dummy[p_exp] = FALSE; p_exp++;
5293             }
5294             } else {
5295 17           exp_terms[p_exp] = savepv(uniq_terms[j]); is_dummy[p_exp] = FALSE; p_exp++;
5296             }
5297             }
5298 11           p = p_exp;
5299              
5300 11 50         Newx(X, n * p, NV); Newx(Y, n, NV);
    50          
5301 11 50         Newx(valid_row_names, n, char*);
5302              
5303 305 100         for (size_t i = 0; i < n; i++) {
5304 294           NV y_val = evaluate_term(aTHX_ data_hoa, row_hashes, i, lhs);
5305 294 50         if (isnan(y_val)) { Safefree(row_names[i]); continue; }
5306              
5307 294           bool row_ok = TRUE;
5308 294           NV *restrict row_x = (NV*)safemalloc(p * sizeof(NV));
5309 1102 100         for (size_t j = 0; j < p; j++) {
5310 808 100         if (strcmp(exp_terms[j], "Intercept") == 0) {
5311 291           row_x[j] = 1.0;
5312 517 100         } else if (is_dummy[j]) {
5313 60           char* str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, dummy_base[j]);
5314 60 50         if (str_val) {
5315 60 100         row_x[j] = (strcmp(str_val, dummy_level[j]) == 0) ? 1.0 : 0.0;
5316 60           Safefree(str_val);
5317 0           } else { row_ok = FALSE; break; }
5318             } else {
5319 457           row_x[j] = evaluate_term(aTHX_ data_hoa, row_hashes, i, exp_terms[j]);
5320 457 50         if (isnan(row_x[j])) { row_ok = FALSE; break; }
5321             }
5322             }
5323 294 50         if (!row_ok) { Safefree(row_names[i]); Safefree(row_x); continue; }
5324 294           Y[valid_n] = y_val;
5325 1102 100         for (size_t j = 0; j < p; j++) X[valid_n * p + j] = row_x[j];
5326 294           valid_row_names[valid_n] = row_names[i];
5327 294           valid_n++;
5328 294           Safefree(row_x);
5329             }
5330 11           Safefree(row_names);
5331 11 50         if (valid_n < p) {
5332 0 0         Safefree(X); Safefree(Y); Safefree(valid_row_names); if (row_hashes) Safefree(row_hashes);
5333 0           croak("glm: 0 degrees of freedom (too many NAs or parameters > observations)");
5334             }
5335 11           mu = (NV*)safemalloc(valid_n * sizeof(NV)); eta = (NV*)safemalloc(valid_n * sizeof(NV));
5336 11           W = (NV*)safemalloc(valid_n * sizeof(NV)); Z = (NV*)safemalloc(valid_n * sizeof(NV));
5337 11           beta = (NV*)safemalloc(p * sizeof(NV)); beta_old = (NV*)safemalloc(p * sizeof(NV));
5338 11           aliased = (bool*)safemalloc(p * sizeof(bool));
5339 11           XtWX = (NV*)safemalloc(p * p * sizeof(NV)); XtWZ = (NV*)safemalloc(p * sizeof(NV));
5340 39 100         for (i = 0; i < p; i++) { beta[i] = 0.0; beta_old[i] = 0.0; }
5341 11           NV sum_y = 0.0;
5342 305 100         for (i = 0; i < valid_n; i++) sum_y += Y[i];
5343 11           NV mean_y = sum_y / valid_n;
5344 301 100         for (i = 0; i < valid_n; i++) {
5345 291 100         if (is_binomial) {
5346 37 100         if (Y[i] < 0.0 || Y[i] > 1.0) croak("glm: binomial family requires response between 0 and 1");
    50          
5347 36           mu[i] = (Y[i] + 0.5) / 2.0;
5348 36           eta[i] = log(mu[i] / (1.0 - mu[i]));
5349 36           NV dev = 0.0;
5350 36 100         if (Y[i] == 0.0) dev = -2.0 * log(1.0 - mu[i]);
5351 15 50         else if (Y[i] == 1.0) dev = -2.0 * log(mu[i]);
5352 0           else dev = 2.0 * (Y[i] * log(Y[i] / mu[i]) + (1.0 - Y[i]) * log((1.0 - Y[i]) / (1.0 - mu[i])));
5353 36           deviance_old += dev;
5354             } else {
5355 254           mu[i] = mean_y;
5356 254           eta[i] = mu[i];
5357             }
5358             }
5359 46 50         for (iter = 1; iter <= max_iter; iter++) {
5360 928 100         for (i = 0; i < valid_n; i++) {
5361 882 100         if (is_binomial) {
5362 380           NV varmu = mu[i] * (1.0 - mu[i]);
5363 380           NV mu_eta = varmu;
5364 380 100         if (varmu < 1e-10) varmu = 1e-10;
5365 380           Z[i] = eta[i] + (Y[i] - mu[i]) / mu_eta;
5366 380           W[i] = (mu_eta * mu_eta) / varmu;
5367             } else {
5368 502           W[i] = 1.0;
5369 502           Z[i] = Y[i];
5370             }
5371             }
5372 438 100         for (i = 0; i < p; i++) { XtWZ[i] = 0.0; for (size_t j = 0; j < p; j++) XtWX[i * p + j] = 0.0; }
    100          
5373 928 100         for (size_t k = 0; k < valid_n; k++) {
5374 882           NV w = W[k], z = Z[k];
5375 3310 100         for (i = 0; i < p; i++) {
5376 2428           XtWZ[i] += X[k * p + i] * w * z;
5377 2428           NV xw = X[k * p + i] * w;
5378 9282 100         for (size_t j = 0; j < p; j++) XtWX[i * p + j] += xw * X[k * p + j];
5379             }
5380             }
5381 46           final_rank = sweep_matrix_ols(XtWX, p, aliased);
5382 157 100         for (i = 0; i < p; i++) {
5383 111 50         if (aliased[i]) { beta[i] = NAN; } else {
5384 111           NV sum = 0.0;
5385 392 50         for (size_t j = 0; j < p; j++) if (!aliased[j]) sum += XtWX[i * p + j] * XtWZ[j];
    100          
5386 111           beta[i] = sum;
5387             }
5388             }
5389 46           boundary = FALSE;
5390 506 100         for (unsigned short int half = 0; half < 10; half++) {
5391 460           deviance_new = 0.0;
5392 9280 100         for (i = 0; i < valid_n; i++) {
5393 8820           NV linear_pred = 0.0;
5394 33100 50         for (size_t j = 0; j < p; j++) if (!aliased[j]) linear_pred += X[i * p + j] * beta[j];
    100          
5395 8820           eta[i] = linear_pred;
5396 8820 100         if (is_binomial) {
5397 3800           mu[i] = 1.0 / (1.0 + exp(-eta[i]));
5398 3800 50         if (mu[i] < 10 * DBL_EPSILON) mu[i] = 10 * DBL_EPSILON;
5399 3800 50         if (mu[i] > 1.0 - 10 * DBL_EPSILON) mu[i] = 1.0 - 10 * DBL_EPSILON;
5400 3800           NV dev = 0.0;
5401 3800 100         if (Y[i] == 0.0) dev = -2.0 * log(1.0 - mu[i]);
5402 1630 50         else if (Y[i] == 1.0) dev = -2.0 * log(mu[i]);
5403 0           else dev = 2.0 * (Y[i] * log(Y[i] / mu[i]) + (1.0 - Y[i]) * log((1.0 - Y[i]) / (1.0 - mu[i])));
5404 3800           deviance_new += dev;
5405             } else {
5406 5020           mu[i] = eta[i];
5407 5020           NV res = Y[i] - mu[i];
5408 5020           deviance_new += res * res;
5409             }
5410             }
5411 460 100         if (!is_binomial || deviance_new <= deviance_old + 1e-7 || !isfinite(deviance_new)) {
    100          
    50          
5412 450           continue;
5413             }
5414 10           boundary = TRUE;
5415 40 100         for (size_t j = 0; j < p; j++) beta[j] = (beta[j] + beta_old[j]) / 2.0;
5416             }
5417 46 100         if (fabs(deviance_new - deviance_old) / (0.1 + fabs(deviance_new)) < epsilon) {
5418 10           converged = TRUE; break;
5419             }
5420 36           deviance_old = deviance_new;
5421 121 100         for (size_t j = 0; j < p; j++) beta_old[j] = beta[j];
5422             }
5423 108 100         for (i = 0; i < p; i++) { for (size_t j = 0; j < p; j++) XtWX[i * p + j] = 0.0; }
    100          
5424 300 100         for (size_t k = 0; k < valid_n; k++) {
5425 290 100         NV w = is_binomial ? (mu[k] * (1.0 - mu[k])) : 1.0;
5426 290 100         if (w < 1e-10) w = 1e-10;
5427 1090 100         for (i = 0; i < p; i++) {
5428 800           NV xw = X[k * p + i] * w;
5429 3066 100         for (size_t j = 0; j < p; j++) XtWX[i * p + j] += xw * X[k * p + j];
5430             }
5431             }
5432 10           final_rank = sweep_matrix_ols(XtWX, p, aliased);
5433 10 100         NV wtdmu = has_intercept ? mean_y : (is_binomial ? 0.5 : 0.0);
    50          
5434              
5435 300 100         for (i = 0; i < valid_n; i++) {
5436 290 100         if (is_binomial) {
5437 36 100         if (Y[i] == 0.0) null_dev += -2.0 * log(1.0 - wtdmu);
5438 15 50         else if (Y[i] == 1.0) null_dev += -2.0 * log(wtdmu);
5439 0           else null_dev += 2.0 * (Y[i] * log(Y[i] / wtdmu) + (1.0 - Y[i]) * log((1.0 - Y[i]) / (1.0 - wtdmu)));
5440             } else {
5441 254           NV diff = Y[i] - wtdmu;
5442 254           null_dev += diff * diff;
5443             }
5444             }
5445 10 100         if (is_gaussian) {
5446 8           NV n_f = (NV)valid_n;
5447 8           NV dev_for_aic = deviance_new;
5448 8 100         if (dev_for_aic < 1.0355727742801604e-30) {
5449 1           dev_for_aic = 1.0355727742801604e-30;
5450             }
5451 8           aic = n_f * (log(2.0 * M_PI) + 1.0 + log(dev_for_aic / n_f)) + 2.0 * (final_rank + 1.0);
5452 2 50         } else if (is_binomial) {
5453 2           aic = deviance_new + 2.0 * final_rank;
5454             }
5455 10           res_hv = newHV(); coef_hv = newHV(); fitted_hv = newHV(); resid_hv = newHV();
5456 10           df_res = valid_n - final_rank;
5457 10 100         dispersion = is_binomial ? 1.0 : ((df_res > 0) ? (deviance_new / df_res) : NAN);
    100          
5458 300 100         for (size_t i = 0; i < valid_n; i++) {
5459 290           NV res = Y[i] - mu[i];
5460 290 100         if (is_binomial) {
5461 36           NV d_res = 0.0;
5462 36 100         if (Y[i] == 0.0) d_res = sqrt(-2.0 * log(1.0 - mu[i]));
5463 15 50         else if (Y[i] == 1.0) d_res = sqrt(-2.0 * log(mu[i]));
5464 0           else d_res = sqrt(2.0 * (Y[i] * log(Y[i] / mu[i]) + (1.0 - Y[i]) * log((1.0 - Y[i]) / (1.0 - mu[i]))));
5465 36 100         res = (Y[i] > mu[i]) ? d_res : -d_res;
5466             }
5467 290           hv_store(fitted_hv, valid_row_names[i], strlen(valid_row_names[i]), newSVnv(mu[i]), 0);
5468 290           hv_store(resid_hv, valid_row_names[i], strlen(valid_row_names[i]), newSVnv(res), 0);
5469 290           Safefree(valid_row_names[i]);
5470             }
5471 10           Safefree(valid_row_names);
5472 10           summary_hv = newHV(); terms_av = newAV();
5473 36 100         for (size_t j = 0; j < p; j++) {
5474 26           hv_store(coef_hv, exp_terms[j], strlen(exp_terms[j]), newSVnv(beta[j]), 0);
5475 26           av_push(terms_av, newSVpv(exp_terms[j], 0));
5476              
5477 26           HV *restrict row_hv = newHV();
5478 26 50         if (aliased[j]) {
5479 0           hv_store(row_hv, "Estimate", 8, newSVpv("NaN", 0), 0);
5480 0           hv_store(row_hv, "Std. Error", 10, newSVpv("NaN", 0), 0);
5481 0 0         hv_store(row_hv, is_binomial ? "z value" : "t value", 7, newSVpv("NaN", 0), 0);
5482 0 0         hv_store(row_hv, is_binomial ? "Pr(>|z|)" : "Pr(>|t|)", 8, newSVpv("NaN", 0), 0);
5483             } else {
5484 26           NV se = sqrt(dispersion * XtWX[j * p + j]);
5485 26           NV val_stat = beta[j] / se;
5486 26 100         NV p_val = is_binomial ? 2.0 * (1.0 - approx_pnorm(fabs(val_stat))) : get_t_pvalue(val_stat, df_res, "two.sided");
5487 26           hv_store(row_hv, "Estimate", 8, newSVnv(beta[j]), 0);
5488 26           hv_store(row_hv, "Std. Error", 10, newSVnv(se), 0);
5489 26 100         hv_store(row_hv, is_binomial ? "z value" : "t value", 7, newSVnv(val_stat), 0);
5490 26 100         hv_store(row_hv, is_binomial ? "Pr(>|z|)" : "Pr(>|t|)", 8, newSVnv(p_val), 0);
5491             }
5492 26           hv_store(summary_hv, exp_terms[j], strlen(exp_terms[j]), newRV_noinc((SV*)row_hv), 0);
5493             }
5494 10           hv_store(res_hv, "aic", 3, newSVnv(aic), 0);
5495 10           hv_store(res_hv, "coefficients", 12, newRV_noinc((SV*)coef_hv), 0);
5496 10           hv_store(res_hv, "converged", 9, newSVuv(converged ? 1 : 0), 0);
5497 10           hv_store(res_hv, "boundary", 8, newSVuv(boundary ? 1 : 0), 0);
5498 10           hv_store(res_hv, "deviance", 8, newSVnv(deviance_new), 0);
5499 10           hv_store(res_hv, "deviance.resid", 14, newRV_noinc((SV*)resid_hv), 0);
5500 10           hv_store(res_hv, "df.null", 7, newSVuv(valid_n - has_intercept), 0);
5501 10           hv_store(res_hv, "df.residual", 11, newSVuv(df_res), 0);
5502 10           hv_store(res_hv, "family", 6, newSVpv(family_str, 0), 0);
5503 10           hv_store(res_hv, "fitted.values", 13, newRV_noinc((SV*)fitted_hv), 0);
5504 10           hv_store(res_hv, "iter", 4, newSVuv(iter > max_iter ? max_iter : iter), 0);
5505 10           hv_store(res_hv, "null.deviance", 13, newSVnv(null_dev), 0);
5506 10           hv_store(res_hv, "rank", 4, newSVuv(final_rank), 0);
5507 10           hv_store(res_hv, "summary", 7, newRV_noinc((SV*)summary_hv), 0);
5508 10           hv_store(res_hv, "terms", 5, newRV_noinc((SV*)terms_av), 0);
5509 36 100         for (i = 0; i < num_terms; i++) Safefree(terms[i]);
5510 10           Safefree(terms);
5511 36 100         for (i = 0; i < num_uniq; i++) Safefree(uniq_terms[i]);
5512 10           Safefree(uniq_terms);
5513 36 100         for (size_t j = 0; j < p_exp; j++) {
5514 26           Safefree(exp_terms[j]);
5515 26 100         if (is_dummy[j]) { Safefree(dummy_base[j]); Safefree(dummy_level[j]); }
5516             }
5517 10           Safefree(exp_terms); Safefree(is_dummy); Safefree(dummy_base); Safefree(dummy_level);
5518 10           Safefree(mu); Safefree(eta); Safefree(Z); Safefree(W);
5519 10           Safefree(beta); Safefree(beta_old); Safefree(aliased);
5520 10           Safefree(XtWX); Safefree(XtWZ); Safefree(X); Safefree(Y);
5521 10 100         if (row_hashes) Safefree(row_hashes);
5522 10           RETVAL = newRV_noinc((SV*)res_hv);
5523             }
5524             OUTPUT:
5525             RETVAL
5526              
5527             SV* cor_test(...)
5528             CODE:
5529             {
5530 12 50         if (items < 2 || items % 2 != 0)
    50          
5531 0           croak("Usage: cor_test(\\@x, \\@y, method => 'pearson', ...)");
5532 12           SV *restrict x_ref = ST(0), *restrict y_ref = ST(1);
5533 12           const char *restrict alternative = "two.sided";
5534 12           const char *restrict method = "pearson";
5535 12           SV *restrict exact_sv = NULL;
5536 12           NV conf_level = 0.95;
5537 12           bool continuity = 0;
5538             /* Parse named arguments from the flat stack starting at index 2 */
5539 46 100         for (unsigned short int i = 2; i < items; i += 2) {
5540 34           const char *restrict key = SvPV_nolen(ST(i));
5541 34           SV *restrict val = ST(i + 1);
5542 34 100         if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
5543 27 100         else if (strEQ(key, "method")) method = SvPV_nolen(val);
5544 15 100         else if (strEQ(key, "exact")) exact_sv = val;
5545 14 100         else if (strEQ(key, "conf.level") || strEQ(key, "conf_level")) conf_level = SvNV(val);
    50          
5546 7 50         else if (strEQ(key, "continuity")) continuity = SvTRUE(val);
5547 0           else croak("cor_test: unknown argument '%s'", key);
5548             }
5549             AV *restrict x_av, *restrict y_av;
5550             NV *restrict x, *restrict y;
5551 12           NV estimate = 0, p_value = 0, statistic = 0, df = 0, ci_lower = 0, ci_upper = 0;
5552 12           bool is_pearson = (strcmp(method, "pearson") == 0);
5553 12           bool is_kendall = (strcmp(method, "kendall") == 0);
5554 12           bool is_spearman = (strcmp(method, "spearman") == 0);
5555             HV *restrict rhv;
5556 12 50         if (!SvOK(x_ref) || !SvROK(x_ref) || SvTYPE(SvRV(x_ref)) != SVt_PVAV ||
    50          
    50          
5557 12 50         !SvOK(y_ref) || !SvROK(y_ref) || SvTYPE(SvRV(y_ref)) != SVt_PVAV) {
    50          
    50          
5558 0           croak("cor_test: x and y must be array references");
5559             }
5560 12           x_av = (AV*)SvRV(x_ref);
5561 12           y_av = (AV*)SvRV(y_ref);
5562 12           size_t n_raw = av_len(x_av) + 1;
5563 12 50         if (n_raw != (size_t)(av_len(y_av) + 1)) croak("incompatible dimensions");
5564 12           x = safemalloc(n_raw * sizeof(NV));
5565 12           y = safemalloc(n_raw * sizeof(NV));
5566 12           size_t n = 0; /* Final count of pairwise complete observations */
5567 281 100         for (size_t i = 0; i < n_raw; i++) {
5568 269           SV **restrict x_val = av_fetch(x_av, i, 0);
5569 269           SV **restrict y_val = av_fetch(y_av, i, 0);
5570 269 50         NV xv = (x_val && SvOK(*x_val) && looks_like_number(*x_val)) ? SvNV(*x_val) : NAN;
    100          
    50          
5571 269 50         NV yv = (y_val && SvOK(*y_val) && looks_like_number(*y_val)) ? SvNV(*y_val) : NAN;
    100          
    50          
5572             /* Pairwise complete observations (skips NAs seamlessly like R) */
5573 269 100         if (!isnan(xv) && !isnan(yv)) {
    100          
5574 265           x[n] = xv;
5575 265           y[n] = yv;
5576 265           n++;
5577             }
5578             }
5579 12 50         if (n < 3) {
5580 0           Safefree(x);
5581 0           Safefree(y);
5582 0           croak("not enough finite observations");
5583             }
5584 12 100         if (is_pearson) {
5585             /* Welford's one-pass algorithm for Pearson correlation */
5586 6           NV mean_x = 0.0, mean_y = 0.0, M2_x = 0.0, M2_y = 0.0, cov = 0.0;
5587 36 100         for (size_t i = 0; i < n; i++) {
5588 30           NV dx = x[i] - mean_x;
5589 30           mean_x += dx / (i + 1);
5590 30           NV dy = y[i] - mean_y;
5591 30           mean_y += dy / (i + 1);
5592 30           M2_x += dx * (x[i] - mean_x);
5593 30           M2_y += dy * (y[i] - mean_y);
5594 30           cov += dx * (y[i] - mean_y);
5595             }
5596 6 50         estimate = (M2_x > 0.0 && M2_y > 0.0) ? cov / sqrt(M2_x * M2_y) : 0.0;
    50          
5597             /* Clamp to [-1, 1] to guard against floating-point overshoot */
5598 6 50         if (estimate > 1.0) estimate = 1.0;
5599 6 50         else if (estimate < -1.0) estimate = -1.0;
5600 6           df = (NV)(n - 2);
5601             /* BUG FIX: guard divide-by-zero when |estimate| == 1 exactly.
5602             * A perfect correlation gives t = ±Inf, matching R's behaviour. */
5603 6           NV denom_t = 1.0 - estimate * estimate;
5604 6 100         if (denom_t <= 0.0)
5605 2 100         statistic = (estimate > 0.0) ? INFINITY : -INFINITY;
5606             else
5607 4           statistic = estimate * sqrt(df / denom_t);
5608             /* Confidence interval via Fisher's Z transform.
5609             * BUG FIX: when |estimate| == 1 the log blows up; clamp first.
5610             * We use a half-ULP margin so tanh can recover ±1 cleanly. */
5611 6           NV est_clamped = estimate;
5612 6 100         if (est_clamped >= 1.0) est_clamped = 1.0 - DBL_EPSILON;
5613 5 100         else if (est_clamped <= -1.0) est_clamped = -1.0 + DBL_EPSILON;
5614 6           NV z = 0.5 * log((1.0 + est_clamped) / (1.0 - est_clamped));
5615 6           NV se = 1.0 / sqrt((NV)(n - 3));
5616 6           NV alpha = 1.0 - conf_level;
5617 6           NV q = inverse_normal_cdf(1.0 - alpha / 2.0);
5618 6           ci_lower = tanh(z - q * se);
5619 6           ci_upper = tanh(z + q * se);
5620             // High-precision p-value using incomplete beta
5621 6           p_value = get_t_pvalue(statistic, df, alternative);
5622 6 100         } else if (is_kendall) {
5623             // BUG FIX: use long to avoid int overflow for large n
5624 3           long c = 0, d = 0, tie_x = 0, tie_y = 0;
5625 210 100         for (size_t i = 0; i < n - 1; i++) {
5626 20127 100         for (size_t j = i + 1; j < n; j++) {
5627 19920           NV sign_x = (x[i] > x[j]) - (x[i] < x[j]);
5628 19920           NV sign_y = (y[i] > y[j]) - (y[i] < y[j]);
5629 19920 50         if (sign_x == 0 && sign_y == 0) { /* joint tie — ignore */ }
    0          
5630 19920 50         else if (sign_x == 0) tie_x++;
5631 19920 50         else if (sign_y == 0) tie_y++;
5632 19920 100         else if (sign_x * sign_y > 0) c++;
5633 19904           else d++;
5634             }
5635             }
5636 3           NV denom = sqrt((NV)(c + d + tie_x) * (NV)(c + d + tie_y));
5637             // BUG FIX: use NAN (from ) instead of 0.0/0.0 (UB in C)
5638 3 50         estimate = (denom == 0.0) ? NAN : (NV)(c - d) / denom;
5639 3 50         bool has_ties = (tie_x > 0 || tie_y > 0);
    50          
5640             bool do_exact;
5641             /* Mirror R: exact defaults to TRUE if n < 50 and no ties */
5642 3 100         if (!exact_sv || !SvOK(exact_sv))
    50          
5643 2 50         do_exact = (n < 50) && !has_ties;
    50          
5644             else
5645 1           do_exact = SvTRUE(exact_sv) ? 1 : 0;
5646             /* R overrides forced-exact back to approximation when ties exist */
5647 3 100         if (do_exact && has_ties) do_exact = 0;
    50          
5648 3 100         if (do_exact) {
5649 2           NV S_stat = (NV)(c - d);
5650 2           statistic = (NV)c;
5651 2           p_value = kendall_exact_pvalue(n, S_stat, alternative);
5652             } else {
5653             /* Normal approximation for large n or when ties are present */
5654 1           NV var_S = (NV)n * (NV)(n - 1) * (2.0 * (NV)n + 5.0) / 18.0;
5655 1           NV S = (NV)(c - d);
5656 1 50         if (continuity) S -= (S > 0.0 ? 1.0 : -1.0);
    0          
5657 1           statistic = S / sqrt(var_S);
5658              
5659 1 50         if (strcmp(alternative, "two.sided") == 0)
5660 1           p_value = 2.0 * (1.0 - approx_pnorm(fabs(statistic)));
5661 0 0         else if (strcmp(alternative, "less") == 0)
5662 0           p_value = approx_pnorm(statistic);
5663             else
5664 0           p_value = 1.0 - approx_pnorm(statistic);
5665             }
5666              
5667 3 50         } else if (is_spearman) {
5668 3           NV *restrict rank_x = safemalloc(n * sizeof(NV));
5669 3           NV *restrict rank_y = safemalloc(n * sizeof(NV));
5670 3           compute_ranks(x, rank_x, n);
5671 3           compute_ranks(y, rank_y, n);
5672              
5673             /* Spearman rho = Pearson r of the ranks (Welford's algorithm) */
5674 3           NV mean_x = 0.0, mean_y = 0.0, M2_x = 0.0, M2_y = 0.0, cov = 0.0;
5675 28 100         for (size_t i = 0; i < n; i++) {
5676 25           NV dx = rank_x[i] - mean_x;
5677 25           mean_x += dx / (i + 1);
5678 25           NV dy = rank_y[i] - mean_y;
5679 25           mean_y += dy / (i + 1);
5680 25           M2_x += dx * (rank_x[i] - mean_x);
5681 25           M2_y += dy * (rank_y[i] - mean_y);
5682 25           cov += dx * (rank_y[i] - mean_y);
5683             }
5684 3 50         estimate = (M2_x > 0.0 && M2_y > 0.0) ? cov / sqrt(M2_x * M2_y) : 0.0;
    50          
5685              
5686             /* Clamp to [-1, 1] to guard against floating-point overshoot */
5687 3 50         if (estimate > 1.0) estimate = 1.0;
5688 3 50         else if (estimate < -1.0) estimate = -1.0;
5689              
5690             /* S = sum of squared rank differences (R's reported statistic) */
5691 3           NV S_stat = 0.0;
5692 28 100         for (size_t i = 0; i < n; i++) {
5693 25           NV diff = rank_x[i] - rank_y[i];
5694 25           S_stat += diff * diff;
5695             }
5696              
5697             /* Ties produce fractional (averaged) ranks — detect them */
5698 3           bool has_ties = 0;
5699 28 100         for (size_t i = 0; i < n; i++) {
5700 25 50         if (rank_x[i] != floor(rank_x[i]) || rank_y[i] != floor(rank_y[i])) {
    50          
5701 0           has_ties = 1;
5702 0           break;
5703             }
5704             }
5705              
5706             bool do_exact;
5707 3 50         if (!exact_sv || !SvOK(exact_sv))
    0          
5708 3 100         do_exact = (n < 10) && !has_ties;
    50          
5709             else
5710 0           do_exact = SvTRUE(exact_sv) ? 1 : 0;
5711              
5712 3 100         if (do_exact) {
5713 1           statistic = S_stat;
5714 1           p_value = spearman_exact_pvalue(S_stat, n, alternative);
5715             } else {
5716 2           NV r = estimate;
5717             /* NOTE: R silently ignores continuity correction for Spearman.
5718             * The adjustment below is non-standard; a warning is emitted
5719             * so callers are not silently misled. */
5720 2 50         if (continuity) {
5721 0           warn("cor_test: continuity correction is not defined for Spearman in R and is ignored here");
5722             }
5723             /* BUG FIX: guard divide-by-zero when |r| == 1 exactly */
5724 2           NV denom_t = 1.0 - r * r;
5725 2 50         if (denom_t <= 0.0)
5726 2 100         statistic = (r > 0.0) ? INFINITY : -INFINITY;
5727             else
5728 0           statistic = r * sqrt((NV)(n - 2) / denom_t);
5729 2           p_value = get_t_pvalue(statistic, (NV)(n - 2), alternative);
5730             }
5731 3           Safefree(rank_x);
5732 3           Safefree(rank_y);
5733              
5734             } else {
5735 0           Safefree(x);
5736 0           Safefree(y);
5737 0           croak("Unknown method '%s': must be 'pearson', 'kendall', or 'spearman'", method);
5738             }
5739              
5740 12           Safefree(x);
5741 12           Safefree(y);
5742              
5743 12           rhv = newHV();
5744 12           hv_stores(rhv, "estimate", newSVnv(estimate));
5745 12           hv_stores(rhv, "p.value", newSVnv(p_value));
5746 12           hv_stores(rhv, "statistic", newSVnv(statistic));
5747 12           hv_stores(rhv, "method", newSVpv(method, 0));
5748 12           hv_stores(rhv, "alternative", newSVpv(alternative, 0));
5749 12 100         if (is_pearson) {
5750 6           hv_stores(rhv, "parameter", newSVnv(df));
5751 6           AV *restrict ci_av = newAV();
5752 6           av_push(ci_av, newSVnv(ci_lower));
5753 6           av_push(ci_av, newSVnv(ci_upper));
5754 6           hv_stores(rhv, "conf.int", newRV_noinc((SV*)ci_av));
5755             }
5756              
5757 12           RETVAL = newRV_noinc((SV*)rhv);
5758             }
5759             OUTPUT:
5760             RETVAL
5761              
5762             void shapiro_test(data)
5763             SV *data
5764             PREINIT:
5765             AV *restrict av;
5766             HV *restrict ret_hash;
5767 2           size_t n_raw, n = 0;
5768 2           NV *restrict x, w = 0.0, p_val = 0.0, mean = 0.0, ssq = 0.0;
5769             PPCODE:
5770 2 50         if (!SvROK(data) || SvTYPE(SvRV(data)) != SVt_PVAV) {
    50          
5771 0           croak("Expected an array reference");
5772             }
5773              
5774 2           av = (AV *)SvRV(data);
5775 2           n_raw = av_len(av) + 1;
5776              
5777 2 50         Newx(x, n_raw, NV);
5778              
5779             // Extract variables and calculate mean (skipping undefined/NaN values)
5780 26 100         for (size_t i = 0; i < n_raw; i++) {
5781 24           SV **restrict elem = av_fetch(av, i, 0);
5782 24 50         if (elem && SvOK(*elem)) {
    50          
5783 24           NV val = SvNV(*elem);
5784 24 50         if (!isnan(val)) {
5785 24           x[n] = val;
5786 24           mean += val;
5787 24           n++;
5788             }
5789             }
5790             }
5791              
5792 2 50         if (n < 3 || n > 5000) {
    50          
5793 0           Safefree(x);
5794 0           croak("Sample size must be between 3 and 5000 (R's limit)");
5795             }
5796              
5797 2           mean /= n;
5798             // Calculate Sum of Squares
5799 26 100         for (size_t i = 0; i < n; i++) {
5800 24           ssq += (x[i] - mean) * (x[i] - mean);
5801             }
5802 2 50         if (ssq == 0.0) {
5803 0           Safefree(x);
5804 0           croak("Data is perfectly constant; cannot compute Shapiro-Wilk test");
5805             }
5806 2           qsort(x, n, sizeof(NV), compare_doubles);
5807             // --- Core AS R94 Algorithm: Weights and Statistic W
5808 2 50         if (n == 3) {
5809 0           NV a_val = 0.7071067811865475; // sqrt(1/2)
5810 0           NV b_val = a_val * (x[2] - x[0]);
5811 0           w = (b_val * b_val) / ssq;
5812 0 0         if (w < 0.75) w = 0.75;
5813             // Exact P-value for n=3
5814 0           p_val = 1.90985931710274 * (asin(sqrt(w)) - 1.04719755119660);
5815             } else {
5816             NV *restrict m, *restrict a;
5817 2           NV sum_m2 = 0.0, b_val = 0.0;
5818 2 50         Newx(m, n, NV);
5819 2 50         Newx(a, n, NV);
5820 26 100         for (size_t i = 0; i < n; i++) {
5821 24           m[i] = inverse_normal_cdf((i + 1.0 - 0.375) / (n + 0.25));
5822 24           sum_m2 += m[i] * m[i];
5823             }
5824 2           NV u = 1.0 / sqrt((NV)n);
5825 2           NV a_n = -2.706056*pow(u,5) + 4.434685*pow(u,4) - 2.071190*pow(u,3) - 0.147981*pow(u,2) + 0.221157*u + m[n-1]/sqrt(sum_m2);
5826 2           a[n-1] = a_n;
5827 2           a[0] = -a_n;
5828 3 50         if (n == 4 || n == 5) {
    100          
5829 1           NV eps = (sum_m2 - 2.0 * m[n-1]*m[n-1]) / (1.0 - 2.0 * a_n*a_n);
5830 4 100         for (unsigned int i = 1; i < n-1; i++) {
5831 3           a[i] = m[i] / sqrt(eps);
5832             }
5833             } else {
5834 1           NV a_n1 = -3.582633*pow(u,5) + 5.682633*pow(u,4) - 1.752461*pow(u,3) - 0.293762*pow(u,2) + 0.042981*u + m[n-2]/sqrt(sum_m2);
5835 1           a[n-2] = a_n1;
5836 1           a[1] = -a_n1;
5837 1           NV eps = (sum_m2 - 2.0 * m[n-1]*m[n-1] - 2.0 * m[n-2]*m[n-2]) / (1.0 - 2.0 * a_n*a_n - 2.0 * a_n1*a_n1);
5838 16 100         for (unsigned int i = 2; i < n-2; i++) {
5839 15           a[i] = m[i] / sqrt(eps);
5840             }
5841             }
5842 26 100         for (size_t i = 0; i < n; i++) {
5843 24           b_val += a[i] * x[i];
5844             }
5845 2           w = (b_val * b_val) / ssq;
5846             // --- AS R94 P-Value Calculation: High Precision Refinement ---
5847             /* NOTE: p_val is declared in PREINIT above;
5848             * do NOT shadow it with a local 'double p_val' here or the result will never reach the caller.
5849             */
5850 2           NV y = log(1.0 - w);
5851             NV z;
5852 2 100         if (n <= 11) {
5853             // Royston's branch for 4 <= n <= 11 (AS R94, small-sample path).
5854             // gamma is the upper bound on y = log(1-W);
5855             // if y reaches gamma the p-value is essentially zero
5856 1           NV nn = (NV)n;
5857 1           NV gamma = 0.459 * nn - 2.273;
5858 1 50         if (y >= gamma) {
5859 0           p_val = 1e-19;
5860             } else {
5861             // Horner-form polynomials in n for mu and log(sigma)
5862 1           NV mu = 0.544 + nn * (-0.39978 + nn * ( 0.025054 - nn * 0.0006714));
5863 1           NV sig_val= 1.3822 + nn * (-0.77857 + nn * ( 0.062767 - nn * 0.0020322));
5864 1           NV sigma = exp(sig_val);
5865 1           z = (-log(gamma - y) - mu) / sigma;
5866             /* Upper-tail probability P(Z > z): small W → large z → small p-value.
5867             */
5868 1           p_val = 0.5 * erfc(z * M_SQRT1_2);
5869             }
5870             } else {
5871             // Royston's branch for n >= 12 (AS R94, large-sample path)
5872 1           NV ln_n = log((NV)n);
5873             // Horner-form polynomials in log(n) for mu and log(sigma). */
5874 1           NV mu = -1.5861 + ln_n * (-0.31082 + ln_n * (-0.083751 + ln_n * 0.0038915));
5875 1           NV sig_val= -0.4803 + ln_n * (-0.082676 + ln_n * 0.0030302);
5876 1           NV sigma = exp(sig_val);
5877 1           z = (y - mu) / sigma;
5878 1           p_val = 0.5 * erfc(z * M_SQRT1_2);
5879             }
5880             // Clamp the p-value
5881 2 50         if (p_val > 1.0) p_val = 1.0;
5882 2 50         if (p_val < 0.0) p_val = 0.0;
5883 2           Safefree(m); m = NULL; Safefree(a); a = NULL;
5884             }
5885 2           Safefree(x); x = NULL;
5886 2           ret_hash = newHV();
5887 2           hv_stores(ret_hash, "statistic", newSVnv(w));
5888 2           hv_stores(ret_hash, "W", newSVnv(w));
5889 2           hv_stores(ret_hash, "p_value", newSVnv(p_val));
5890 2           hv_stores(ret_hash, "p.value", newSVnv(p_val));
5891 2 50         EXTEND(SP, 1);
5892 2           PUSHs(sv_2mortal(newRV_noinc((SV *)ret_hash)));
5893              
5894             NV min(...)
5895             PROTOTYPE: @
5896             INIT:
5897 30           NV min_val = 0.0;
5898 30           size_t count = 0;
5899 30           bool first = TRUE;
5900             CODE:
5901 10074 100         for (unsigned short int i = 0; i < items; i++) {
5902 10046           SV* restrict arg = ST(i);
5903 10067 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
5904 22           AV* restrict av = (AV*)SvRV(arg);
5905 22           size_t len = av_len(av) + 1;
5906 519 100         for (size_t j = 0; j < len; j++) {
5907 498           SV** restrict tv = av_fetch(av, j, 0);
5908 498 50         if (tv && SvOK(*tv)) {
    100          
5909 497           NV val = SvNV(*tv);
5910 497 100         if (first || val < min_val) {
    100          
5911 39           min_val = val;
5912 39           first = FALSE;
5913             }
5914 497           count++;
5915             } else {
5916 1           croak("min: undefined value at array ref index %zu (argument %d)", j, (int)i);
5917             }
5918             }
5919 10024 100         } else if (SvOK(arg)) {
5920 10023           NV val = SvNV(arg);
5921 10023 100         if (first || val < min_val) {
    100          
5922 15           min_val = val;
5923 15           first = FALSE;
5924             }
5925 10023           count++;
5926             } else {
5927 1           croak("min: undefined value at argument index %d", (int)i);
5928             }
5929             }
5930 28 100         if (count == 0) croak("min needs >= 1 numeric element");
5931 27 100         RETVAL = min_val;
5932             OUTPUT:
5933             RETVAL
5934              
5935             NV max(...)
5936             PROTOTYPE: @
5937             INIT:
5938 31           NV max_val = 0.0;
5939 31           size_t count = 0;
5940 31           bool first = TRUE;
5941             CODE:
5942 10075 100         for (size_t i = 0; i < items; i++) {
5943 10046           SV* restrict arg = ST(i);
5944 10068 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
5945 23           AV* restrict av = (AV*)SvRV(arg);
5946 23           size_t len = av_len(av) + 1;
5947 620 100         for (size_t j = 0; j < len; j++) {
5948 598           SV** restrict tv = av_fetch(av, j, 0);
5949 598 50         if (tv && SvOK(*tv)) {
    100          
5950 597           NV val = SvNV(*tv);
5951 597 100         if (first || val > max_val) {
    100          
5952 89           max_val = val;
5953 89           first = FALSE;
5954             }
5955 597           count++;
5956             } else {
5957 1           croak("max: undefined value at array ref index %zu (argument %zu)", j, i);
5958             }
5959             }
5960 10023 100         } else if (SvOK(arg)) {
5961 10022           NV val = SvNV(arg);
5962 10022 100         if (first || val > max_val) {
    100          
5963 39           max_val = val;
5964 39           first = FALSE;
5965             }
5966 10022           count++;
5967             } else {
5968 1           croak("max: undefined value at argument index %zu", i);
5969             }
5970             }
5971 29 100         if (count == 0) croak("max needs >= 1 numeric element");
5972 28 100         RETVAL = max_val;
5973             OUTPUT:
5974             RETVAL
5975              
5976             SV* runif(...)
5977             CODE:
5978             {
5979 11           size_t n = 0;
5980 11           NV min = 0.0, max = 1.0;
5981              
5982             // Flags to track what has been assigned
5983 11           bool n_set = 0, min_set = 0, max_set = 0;
5984              
5985 11           unsigned int i = 0;
5986              
5987 11 50         if (items == 0) {
5988 0           croak("Usage: runif(n, [min=0], [max=1]) or runif(n => $n, ...)");
5989             }
5990              
5991 28 100         while (i < items) {
5992             // 1. Check if the current argument is a string key for a named parameter
5993 17 100         if (i + 1 < items && SvPOK(ST(i))) {
    100          
5994 6           char *restrict key = SvPV_nolen(ST(i));
5995 6 100         if (strEQ(key, "n")) {
5996 2           n = (size_t)SvUV(ST(i+1));
5997 2           n_set = 1;
5998 2           i += 2;
5999 2           continue;
6000 4 100         } else if (strEQ(key, "min")) {
6001 2           min = SvNV(ST(i+1));
6002 2           min_set = 1;
6003 2           i += 2;
6004 2           continue;
6005 2 50         } else if (strEQ(key, "max")) {
6006 2           max = SvNV(ST(i+1));
6007 2           max_set = 1;
6008 2           i += 2;
6009 2           continue;
6010             }
6011             }
6012              
6013             // 2. Fallback to positional parsing if it's not a recognized key
6014 11 100         if (!n_set) {
6015 9           n = (size_t)SvUV(ST(i));
6016 9           n_set = 1;
6017 2 100         } else if (!min_set) {
6018 1           min = SvNV(ST(i));
6019 1           min_set = 1;
6020 1 50         } else if (!max_set) {
6021 1           max = SvNV(ST(i));
6022 1           max_set = 1;
6023             } else {
6024 0           croak("Too many arguments or unrecognized parameter passed to runif()");
6025             }
6026 11           i++;
6027             }
6028 11 50         if (!n_set) {
6029 0           croak("runif() requires at least the 'n' parameter");
6030             }
6031             // Ensure PRNG is seeded
6032 11 50         AUTO_SEED_PRNG();
6033 11           AV *restrict results = newAV();
6034 11 50         if (n > 0) {
6035 11           av_extend(results, n - 1);
6036             }
6037 11           const NV range = max - min;
6038 20090 100         for (size_t j = 0; j < n; j++) {
6039             NV r;
6040 20079 50         if (max < min) {
6041 0           r = NAN; // R behavior for inverted ranges
6042             } else {
6043 20079           r = min + range * Drand01();
6044             }
6045 20079           av_push(results, newSVnv(r));
6046             }
6047 11           RETVAL = newRV_noinc((SV*)results);
6048             }
6049             OUTPUT:
6050             RETVAL
6051              
6052             SV* rbinom(...)
6053             CODE:
6054             {
6055             // Auto-seed the PRNG if the Perl script hasn't done so yet
6056 12 50         AUTO_SEED_PRNG();
6057 12 100         if (items % 2 != 0)
6058 1           croak("Usage: rbinom(n => 10, size => 100, prob => 0.5)");
6059             //Parse named arguments
6060 11           size_t n = 0, size = 0;
6061 11           NV prob = 0.5;
6062              
6063 11           bool size_set = FALSE, prob_set = FALSE;
6064              
6065 42 100         for (unsigned short i = 0; i < items; i += 2) {
6066 31           const char* restrict key = SvPV_nolen(ST(i));
6067 31           SV* restrict val = ST(i + 1);
6068              
6069 31 100         if (strEQ(key, "n")) n = (unsigned int)SvUV(val);
6070 20 100         else if (strEQ(key, "size")) { size = (unsigned int)SvUV(val); size_set = TRUE; }
6071 10 50         else if (strEQ(key, "prob")) { prob = SvNV(val); prob_set = TRUE; }
6072 0           else croak("rbinom: unknown argument '%s'", key);
6073             }
6074              
6075             // R requires size and prob to be explicitly passed in rbinom
6076 11 100         if (!size_set || !prob_set) croak("rbinom: 'size' and 'prob' are required arguments");
    100          
6077 9 100         if (prob < 0.0 || prob > 1.0) croak("rbinom: prob must be between 0 and 1");
    100          
6078              
6079 7           AV *restrict result_av = newAV();
6080 7 50         if (n > 0) {
6081 7           av_extend(result_av, n - 1);
6082 20506 100         for (unsigned int i = 0; i < n; i++) {
6083 20499           av_store(result_av, i, newSVuv(generate_binomial(aTHX_ size, prob)));
6084             }
6085             }
6086              
6087 7           RETVAL = newRV_noinc((SV*)result_av);
6088             }
6089             OUTPUT:
6090             RETVAL
6091              
6092             SV* hist(SV* x_sv, ...)
6093             CODE:
6094             {
6095             // 1. Validate Input
6096 9 100         if (!SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    100          
6097 2           croak("hist: first argument must be an array reference");
6098              
6099 7           AV*restrict x_av = (AV*)SvRV(x_sv);
6100 7           size_t n_raw = av_len(x_av) + 1;
6101 7 100         if (n_raw == 0) croak("hist: input array is empty");
6102              
6103             // 2. Extract Data & Find Range
6104             NV *restrict x;
6105 6 50         Newx(x, n_raw, NV);
6106 6           size_t n = 0;
6107 6           NV min_val = DBL_MAX, max_val = -DBL_MAX;
6108              
6109 2026 100         for (size_t i = 0; i < n_raw; i++) {
6110 2021           SV**restrict tv = av_fetch(x_av, i, 0);
6111 2021 50         if (tv && SvOK(*tv)) {
    50          
6112 2021           NV val = SvNV(*tv);
6113 2020           x[n++] = val;
6114 2020 100         if (val < min_val) min_val = val;
6115 2020 100         if (val > max_val) max_val = val;
6116             }
6117             }
6118 5 50         if (n == 0) {
6119 0           Safefree(x);
6120 0           croak("hist: input contains no valid numeric data");
6121             }
6122             // 3. Determine Bin Count (Sturges default or user-provided)
6123 5           size_t n_bins = 0;
6124 5 50         if (items == 2) {
6125             // Support pure positional argument: hist($data, 22)
6126 0           n_bins = (size_t)SvIV(ST(1));
6127 5 50         } else if (items > 2) {
6128             // Support named parameters even if mixed with positional arguments
6129 5 50         for (unsigned short i = 1; i < items - 1; i++) {
6130             // Make sure the SV holds a string before doing string comparison
6131 5 50         if (SvPOK(ST(i)) && strEQ(SvPV_nolen(ST(i)), "breaks")) {
    50          
6132 5           n_bins = (size_t)SvIV(ST(i+1));
6133 5           break;
6134             }
6135             }
6136             /* Fallback: if 'breaks' wasn't found but a positional number was given first */
6137 5 50         if (n_bins == 0 && looks_like_number(ST(1))) {
    0          
6138 0           n_bins = (size_t)SvIV(ST(1));
6139             }
6140             }
6141 5 50         if (n_bins == 0) n_bins = calculate_sturges_bins(n);
6142             // 4. Allocate Result Arrays
6143             NV *restrict breaks, *restrict mids, *restrict density;
6144             size_t *restrict counts;
6145 5 50         Newx(breaks, n_bins + 1, NV);
6146 5 50         Newx(mids, n_bins, NV);
6147 5 50         Newx(density, n_bins, NV);
6148 5 50         Newx(counts, n_bins, size_t);
6149             // Generate simple linear breaks
6150 5           NV step = (max_val - min_val) / (NV)n_bins;
6151 28 100         for (size_t i = 0; i <= n_bins; i++) {
6152 23           breaks[i] = min_val + (NV)i * step;
6153             }
6154             // 5. Compute Statistics
6155 5           compute_hist_logic(x, n, breaks, n_bins, counts, mids, density);
6156             // 6. Build Return HashRef
6157 5           HV*restrict res_hv = newHV();
6158 5           AV*restrict av_breaks = newAV();
6159 5           AV*restrict av_counts = newAV();
6160 5           AV*restrict av_mids = newAV();
6161 5           AV*restrict av_density = newAV();
6162 28 100         for (size_t i = 0; i <= n_bins; i++) {
6163 23           av_push(av_breaks, newSVnv(breaks[i]));
6164 23 100         if (i < n_bins) {
6165 18           av_push(av_counts, newSViv(counts[i]));
6166 18           av_push(av_mids, newSVnv(mids[i]));
6167 18           av_push(av_density, newSVnv(density[i]));
6168             }
6169             }
6170 5           hv_stores(res_hv, "breaks", newRV_noinc((SV*)av_breaks));
6171 5           hv_stores(res_hv, "counts", newRV_noinc((SV*)av_counts));
6172 5           hv_stores(res_hv, "mids", newRV_noinc((SV*)av_mids));
6173 5           hv_stores(res_hv, "density", newRV_noinc((SV*)av_density));
6174             // Clean
6175 5           Safefree(x); Safefree(breaks); Safefree(mids);
6176 5           Safefree(density); Safefree(counts);
6177 5           RETVAL = newRV_noinc((SV*)res_hv);
6178             }
6179             OUTPUT:
6180             RETVAL
6181              
6182             SV* quantile(...)
6183             CODE:
6184             {
6185 22           SV *restrict x_sv = NULL;
6186 22           SV *restrict probs_sv = NULL;
6187 22           unsigned int arg_idx = 0;
6188             // --- 1. Consume first positional arg as 'x' if it's an array ref
6189 22 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
6190 21           x_sv = ST(arg_idx);
6191 21           arg_idx++;
6192             }
6193             // --- 2. Remaining args must be key-value pairs
6194 22 50         if ((items - arg_idx) % 2 != 0)
6195 0           croak("Usage: quantile(\\@data, probs => \\@probs) OR quantile(x => \\@data, probs => \\@probs)");
6196              
6197 45 100         for (; arg_idx < items; arg_idx += 2) {
6198 23           const char *restrict key = SvPV_nolen(ST(arg_idx));
6199 23           SV *restrict val = ST(arg_idx + 1);
6200              
6201 23 100         if (strEQ(key, "x")) x_sv = val;
6202 22 50         else if (strEQ(key, "probs")) probs_sv = val;
6203 0           else croak("quantile: unknown argument '%s'", key);
6204             }
6205 22 50         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
    50          
6206 0           croak("quantile: 'x' must be an array reference");
6207            
6208 22           AV *restrict x_av = (AV*)SvRV(x_sv);
6209 22           size_t n_raw = av_len(x_av) + 1;
6210 22 50         if (n_raw == 0) croak("quantile: 'x' is empty");
6211             // --- Extract valid numeric data & drop NAs (Upgraded to NV)
6212             NV *restrict x;
6213 22 50         Newx(x, n_raw, NV);
6214 22           size_t n = 0;
6215 511 100         for (size_t i = 0; i < n_raw; i++) {
6216 489           SV **restrict tv = av_fetch(x_av, i, 0);
6217 489 50         if (tv && SvOK(*tv)) {
    50          
6218 489           x[n++] = SvNV(*tv);
6219             }
6220             }
6221 22 50         if (n == 0) {
6222 0           Safefree(x);
6223 0           croak("quantile: 'x' contains no valid numbers");
6224             }
6225             // --- Sort Data for Quantile Math ---
6226             // Note: You must update `compare_doubles` to accept and compare `NV` types!
6227 22           qsort(x, n, sizeof(NV), compare_NVs);
6228             // --- Parse Probabilities (Upgraded to NV) ---
6229 22           NV default_probs[] = {0.0, 0.25, 0.50, 0.75, 1.0};
6230 22           unsigned int n_probs = 5;
6231             NV *restrict probs;
6232 44 50         if (probs_sv && SvROK(probs_sv) && SvTYPE(SvRV(probs_sv)) == SVt_PVAV) {
    50          
    50          
6233 22           AV *restrict p_av = (AV*)SvRV(probs_sv);
6234 22           n_probs = av_len(p_av) + 1;
6235 22           Newx(probs, n_probs, NV);
6236 67 100         for (unsigned int i = 0; i < n_probs; i++) {
6237 45           SV **tv = av_fetch(p_av, i, 0);
6238 45 50         probs[i] = (tv && SvOK(*tv)) ? SvNV(*tv) : 0.0;
    50          
6239 45 50         if (probs[i] < 0.0 || probs[i] > 1.0) {
    50          
6240 0           Safefree(x); Safefree(probs);
6241 0           croak("quantile: probabilities must be between 0 and 1");
6242             }
6243             }
6244             } else {
6245 0           Newx(probs, n_probs, NV);
6246 0 0         for (unsigned int i = 0; i < n_probs; i++) probs[i] = default_probs[i];
6247             }
6248             // --- Calculate Quantiles (R Type 7 Algorithm) ---
6249 22           HV *restrict res_hv = newHV();
6250 67 100         for (size_t i = 0; i < n_probs; i++) {
6251 45           NV p = probs[i];
6252 45           NV q = 0.0;
6253              
6254 45 100         if (n == 1) {
6255 1           q = x[0];
6256 44 100         } else if (p == 1.0) {
6257 1           q = x[n - 1];
6258 43 100         } else if (p == 0.0) {
6259 1           q = x[0];
6260             } else {
6261 42           NV h = (n - 1) * p;
6262 42           unsigned int j = (unsigned int)h;
6263 42           NV gamma = h - j;
6264 42           q = (1.0 - gamma) * x[j] + gamma * x[j + 1];
6265             }
6266             // --- Format hash key with Epsilon guarding ---
6267             char key[32];
6268 45           double pct = (double)(p * 100.0); // Safe to cast to double just for formatting
6269 45           double pct_rounded = floor(pct + 0.5); // C89 safe rounding
6270             // Use 1e-9 epsilon check instead of strict integer equality
6271 45 50         if (fabs(pct - pct_rounded) < 1e-9) {
6272 45           snprintf(key, sizeof(key), "%.0f%%", pct_rounded);
6273             } else {
6274 0           snprintf(key, sizeof(key), "%.1f%%", pct);
6275             }
6276            
6277 45           hv_store(res_hv, key, strlen(key), newSVnv(q), 0);
6278             }
6279 22           Safefree(x); Safefree(probs);
6280 22           RETVAL = newRV_noinc((SV*)res_hv);
6281             }
6282             OUTPUT:
6283             RETVAL
6284              
6285             NV mean(...)
6286             PROTOTYPE: @
6287             INIT:
6288 59           NV total = 0;
6289 59           size_t count = 0;
6290             CODE:
6291 129 100         for (size_t i = 0; i < items; i++) {
6292 72           SV* restrict arg = ST(i);
6293 127 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6294 56           AV* restrict av = (AV*)SvRV(arg);
6295 56           size_t len = av_len(av) + 1;
6296 20610 100         for (size_t j = 0; j < len; j++) {
6297 20555           SV** restrict tv = av_fetch(av, j, 0);
6298 20555 50         if (tv && SvOK(*tv)) {
    100          
6299 20554           total += SvNV(*tv);
6300 20554           count++;
6301             } else {
6302 1           croak("mean: undefined value at array ref index %zu (argument %zu)", j, i);
6303             }
6304             }
6305 16 100         } else if (SvOK(arg)) {
6306 15           total += SvNV(arg);
6307 15           count++;
6308             } else {
6309 1           croak("mean: undefined value at argument index %zu", i);
6310             }
6311             }
6312 57 100         if (count == 0) croak("mean needs >= 1 element");
6313 56 100         RETVAL = total / count;
6314             OUTPUT:
6315             RETVAL
6316              
6317             void mode(...)
6318             PROTOTYPE: @
6319             PREINIT:
6320             HV *restrict counts;
6321             HV *restrict originals;
6322 5           size_t max_count = 0, arg_count = 0;
6323             HE *restrict he;
6324             PPCODE:
6325             /* counts: string(value) -> occurrence count */
6326             /* originals: string(value) -> SV* first-seen original */
6327 5           counts = (HV *)sv_2mortal((SV *)newHV());
6328 5           originals = (HV *)sv_2mortal((SV *)newHV());
6329              
6330 16 100         for (size_t i = 0; i < items; i++) {
6331 12           SV *restrict arg = ST(i);
6332 13 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6333 1           AV *restrict av = (AV *)SvRV(arg);
6334 1           size_t len = av_len(av) + 1;
6335 5 100         for (size_t j = 0; j < len; j++) {
6336 4           SV **restrict tv = av_fetch(av, j, 0);
6337 4 50         if (tv && SvOK(*tv)) {
    50          
6338             STRLEN klen;
6339 4           const char *restrict key = SvPV(*tv, klen);
6340 4           SV **restrict slot = hv_fetch(counts, key, klen, 1);
6341 4 50         if (!slot) croak("mode: internal hash error");
6342 4 100         size_t cnt = SvOK(*slot) ? SvIV(*slot) + 1 : 1;
6343 4           sv_setiv(*slot, cnt);
6344 4 100         if (cnt > max_count) max_count = cnt;
6345 4 100         if (cnt == 1)
6346 2           hv_store(originals, key, klen, newSVsv(*tv), 0);
6347 4           arg_count++;
6348             } else {
6349 0           croak("mode: undefined value at array ref index %zu (argument %zu)", j, i);
6350             }
6351             }
6352 11 100         } else if (SvOK(arg)) {
6353             STRLEN klen;
6354 10           const char *restrict key = SvPV(arg, klen);
6355 10           SV **restrict slot = hv_fetch(counts, key, klen, 1);
6356 10 50         if (!slot) croak("mode: internal hash error");
6357 10 100         size_t cnt = SvOK(*slot) ? SvIV(*slot) + 1 : 1;
6358 10           sv_setiv(*slot, cnt);
6359 10 100         if (cnt > max_count) max_count = cnt;
6360 10 100         if (cnt == 1)
6361 6           hv_store(originals, key, klen, newSVsv(arg), 0);
6362 10           arg_count++;
6363             } else {
6364 1           croak("mode: undefined value at argument index %zu", i);
6365             }
6366             }
6367              
6368 4 100         if (arg_count == 0)
6369 1           croak("mode needs >= 1 element");
6370              
6371 3           hv_iterinit(counts);
6372 13 100         while ((he = hv_iternext(counts))) {
6373 7 100         if (SvIV(hv_iterval(counts, he)) == max_count) {
6374             STRLEN klen;
6375 4 50         const char *restrict key = HePV(he, klen);
6376 4           SV **restrict orig = hv_fetch(originals, key, klen, 0);
6377 4 50         mXPUSHs(orig ? newSVsv(*orig) : newSVpvn(key, klen));
    50          
6378             }
6379             }
6380              
6381             NV sum(...)
6382             PROTOTYPE: @
6383             INIT:
6384 5           NV total = 0;
6385 5           size_t count = 0;
6386             CODE:
6387 19 100         for (size_t i = 0; i < items; i++) {
6388 16           SV* restrict arg = ST(i);
6389 17 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6390 2           AV* restrict av = (AV*)SvRV(arg);
6391 2           size_t len = av_len(av) + 1;
6392 11 100         for (size_t j = 0; j < len; j++) {
6393 10           SV** restrict tv = av_fetch(av, j, 0);
6394 10 50         if (tv && SvOK(*tv)) {
    100          
6395 9           total += SvNV(*tv);
6396 9           count++;
6397             } else {
6398 1           croak("sum: undefined value at array ref index %zu (argument %zu)", j, i);
6399             }
6400             }
6401 14 100         } else if (SvOK(arg)) {
6402 13           total += SvNV(arg);
6403 13           count++;
6404             } else {
6405 1           croak("sum: undefined value at argument index %zu", i);
6406             }
6407             }
6408 3 50         if (count == 0) croak("sum needs >= 1 element");
6409 3 100         RETVAL = total;
6410             OUTPUT:
6411             RETVAL
6412              
6413             NV sd(...)
6414             PROTOTYPE: @
6415             INIT:
6416 23           NV mean = 0.0, M2 = 0.0;
6417 23           size_t count = 0;
6418             CODE:
6419             /* Single Pass Standard Deviation via Welford's Algorithm */
6420 58 100         for (size_t i = 0; i < items; i++) {
6421 37           SV* restrict arg = ST(i);
6422 54 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6423 18           AV* restrict av = (AV*)SvRV(arg);
6424 18           size_t len = av_len(av) + 1;
6425 10086 100         for (size_t j = 0; j < len; j++) {
6426 10069           SV** restrict tv = av_fetch(av, j, 0);
6427 10069 50         if (tv && SvOK(*tv)) {
    100          
6428 10068           count++;
6429 10068           NV val = SvNV(*tv);
6430 10068           NV delta = val - mean;
6431 10068           mean += delta / count;
6432 10068           M2 += delta * (val - mean);
6433             } else {
6434 1           croak("sd: undefined value at array ref index %zu (argument %zu)", j, i);
6435             }
6436             }
6437 19 100         } else if (SvOK(arg)) {
6438 18           count++;
6439 18           NV val = SvNV(arg);
6440 18           NV delta = val - mean;
6441 18           mean += delta / count;
6442 18           M2 += delta * (val - mean);
6443             } else {
6444 1           croak("sd: undefined value at argument index %zu", i);
6445             }
6446             }
6447 21 100         if (count < 2) croak("sd needs >= 2 elements");
6448 20 100         RETVAL = sqrt(M2 / (count - 1));
6449             OUTPUT:
6450             RETVAL
6451              
6452             NV var(...)
6453             PROTOTYPE: @
6454             INIT:
6455 8           NV mean = 0.0, M2 = 0.0;
6456 8           size_t count = 0;
6457             CODE:
6458             // Single Pass Variance via Welford's Algorithm
6459 21 100         for (size_t i = 0; i < items; i++) {
6460 15           SV* restrict arg = ST(i);
6461 18 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6462 4           AV* restrict av = (AV*)SvRV(arg);
6463 4           size_t len = av_len(av) + 1;
6464 10015 100         for (size_t j = 0; j < len; j++) {
6465 10012           SV** restrict tv = av_fetch(av, j, 0);
6466 10012 50         if (tv && SvOK(*tv)) {
    100          
6467 10011           count++;
6468 10011           NV val = SvNV(*tv);
6469 10011           NV delta = val - mean;
6470 10011           mean += delta / count;
6471 10011           M2 += delta * (val - mean);
6472             } else {
6473 1           croak("var: undefined value at array ref index %zu (argument %zu)", j, i);
6474             }
6475             }
6476 11 100         } else if (SvOK(arg)) {
6477 10           count++;
6478 10           NV val = SvNV(arg);
6479 10           NV delta = val - mean;
6480 10           mean += delta / count;
6481 10           M2 += delta * (val - mean);
6482             } else {
6483 1           croak("var: undefined value at argument index %zu", i);
6484             }
6485             }
6486 6 100         if (count < 2) croak("var needs >= 2 elements");
6487 5 100         RETVAL = M2 / (count - 1);
6488             OUTPUT:
6489             RETVAL
6490              
6491             SV* t_test(...)
6492             CODE:
6493             {
6494 53           SV*restrict x_sv = NULL;
6495 53           SV*restrict y_sv = NULL;
6496 53           NV mu = 0.0, conf_level = 0.95;
6497 53           bool paired = FALSE, var_equal = FALSE;
6498 53           const char*restrict alternative = "two.sided";
6499 53           unsigned short int arg_idx = 0;
6500             // 1. Shift first positional argument as 'x' if it's an array reference
6501 53 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
6502 27           x_sv = ST(arg_idx);
6503 27           arg_idx++;
6504             }
6505             // 2. Shift second positional argument as 'y' if it's an array reference
6506 53 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    100          
    50          
6507 10           y_sv = ST(arg_idx);
6508 10           arg_idx++;
6509             }
6510             // Ensure the remaining arguments form complete key-value pairs
6511 53 50         if ((items - arg_idx) % 2 != 0) {
6512 0           croak("Usage: t_test(\\@x, [\\@y], key => value, ...)");
6513             }
6514             // --- Parse named arguments from the remaining flat stack ---
6515 129 100         for (; arg_idx < items; arg_idx += 2) {
6516 76           const char*restrict key = SvPV_nolen(ST(arg_idx));
6517 76           SV*restrict val = ST(arg_idx + 1);
6518              
6519 76 100         if (strEQ(key, "x")) x_sv = val;
6520 51 100         else if (strEQ(key, "y")) y_sv = val;
6521 46 100         else if (strEQ(key, "mu")) mu = SvNV(val);
6522 11 100         else if (strEQ(key, "paired")) paired = SvTRUE(val);
6523 7 100         else if (strEQ(key, "var_equal")) var_equal = SvTRUE(val);
6524 4 100         else if (strEQ(key, "conf_level")) conf_level = SvNV(val);
6525 2 50         else if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
6526 0           else croak("t_test: unknown argument '%s'", key);
6527             }
6528              
6529             // --- Validate required / types ---
6530 53 100         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
    50          
6531 1           croak("t_test: 'x' is a required argument and must be an ARRAY reference");
6532 52           AV*restrict x_av = (AV*)SvRV(x_sv);
6533 52           size_t nx = av_len(x_av) + 1;
6534 52 50         if (nx < 2) croak("t_test: 'x' needs at least 2 elements");
6535 52           AV*restrict y_av = NULL;
6536 52 100         if (y_sv && SvROK(y_sv) && SvTYPE(SvRV(y_sv)) == SVt_PVAV)
    50          
    50          
6537 14           y_av = (AV*)SvRV(y_sv);
6538 52 50         if (conf_level <= 0.0 || conf_level >= 1.0)
    100          
6539 1           croak("t_test: 'conf_level' must be between 0 and 1");
6540             // --- Computation via Welford's Algorithm --- */
6541 51           NV mean_x = 0.0, M2_x = 0.0, var_x, t_stat, df, p_val, std_err, cint_est;
6542 51           HV*restrict results = newHV();
6543 447 100         for (size_t i = 0; i < nx; i++) {
6544 396           SV**restrict tv = av_fetch(x_av, i, 0);
6545 396 50         NV val = (tv && SvOK(*tv)) ? SvNV(*tv) : 0;
    50          
6546 396           NV delta = val - mean_x;
6547 396           mean_x += delta / (i + 1);
6548 396           M2_x += delta * (val - mean_x);
6549             }
6550 51           var_x = M2_x / (nx - 1);
6551 51 100         if (var_x == 0.0 && !y_av) croak("t_test: data are essentially constant");
    50          
6552              
6553 63 100         if (paired || y_av) {
    100          
6554 15 100         if (!y_av) croak("t_test: 'y' must be provided for paired or two-sample tests");
6555 14           size_t ny = av_len(y_av) + 1;
6556 14 100         if (paired && ny != nx) croak("t_test: Paired arrays must be same length");
    100          
6557 13           NV mean_y = 0.0, M2_y = 0.0, var_y;
6558 140 100         for (size_t i = 0; i < ny; i++) {
6559 127           SV**restrict tv = av_fetch(y_av, i, 0);
6560 127 50         NV val = (tv && SvOK(*tv)) ? SvNV(*tv) : 0;
    50          
6561 127           NV delta = val - mean_y;
6562 127           mean_y += delta / (i + 1);
6563 127           M2_y += delta * (val - mean_y);
6564             }
6565 13           var_y = M2_y / (ny - 1);
6566 13 100         if (paired) {
6567 2           NV mean_d = 0.0, M2_d = 0.0;
6568 14 100         for (size_t i = 0; i < nx; i++) {
6569 12           SV**restrict dx_ptr = av_fetch(x_av, i, 0);
6570 12           SV**restrict dy_ptr = av_fetch(y_av, i, 0);
6571 12 50         NV dx = (dx_ptr && SvOK(*dx_ptr)) ? SvNV(*dx_ptr) : 0.0;
    50          
6572 12 50         NV dy = (dy_ptr && SvOK(*dy_ptr)) ? SvNV(*dy_ptr) : 0.0;
    50          
6573 12           NV val = dx - dy;
6574 12           NV delta = val - mean_d;
6575 12           mean_d += delta / (i + 1);
6576 12           M2_d += delta * (val - mean_d);
6577             }
6578 2           NV var_d = M2_d / (nx - 1);
6579 2 50         if (var_d == 0.0) croak("t_test: data are essentially constant");
6580 2           cint_est = mean_d;
6581 2           std_err = sqrt(var_d / nx);
6582 2           t_stat = (cint_est - mu) / std_err;
6583 2           df = nx - 1;
6584 2           hv_store(results, "estimate", 8, newSVnv(mean_d), 0);
6585 11 100         } else if (var_equal) {
6586 2 50         if (var_x == 0.0 && var_y == 0.0) croak("t_test: data are essentially constant");
    0          
6587 2           NV pooled_var = ((nx - 1) * var_x + (ny - 1) * var_y) / (nx + ny - 2);
6588 2           cint_est = mean_x - mean_y;
6589 2           std_err = sqrt(pooled_var * (1.0 / nx + 1.0 / ny));
6590 2           t_stat = (cint_est - mu) / std_err;
6591 2           df = nx + ny - 2;
6592 2           hv_store(results, "estimate_x", 10, newSVnv(mean_x), 0);
6593 2           hv_store(results, "estimate_y", 10, newSVnv(mean_y), 0);
6594             } else {
6595 9 50         if (var_x == 0.0 && var_y == 0.0) croak("t_test: data are essentially constant");
    0          
6596 9           cint_est = mean_x - mean_y;
6597 9           NV stderr_x2 = var_x / nx;
6598 9           NV stderr_y2 = var_y / ny;
6599 9           std_err = sqrt(stderr_x2 + stderr_y2);
6600 9           t_stat = (cint_est - mu) / std_err;
6601 9           df = pow(stderr_x2 + stderr_y2, 2) /
6602 9           (pow(stderr_x2, 2) / (nx - 1) + pow(stderr_y2, 2) / (ny - 1));
6603 9           hv_store(results, "estimate_x", 10, newSVnv(mean_x), 0);
6604 9           hv_store(results, "estimate_y", 10, newSVnv(mean_y), 0);
6605             }
6606             } else {
6607 35           cint_est = mean_x;
6608 35           std_err = sqrt(var_x / nx);
6609 35           t_stat = (cint_est - mu) / std_err;
6610 35           df = nx - 1;
6611 35           hv_store(results, "estimate", 8, newSVnv(mean_x), 0);
6612             }
6613 48           p_val = get_t_pvalue(t_stat, df, alternative);
6614 48           NV alpha = 1.0 - conf_level, t_crit, ci_lower, ci_upper;
6615 48 100         if (strcmp(alternative, "less") == 0) {
6616 1           t_crit = qt_tail(df, alpha);
6617 1           ci_lower = -INFINITY;
6618 1           ci_upper = cint_est + t_crit * std_err;
6619 47 100         } else if (strcmp(alternative, "greater") == 0) {
6620 1           t_crit = qt_tail(df, alpha);
6621 1           ci_lower = cint_est - t_crit * std_err;
6622 1           ci_upper = INFINITY;
6623             } else {
6624 46           t_crit = qt_tail(df, alpha / 2.0);
6625 46           ci_lower = cint_est - t_crit * std_err;
6626 46           ci_upper = cint_est + t_crit * std_err;
6627             }
6628 48           AV*restrict conf_int = newAV();
6629 48           av_push(conf_int, newSVnv(ci_lower));
6630 48           av_push(conf_int, newSVnv(ci_upper));
6631 48           hv_store(results, "statistic", 9, newSVnv(t_stat), 0);
6632 48           hv_store(results, "df", 2, newSVnv(df), 0);
6633 48           hv_store(results, "p_value", 7, newSVnv(p_val), 0);
6634 48           hv_store(results, "conf_int", 8, newRV_noinc((SV*)conf_int), 0);
6635 48           RETVAL = newRV_noinc((SV*)results);
6636             }
6637             OUTPUT:
6638             RETVAL
6639              
6640             void p_adjust(SV* p_sv, const char* method = "holm")
6641             INIT:
6642 15 100         if (!SvROK(p_sv) || SvTYPE(SvRV(p_sv)) != SVt_PVAV) {
    50          
6643 1           croak("p_adjust: first argument must be an ARRAY reference of p-values");
6644             }
6645 14           AV *restrict p_av = (AV*)SvRV(p_sv);
6646 14           size_t n = av_len(p_av) + 1;
6647             // Handle empty input
6648 14 100         if (n == 0) {
6649 1           XSRETURN_EMPTY;
6650             }
6651             // Normalize method string
6652             char meth[64];
6653 13           strncpy(meth, method, 63); meth[63] = '\0';
6654 157 100         for(unsigned short int i = 0; meth[i]; i++) meth[i] = tolower(meth[i]);
6655             // Resolve aliases
6656 13 100         if (strstr(meth, "benjamini") && strstr(meth, "hochberg")) strcpy(meth, "bh");
    100          
6657 13 100         if (strstr(meth, "benjamini") && strstr(meth, "yekutieli")) strcpy(meth, "by");
    50          
6658 13 50         if (strcmp(meth, "fdr") == 0) strcpy(meth, "bh");
6659             // Allocate C memory
6660             PVal *restrict arr;
6661             NV *restrict adj;
6662 13 50         Newx(arr, n, PVal);
6663 13 50         Newx(adj, n, NV);
6664              
6665 369 100         for (size_t i = 0; i < n; i++) {
6666 356           SV**restrict tv = av_fetch(p_av, i, 0);
6667 356 50         arr[i].p = (tv && SvOK(*tv)) ? SvNV(*tv) : 1.0;
    50          
6668 356           arr[i].orig_idx = i;
6669             }
6670             // Sort ascending (Stable sort using original index)
6671 13           qsort(arr, n, sizeof(PVal), cmp_pval);
6672             PPCODE:
6673 13 100         if (strcmp(meth, "bonferroni") == 0) {
6674 53 100         for (size_t i = 0; i < n; i++) {
6675 51           NV v = arr[i].p * n;
6676 51 100         adj[arr[i].orig_idx] = (v < 1.0) ? v : 1.0;
6677             }
6678 11 100         } else if (strcmp(meth, "holm") == 0) {
6679 2           NV cummax = 0.0;
6680 53 100         for (size_t i = 0; i < n; i++) {
6681 51           NV v = arr[i].p * (n - i);
6682 51 100         if (v > cummax) cummax = v;
6683 51 100         adj[arr[i].orig_idx] = (cummax < 1.0) ? cummax : 1.0;
6684             }
6685 9 100         } else if (strcmp(meth, "hochberg") == 0) {
6686 2           NV cummin = 1.0;
6687 53 100         for (ssize_t i = n - 1; i >= 0; i--) {
6688 51           NV v = arr[i].p * (n - i);
6689 51 100         if (v < cummin) cummin = v;
6690 51 50         adj[arr[i].orig_idx] = (cummin < 1.0) ? cummin : 1.0;
6691             }
6692 7 100         } else if (strcmp(meth, "bh") == 0) {
6693 2           NV cummin = 1.0;
6694 53 100         for (ssize_t i = n - 1; i >= 0; i--) {
6695 51           NV v = arr[i].p * n / (i + 1.0);
6696 51 100         if (v < cummin) cummin = v;
6697 51 50         adj[arr[i].orig_idx] = (cummin < 1.0) ? cummin : 1.0;
6698             }
6699 5 100         } else if (strcmp(meth, "by") == 0) {
6700 2           NV q = 0.0;
6701 53 100         for (size_t i = 1; i <= n; i++) q += 1.0 / i;
6702 2           NV cummin = 1.0;
6703 53 100         for (ssize_t i = n - 1; i >= 0; i--) {
6704 51           NV v = arr[i].p * n / (i + 1.0) * q;
6705 51 100         if (v < cummin) cummin = v;
6706 51 100         adj[arr[i].orig_idx] = (cummin < 1.0) ? cummin : 1.0;
6707             }
6708 3 100         } else if (strcmp(meth, "hommel") == 0) {
6709             NV *restrict pa, *restrict q_arr;
6710 2 50         Newx(pa, n, NV);
6711 2 50         Newx(q_arr, n, NV);
6712             // Initial: min(n * p[i] / (i + 1))
6713 2           NV min_val = n * arr[0].p;
6714 51 100         for (size_t i = 1; i < n; i++) {
6715 49           NV temp = (n * arr[i].p) / (i + 1.0);
6716 49 50         if (temp < min_val) {
6717 0           min_val = temp;
6718             }
6719             }
6720             // pa <- q <- rep(min, n)
6721 53 100         for (size_t i = 0; i < n; i++) {
6722 51           pa[i] = min_val;
6723 51           q_arr[i] = min_val;
6724             }
6725 50 100         for (size_t j = n - 1; j >= 2; j--) {
6726 48           ssize_t n_mj = n - j; // Max index for 'ij'. Length is n_mj + 1
6727 48           ssize_t i2_len = j - 1; // Length of 'i2
6728             // Calculate q1 = min(j * p[i2] / (2:j))
6729 48           NV q1 = (j * arr[n_mj + 1].p) / 2.0;
6730 1176 100         for (size_t k = 1; k < i2_len; k++) {
6731 1128           NV temp_q1 = (j * arr[n_mj + 1 + k].p) / (2.0 + k);
6732 1128 100         if (temp_q1 < q1) {
6733 266           q1 = temp_q1;
6734             }
6735             }
6736             // q[ij] <- pmin(j * p[ij], q1)
6737 1272 100         for (size_t i = 0; i <= n_mj; i++) {
6738 1224           NV v = j * arr[i].p;
6739 1224 100         q_arr[i] = (v < q1) ? v : q1;
6740             }
6741             // q[i2] <- q[n - j]
6742 1224 100         for (size_t i = 0; i < i2_len; i++) {
6743 1176           q_arr[n_mj + 1 + i] = q_arr[n_mj];
6744             }
6745             // pa <- pmax(pa, q)
6746 2448 100         for (size_t i = 0; i < n; i++) {
6747 2400 100         if (pa[i] < q_arr[i]) {
6748 1401           pa[i] = q_arr[i];
6749             }
6750             }
6751             }
6752             // pmin(1, pmax(pa, p))[ro] — map sorted results back to original indices
6753 53 100         for (size_t i = 0; i < n; i++) {
6754 51 100         NV v = (pa[i] > arr[i].p) ? pa[i] : arr[i].p;
6755 51 50         if (v > 1.0) v = 1.0;
6756 51           adj[arr[i].orig_idx] = v;
6757             }
6758 2           Safefree(pa); Safefree(q_arr);
6759 1 50         } else if (strcmp(meth, "none") == 0) {
6760 0 0         for (size_t i = 0; i < n; i++) {
6761 0           adj[arr[i].orig_idx] = arr[i].p;
6762             }
6763             } else {
6764 1           Safefree(arr); Safefree(adj);
6765 1           croak("Unknown p-value adjustment method: %s", method);
6766             }
6767             // Push values onto the Perl stack as a flat list
6768 12 50         EXTEND(SP, n);
6769 318 100         for (size_t i = 0; i < n; i++) {
6770 306           PUSHs(sv_2mortal(newSVnv(adj[i])));
6771             }
6772 12           Safefree(arr); arr = NULL;
6773 12           Safefree(adj); adj = NULL;
6774              
6775             NV median(...)
6776             PROTOTYPE: @
6777             INIT:
6778 26           size_t total_count = 0, k = 0;
6779             NV* restrict nums;
6780 26           NV median_val = 0.0;
6781             CODE:
6782             // Pass 1: Count valid elements — die immediately on any undef
6783 54 100         for (size_t i = 0; i < items; i++) {
6784 30           SV* restrict arg = ST(i);
6785 52 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6786 23           AV* restrict av = (AV*)SvRV(arg);
6787 23           size_t len = av_len(av) + 1;
6788 348 100         for (size_t j = 0; j < len; j++) {
6789 326           SV** restrict tv = av_fetch(av, j, 0);
6790 326 50         if (tv && SvOK(*tv)) {
    100          
6791 325           total_count++;
6792             } else {
6793 1           croak("median: undefined value at array ref index %zu (argument %zu)", j, i);
6794             }
6795             }
6796 7 100         } else if (SvOK(arg)) {
6797 6           total_count++;
6798             } else {
6799 1           croak("median: undefined value at argument index %zu", i);
6800             }
6801             }
6802 24 100         if (total_count == 0) croak("median needs >= 1 element");
6803              
6804             /* Allocate C array now that we know the exact size */
6805 23 50         Newx(nums, total_count, NV);
6806              
6807             /* Pass 2: Populate the C array — Safefree before any croak */
6808 49 100         for (size_t i = 0; i < items; i++) {
6809 26           SV* restrict arg = ST(i);
6810 48 100         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    50          
6811 22           AV* restrict av = (AV*)SvRV(arg);
6812 22           size_t len = av_len(av) + 1;
6813 346 100         for (size_t j = 0; j < len; j++) {
6814 324           SV** restrict tv = av_fetch(av, j, 0);
6815 324 50         if (tv && SvOK(*tv)) {
    50          
6816 324           nums[k++] = SvNV(*tv);
6817             } else {
6818 0           Safefree(nums);
6819 0           croak("median: undefined value at array ref index %zu (argument %zu)", j, i);
6820             }
6821             }
6822 4 50         } else if (SvOK(arg)) {
6823 4           nums[k++] = SvNV(arg);
6824             } else {
6825 0           Safefree(nums);
6826 0           croak("median: undefined value at argument index %zu", i);
6827             }
6828             }
6829             /* Sort and calculate median */
6830 23           qsort(nums, total_count, sizeof(NV), compare_doubles);
6831 23 100         if (total_count % 2 == 0) {
6832 7           median_val = (nums[total_count / 2 - 1] + nums[total_count / 2]) / 2.0;
6833             } else {
6834 16           median_val = nums[total_count / 2];
6835             }
6836 23           Safefree(nums);
6837 23           nums = NULL;
6838 23 100         RETVAL = median_val;
6839             OUTPUT:
6840             RETVAL
6841              
6842             SV* cor(SV* x_sv, SV* y_sv = &PL_sv_undef, const char* method = "pearson")
6843             INIT:
6844             // --- validate method -------------------------------------------
6845 70 100         if (strcmp(method, "pearson") != 0 &&
6846 11 100         strcmp(method, "spearman") != 0 &&
6847 5 100         strcmp(method, "kendall") != 0)
6848 1           croak("cor: unknown method '%s' (use 'pearson', 'spearman', or 'kendall')",
6849             method);
6850              
6851             // --- validate x ------------------------------------------------
6852 69 50         if (!SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
6853 0           croak("cor: x must be an ARRAY reference");
6854              
6855 69           AV*restrict x_av = (AV*)SvRV(x_sv);
6856 69           size_t nx = av_len(x_av) + 1;
6857 69 50         if (nx == 0) croak("cor: x is empty");
6858              
6859             // --- detect whether x is a flat vector or a matrix (AoA) -------
6860 69           bool x_is_matrix = 0;
6861             {
6862 69           SV**restrict fp = av_fetch(x_av, 0, 0);
6863 69 50         if (fp && SvROK(*fp) && SvTYPE(SvRV(*fp)) == SVt_PVAV)
    100          
    50          
6864 1           x_is_matrix = 1;
6865             }
6866              
6867             // --- detect y ----------------------------
6868 138 50         bool has_y = (SvOK(y_sv) && SvROK(y_sv) &&
    50          
6869 69 50         SvTYPE(SvRV(y_sv)) == SVt_PVAV);
6870              
6871 69 50         AV*restrict y_av = has_y ? (AV*)SvRV(y_sv) : NULL;
6872 69 50         size_t ny = has_y ? av_len(y_av) + 1 : 0;
6873              
6874 69           bool y_is_matrix = 0;
6875 69 50         if (has_y && ny > 0) {
    50          
6876 69           SV**restrict fp = av_fetch(y_av, 0, 0);
6877 69 50         if (fp && SvROK(*fp) && SvTYPE(SvRV(*fp)) == SVt_PVAV)
    100          
    50          
6878 1           y_is_matrix = 1;
6879             }
6880              
6881             CODE:
6882             // Branch 1: both inputs are flat vectors → scalar result
6883 69 100         if (!x_is_matrix && !y_is_matrix) {
    50          
6884 68 50         if (!has_y) {
6885             /* cor(vector) == 1 by definition */
6886 0           RETVAL = newSVnv(1.0);
6887             } else {
6888 68 100         if (nx != ny)
6889 1           croak("cor: x and y must have the same length (%lu vs %lu)",
6890             nx, ny);
6891 67 50         if (nx < 2)
6892 0           croak("cor: need at least 2 observations");
6893             NV *restrict xd, *restrict yd;
6894 67 50         Newx(xd, nx, NV);
6895 67 50         Newx(yd, ny, NV);
6896 67           bool x_sd0 = 1, y_sd0 = 1;
6897 67           NV x_first = NAN, y_first = NAN;
6898 385 100         for (size_t i = 0; i < nx; i++) {
6899 318           SV**restrict tv = av_fetch(x_av, i, 0);
6900 318 50         NV val = (tv && SvOK(*tv) && looks_like_number(*tv)) ? SvNV(*tv) : NAN;
    50          
    50          
6901 318           xd[i] = val;
6902 318 50         if (!isnan(val)) {
6903 318 100         if (isnan(x_first)) x_first = val;
6904 251 100         else if (val != x_first) x_sd0 = 0;
6905             }
6906             }
6907 385 100         for (size_t i = 0; i < ny; i++) {
6908 318           SV**restrict tv = av_fetch(y_av, i, 0);
6909 318 50         NV val = (tv && SvOK(*tv) && looks_like_number(*tv)) ? SvNV(*tv) : NAN;
    50          
    50          
6910 318           yd[i] = val;
6911 318 50         if (!isnan(val)) {
6912 318 100         if (isnan(y_first)) y_first = val;
6913 251 100         else if (val != y_first) y_sd0 = 0;
6914             }
6915             }
6916 67 100         if (x_sd0 || y_sd0) {
    50          
6917 9           Safefree(xd); Safefree(yd);
6918 9 50         if (x_sd0) croak("cor: standard deviation of x is 0");
6919 0           croak("cor: standard deviation of y is 0");
6920             }
6921 58           NV r = compute_cor(xd, yd, nx, method);
6922 58           Safefree(xd); Safefree(yd);
6923 58           RETVAL = newSVnv(r);
6924             }
6925             } else {//Branch 2: x is a matrix (or y is a matrix) → AoA result
6926             // -- resolve x matrix dimensions
6927 1 50         if (!x_is_matrix)
6928 0           croak("cor: x must be a matrix (array ref of array refs) "
6929             "when y is a matrix");
6930              
6931 1           SV**restrict xr0 = av_fetch(x_av, 0, 0);
6932 1 50         if (!xr0 || !SvROK(*xr0) || SvTYPE(SvRV(*xr0)) != SVt_PVAV)
    50          
    50          
6933 0           croak("cor: each row of x must be an ARRAY reference");
6934              
6935 1           size_t ncols_x = av_len((AV*)SvRV(*xr0)) + 1;
6936 1 50         if (ncols_x == 0) croak("cor: x matrix has zero columns");
6937              
6938 1           size_t nrows = nx; /* observations */
6939              
6940             // PRE-VALIDATION PASS: Ensure all rows are arrays to prevent memory leaks on croak
6941 4 100         for (size_t i = 0; i < nrows; i++) {
6942 3           SV**restrict rv = av_fetch(x_av, i, 0);
6943 3 50         if (!rv || !SvROK(*rv) || SvTYPE(SvRV(*rv)) != SVt_PVAV)
    50          
    50          
6944 0           croak("cor: x row %lu is not an array ref", i);
6945             }
6946              
6947 1 50         if (has_y && y_is_matrix) {
    50          
6948 1 50         if (ny != nrows) croak("cor: x and y must have the same number of rows (%lu vs %lu)", nrows, ny);
6949 4 100         for (size_t i = 0; i < nrows; i++) {
6950 3           SV**restrict rv = av_fetch(y_av, i, 0);
6951 3 50         if (!rv || !SvROK(*rv) || SvTYPE(SvRV(*rv)) != SVt_PVAV)
    50          
    50          
6952 0           croak("cor: y row %lu is not an array ref", i);
6953             }
6954             }
6955             // -- extract x columns
6956             NV **restrict col_x;
6957 1 50         Newx(col_x, ncols_x, NV*);
6958 3 100         for (size_t j = 0; j < ncols_x; j++) {
6959 2 50         Newx(col_x[j], nrows, NV);
6960 2           bool sd0 = 1;
6961 2           NV first = NAN;
6962 8 100         for (size_t i = 0; i < nrows; i++) {
6963 6           SV**restrict rv = av_fetch(x_av, i, 0);
6964 6           AV*restrict row = (AV*)SvRV(*rv);
6965 6           SV**restrict cv = av_fetch(row, j, 0);
6966 6 50         NV val = (cv && SvOK(*cv) && looks_like_number(*cv)) ? SvNV(*cv) : NAN;
    50          
    50          
6967 6           col_x[j][i] = val;
6968 6 50         if (!isnan(val)) {
6969 6 100         if (isnan(first)) first = val;
6970 4 50         else if (val != first) sd0 = 0;
6971             }
6972             }
6973 2 50         if (sd0) {
6974 0 0         for (size_t k = 0; k <= j; k++) Safefree(col_x[k]);
6975 0           Safefree(col_x);
6976 0           croak("cor: standard deviation is 0 in x column %lu", j);
6977             }
6978             }
6979             // -- resolve y: separate matrix or re-use x (symmetric)
6980             size_t ncols_y;
6981 1           NV **restrict col_y = NULL;
6982 1           bool symmetric = 0;
6983             // 1 = cor(X) — result is symmetric
6984 2 50         if (has_y && y_is_matrix) {
    50          
6985             // cross-correlation: X (nrows × p) vs Y (nrows × q)
6986 1           SV**restrict yr0 = av_fetch(y_av, 0, 0);
6987 1           ncols_y = av_len((AV*)SvRV(*yr0)) + 1;
6988 1 50         if (ncols_y == 0) croak("cor: y matrix has zero columns");
6989              
6990 1 50         Newx(col_y, ncols_y, NV*);
6991 3 100         for (size_t j = 0; j < ncols_y; j++) {
6992 2 50         Newx(col_y[j], nrows, NV);
6993 2           bool sd0 = 1;
6994 2           NV first = NAN;
6995 8 100         for (size_t i = 0; i < nrows; i++) {
6996 6           SV**restrict rv = av_fetch(y_av, i, 0);
6997 6           AV*restrict row = (AV*)SvRV(*rv);
6998 6           SV**restrict cv = av_fetch(row, j, 0);
6999 6 50         NV val = (cv && SvOK(*cv) && looks_like_number(*cv)) ? SvNV(*cv) : NAN;
    50          
    50          
7000 6           col_y[j][i] = val;
7001 6 50         if (!isnan(val)) {
7002 6 100         if (isnan(first)) first = val;
7003 4 50         else if (val != first) sd0 = 0;
7004             }
7005             }
7006 2 50         if (sd0) {
7007 0 0         for (size_t k = 0; k < ncols_x; k++) Safefree(col_x[k]);
7008 0           Safefree(col_x);
7009 0 0         for (size_t k = 0; k <= j; k++) Safefree(col_y[k]);
7010 0           Safefree(col_y);
7011 0           croak("cor: standard deviation is 0 in y column %lu", j);
7012             }
7013             }
7014             } else { // cor(X) — symmetric p×p result; share column arrays
7015 0           ncols_y = ncols_x;
7016 0           col_y = col_x;
7017 0           symmetric = 1;
7018             }
7019 1 50         if (nrows < 2)
7020 0           croak("cor: need at least 2 observations (got %lu)", nrows);
7021             // -- build cache for symmetric case: compute upper triangle, store results, mirror to lower triangle
7022 1           AV*restrict result_av = newAV();
7023 1           av_extend(result_av, ncols_x - 1);
7024             // Allocate per-row AVs up front so we can fill them in order
7025             AV **restrict rows_out;
7026 1 50         Newx(rows_out, ncols_x, AV*);
7027 3 100         for (size_t i = 0; i < ncols_x; i++) {
7028 2           rows_out[i] = newAV();
7029 2           av_extend(rows_out[i], ncols_y - 1);
7030             }
7031 1 50         if (symmetric) {
7032             /* Upper triangle + diagonal, then mirror. r_cache[i][j] (j >= i) holds the computed value. */
7033             NV **restrict r_cache;
7034 0 0         Newx(r_cache, ncols_x, NV*);
7035 0 0         for (size_t i = 0; i < ncols_x; i++)
7036 0 0         Newx(r_cache[i], ncols_x, NV);
7037              
7038 0 0         for (size_t i = 0; i < ncols_x; i++) {
7039 0           r_cache[i][i] = 1.0; // diagonal
7040 0 0         for (size_t j = i + 1; j < ncols_x; j++) {
7041 0           NV r = compute_cor(col_x[i], col_x[j], nrows, method);
7042 0           r_cache[i][j] = r;
7043 0           r_cache[j][i] = r; // symmetry
7044             }
7045             }
7046             // fill output AoA from cache
7047 0 0         for (size_t i = 0; i < ncols_x; i++)
7048 0 0         for (size_t j = 0; j < ncols_x; j++)
7049 0           av_store(rows_out[i], j, newSVnv(r_cache[i][j]));
7050              
7051 0 0         for (size_t i = 0; i < ncols_x; i++) Safefree(r_cache[i]);
7052 0           Safefree(r_cache); r_cache = NULL;
7053             } else {
7054             // cross-correlation: every (i,j) pair is independent
7055 3 100         for (size_t i = 0; i < ncols_x; i++)
7056 6 100         for (size_t j = 0; j < ncols_y; j++)
7057 4           av_store(rows_out[i], j, newSVnv(compute_cor(col_x[i], col_y[j], nrows, method)));
7058             }
7059             // push row AVs into result
7060 3 100         for (size_t i = 0; i < ncols_x; i++)
7061 2           av_store(result_av, i, newRV_noinc((SV*)rows_out[i]));
7062 1           Safefree(rows_out); rows_out = NULL;
7063             // -- free column arrays -------------------------------------
7064 3 100         for (size_t j = 0; j < ncols_x; j++) Safefree(col_x[j]);
7065 1           Safefree(col_x); col_x = NULL;
7066 1 50         if (!symmetric) {
7067 3 100         for (size_t j = 0; j < ncols_y; j++) Safefree(col_y[j]);
7068 1           Safefree(col_y);
7069             }
7070 1           RETVAL = newRV_noinc((SV*)result_av);
7071             }
7072             OUTPUT:
7073             RETVAL
7074              
7075             void scale(...)
7076             PROTOTYPE: @
7077             PPCODE:
7078             {
7079 5           bool do_center_mean = TRUE, do_scale_sd = TRUE;
7080 5           NV center_val = 0.0, scale_val = 1.0;
7081 5           size_t data_items = items;
7082             // 1. Parse Options Hash (if it exists as the last argument)
7083 5 50         if (items > 0) {
7084 5           SV*restrict last_arg = ST(items - 1);
7085 5 100         if (SvROK(last_arg) && SvTYPE(SvRV(last_arg)) == SVt_PVHV) {
    100          
7086 2           data_items = items - 1; // Exclude hash from data processing
7087 2           HV*restrict opt_hv = (HV*)SvRV(last_arg);
7088             // --- Parse 'center'
7089 2           SV**restrict center_sv = hv_fetch(opt_hv, "center", 6, 0);
7090 2 50         if (center_sv) {
7091 2           SV*restrict val_sv = *center_sv;
7092 2 50         if (!SvOK(val_sv)) {
7093 0           do_center_mean = FALSE; center_val = 0.0;
7094             } else {
7095 2           char *restrict str = SvPV_nolen(val_sv);
7096             /* Trap booleans and empty strings before numeric checks */
7097 2 50         if (strcasecmp(str, "mean") == 0 || strcasecmp(str, "true") == 0 || strcmp(str, "1") == 0) {
    50          
    100          
7098 1           do_center_mean = TRUE;
7099 1 50         } else if (strcasecmp(str, "none") == 0 || strcasecmp(str, "false") == 0 || strcmp(str, "0") == 0 || strcmp(str, "") == 0) {
    50          
    50          
    0          
7100 1           do_center_mean = FALSE; center_val = 0.0;
7101 0 0         } else if (looks_like_number(val_sv)) {
7102 0           do_center_mean = FALSE; center_val = SvNV(val_sv);
7103 0 0         } else if (SvTRUE(val_sv)) {
7104 0           do_center_mean = TRUE;
7105             } else {
7106 0           do_center_mean = FALSE; center_val = 0.0;
7107             }
7108             }
7109             }
7110             // --- Parse 'scale' ---
7111 2           SV**restrict scale_sv = hv_fetch(opt_hv, "scale", 5, 0);
7112 2 100         if (scale_sv) {
7113 1           SV*restrict val_sv = *scale_sv;
7114 1 50         if (!SvOK(val_sv)) {
7115 0           do_scale_sd = FALSE; scale_val = 1.0;
7116             } else {
7117 1           char *restrict str = SvPV_nolen(val_sv);
7118 1 50         if (strcasecmp(str, "sd") == 0 || strcasecmp(str, "true") == 0 || strcmp(str, "1") == 0) {
    50          
    50          
7119 0           do_scale_sd = TRUE;
7120 1 50         } else if (strcasecmp(str, "none") == 0 || strcasecmp(str, "false") == 0 || strcmp(str, "0") == 0 || strcmp(str, "") == 0) {
    50          
    50          
    0          
7121 1           do_scale_sd = FALSE; scale_val = 1.0;
7122 0 0         } else if (looks_like_number(val_sv)) {
7123 0           do_scale_sd = FALSE; scale_val = SvNV(val_sv);
7124 0 0         if (scale_val == 0.0) scale_val = 1.0; /* Prevent Division By Zero */
7125 0 0         } else if (SvTRUE(val_sv)) {
7126 0           do_scale_sd = TRUE;
7127             } else {
7128 0           do_scale_sd = FALSE; scale_val = 1.0;
7129             }
7130             }
7131             }
7132             }
7133             }
7134             // 2. Detect if the input is a Matrix (Array of Arrays)
7135 5           bool is_matrix = FALSE;
7136 5 100         if (data_items == 1) {
7137 2           SV*restrict first_arg = ST(0);
7138 2 100         if (SvROK(first_arg) && SvTYPE(SvRV(first_arg)) == SVt_PVAV) {
    50          
7139 1           AV*restrict av = (AV*)SvRV(first_arg);
7140 1 50         if (av_len(av) >= 0) {
7141 1           SV**restrict first_elem = av_fetch(av, 0, 0);
7142 1 50         if (first_elem && SvROK(*first_elem) && SvTYPE(SvRV(*first_elem)) == SVt_PVAV) {
    50          
    50          
7143 1           is_matrix = TRUE;
7144             }
7145             }
7146             }
7147             }
7148 5 100         if (is_matrix) {
7149             // MATRIX MODE: Scale columns independently (Just like R)
7150 1           AV*restrict mat_av = (AV*)SvRV(ST(0));
7151 1           size_t nrow = av_len(mat_av) + 1, ncol = 0;
7152 1           SV**restrict first_row = av_fetch(mat_av, 0, 0);
7153 1           ncol = av_len((AV*)SvRV(*first_row)) + 1;
7154 1 50         if (nrow == 0 || ncol == 0) croak("scale requires non-empty matrix");
    50          
7155             // Create a new matrix for the scaled output
7156 1           AV*restrict result_av = newAV();
7157 1           av_extend(result_av, nrow - 1);
7158 1           AV**restrict row_ptrs = (AV**)safemalloc(nrow * sizeof(AV*));
7159 4 100         for (size_t r = 0; r < nrow; r++) {
7160 3           row_ptrs[r] = newAV();
7161 3           av_extend(row_ptrs[r], ncol - 1);
7162 3           av_push(result_av, newRV_noinc((SV*)row_ptrs[r]));
7163             }
7164             // Calculate and apply scale per column
7165 3 100         for (size_t c = 0; c < ncol; c++) {
7166 2           NV col_sum = 0.0;
7167             NV *restrict col_data;
7168 2 50         Newx(col_data, nrow, NV);
7169             // Extract the column data
7170 8 100         for (size_t r = 0; r < nrow; r++) {
7171 6           SV**restrict row_sv = av_fetch(mat_av, r, 0);
7172 6 50         if (row_sv && SvROK(*row_sv)) {
    50          
7173 6           AV*restrict row_av = (AV*)SvRV(*row_sv);
7174 6           SV**restrict cell_sv = av_fetch(row_av, c, 0);
7175 6 50         col_data[r] = (cell_sv && SvOK(*cell_sv)) ? SvNV(*cell_sv) : 0.0;
    50          
7176             } else {
7177 0           col_data[r] = 0.0;
7178             }
7179 6           col_sum += col_data[r];
7180             }
7181              
7182 2 50         NV col_center = do_center_mean ? (col_sum / nrow) : center_val;
7183 2           NV col_scale = scale_val;
7184             // Calculate Standard Deviation for this specific column if needed
7185 2 50         if (do_scale_sd) {
7186 2 50         if (nrow <= 1) {
7187 0           Safefree(col_data);
7188 0           safefree(row_ptrs);
7189 0           croak("scale needs >= 2 rows to calculate standard deviation for a matrix column");
7190             }
7191 2           NV sum_sq = 0.0;
7192 8 100         for (size_t r = 0; r < nrow; r++) {
7193 6           NV diff = col_data[r] - col_center;
7194 6           sum_sq += diff * diff;
7195             }
7196 2           col_scale = sqrt(sum_sq / (nrow - 1));
7197             }
7198             // Store scaled values back into the new matrix rows
7199 8 100         for (size_t r = 0; r < nrow; r++) {
7200 6           NV centered = col_data[r] - col_center;
7201 6 50         NV final_val = (col_scale == 0.0) ? (0.0 / 0.0) : (centered / col_scale);
7202 6           av_store(row_ptrs[r], c, newSVnv(final_val));
7203             }
7204 2           Safefree(col_data);
7205             }
7206 1           safefree(row_ptrs);
7207             // Push the resulting matrix as a single Reference onto the Perl stack
7208 1 50         EXTEND(SP, 1);
7209 1           PUSHs(sv_2mortal(newRV_noinc((SV*)result_av)));
7210             } else {
7211             // FLAT LIST MODE: Original functionality
7212 4           size_t total_count = 0, k = 0;
7213             NV *restrict nums;
7214 4           NV sum = 0.0;
7215 20 100         for (size_t i = 0; i < data_items; i++) {
7216 16           SV*restrict arg = ST(i);
7217 16 50         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    0          
7218 0           AV*restrict av = (AV*)SvRV(arg);
7219 0           size_t len = av_len(av) + 1;
7220 0 0         for (unsigned int j = 0; j < len; j++) {
7221 0           SV**restrict tv = av_fetch(av, j, 0);
7222 0 0         if (tv && SvOK(*tv)) { total_count++; }
    0          
7223             }
7224 16 50         } else if (SvOK(arg)) {
7225 16           total_count++;
7226             }
7227             }
7228 4 50         if (total_count == 0) croak("scale requires at least 1 numeric element");
7229 4 50         Newx(nums, total_count, NV);
7230 20 100         for (size_t i = 0; i < data_items; i++) {
7231 16           SV*restrict arg = ST(i);
7232 16 50         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) {
    0          
7233 0           AV*restrict av = (AV*)SvRV(arg);
7234 0           size_t len = av_len(av) + 1;
7235 0 0         for (size_t j = 0; j < len; j++) {
7236 0           SV**restrict tv = av_fetch(av, j, 0);
7237 0 0         if (tv && SvOK(*tv)) {
    0          
7238 0           NV val = SvNV(*tv);
7239 0           nums[k++] = val; sum += val;
7240             }
7241             }
7242 16 50         } else if (SvOK(arg)) {
7243 16           NV val = SvNV(arg);
7244 16           nums[k++] = val; sum += val;
7245             }
7246             }
7247 4 100         if (do_center_mean) center_val = sum / total_count;
7248 4 100         if (do_scale_sd) {
7249 3 100         if (total_count <= 1) {
7250 1           Safefree(nums);
7251 1           croak("scale needs >= 2 elements to calculate SD");
7252             }
7253 2           NV sum_sq = 0.0;
7254 12 100         for (size_t i = 0; i < total_count; i++) {
7255 10           NV diff = nums[i] - center_val;
7256 10           sum_sq += diff * diff;
7257             }
7258 2           scale_val = sqrt(sum_sq / (total_count - 1));
7259             }
7260 3 50         EXTEND(SP, total_count);
7261 18 100         for (size_t i = 0; i < total_count; i++) {
7262 15           NV centered = nums[i] - center_val;
7263 15 50         NV final_val = (scale_val == 0.0) ? (0.0 / 0.0) : (centered / scale_val);
7264 15           PUSHs(sv_2mortal(newSVnv(final_val)));
7265             }
7266 3           Safefree(nums); nums = NULL;
7267             }
7268             }
7269              
7270             SV* matrix(...)
7271             CODE:
7272 6           SV*restrict data_sv = NULL;
7273 6           size_t nrow = 0, ncol = 0;
7274 6           bool byrow = FALSE, nrow_set = FALSE, ncol_set = FALSE;
7275              
7276             /* Hybrid Argument Parser */
7277 6 50         if (items > 0 && SvROK(ST(0)) && SvTYPE(SvRV(ST(0))) == SVt_PVAV) {
    100          
    50          
7278             /* POSITIONAL: matrix($data_ref, $nrow, $ncol, $byrow) */
7279 1           data_sv = ST(0);
7280 1 50         if (items > 1 && SvOK(ST(1))) {
    50          
7281 1           nrow = (size_t)SvUV(ST(1));
7282 1           nrow_set = TRUE;
7283             }
7284 1 50         if (items > 2 && SvOK(ST(2))) {
    0          
7285 0           ncol = (size_t)SvUV(ST(2));
7286 0           ncol_set = TRUE;
7287             }
7288 1 50         if (items > 3 && SvOK(ST(3))) {
    0          
7289 0           byrow = SvTRUE(ST(3));
7290             }
7291 5 50         } else if (items % 2 == 0) {
7292             /* NAMED: matrix(data => [...], nrow => $n, ncol => $m) */
7293 16 100         for (size_t i = 0; i < items; i += 2) {
7294 11           char*restrict key = SvPV_nolen(ST(i));
7295 11           SV*restrict val = ST(i + 1);
7296 11 100         if (strEQ(key, "data")) {
7297 5           data_sv = val;
7298 6 100         } else if (strEQ(key, "nrow")) {
7299 4 50         if (SvOK(val)) { nrow = (size_t)SvUV(val); nrow_set = TRUE; }
7300 2 100         } else if (strEQ(key, "ncol")) {
7301 1 50         if (SvOK(val)) { ncol = (size_t)SvUV(val); ncol_set = TRUE; }
7302 1 50         } else if (strEQ(key, "byrow")) {
7303 1           byrow = SvTRUE(val);
7304             } else {
7305 0           croak("Unknown option: %s", key);
7306             }
7307             }
7308             } else {
7309 0           croak("Usage: matrix($data_ref, $nrow, $ncol, $byrow) OR matrix(data => $data_ref, ...)");
7310             }
7311             // Validate data input
7312 6 50         if (!data_sv || !SvROK(data_sv) || SvTYPE(SvRV(data_sv)) != SVt_PVAV) {
    100          
    50          
7313 1           croak("The 'data' option must be an array reference (e.g. [1..6] or rnorm(6))");
7314             }
7315 5           AV*restrict data_av = (AV*)SvRV(data_sv);
7316 5 50         size_t data_len = (UV)(av_top_index(data_av) + 1);
7317 5 100         if (data_len == 0) {
7318 1           croak("Data array cannot be empty");
7319             }
7320             // R-style dimension inference
7321 4 50         if (!nrow_set && !ncol_set) {
    0          
7322 0           nrow = data_len;
7323 0           ncol = 1;
7324 4 50         } else if (nrow_set && !ncol_set) {
    100          
7325 3           ncol = (data_len + nrow - 1) / nrow;
7326 1 50         } else if (!nrow_set && ncol_set) {
    0          
7327 0           nrow = (data_len + ncol - 1) / ncol;
7328             }
7329             // Final safety check for dimensions
7330 4 100         if (nrow == 0 || ncol == 0) {
    50          
7331 1           croak("Dimensions must be greater than 0");
7332             }
7333             // Create the matrix (Array of Arrays)
7334 3           AV*restrict result_av = newAV();
7335 3           av_extend(result_av, nrow - 1);
7336             size_t r, c; // Use unsigned types for counters to prevent negative indexing
7337 3           AV**restrict row_ptrs = (AV**restrict)safemalloc(nrow * sizeof(AV*)); /* Pre-allocate row pointers */
7338 9 100         for (r = 0; r < nrow; r++) {
7339 6           row_ptrs[r] = newAV();
7340 6           av_extend(row_ptrs[r], ncol - 1);
7341 6           av_push(result_av, newRV_noinc((SV*)row_ptrs[r]));
7342             }
7343             // Fill the matrix
7344 3           size_t total_cells = nrow * ncol;
7345 21 100         for (size_t i = 0; i < total_cells; i++) {
7346             // Vector recycling logic
7347 18           SV**restrict fetched = av_fetch(data_av, i % data_len, 0);
7348 18 50         SV*restrict val = fetched ? newSVsv(*fetched) : newSV(0);
7349 18 100         if (byrow) {
7350 6           r = i / ncol;
7351 6           c = i % ncol;
7352             } else {
7353 12           r = i % nrow;
7354 12           c = i / nrow;
7355             }
7356 18           av_store(row_ptrs[r], c, val);
7357             }
7358 3           safefree(row_ptrs);
7359 3           RETVAL = newRV_noinc((SV*)result_av);
7360             OUTPUT:
7361             RETVAL
7362              
7363             SV *
7364             lm(...)
7365             CODE:
7366             {
7367 27           const char *restrict formula = NULL;
7368 27           SV *restrict data_sv = NULL;
7369 27           char *restrict f_cpy = NULL; /* heap, sized to the formula */
7370             char *restrict src, *restrict dst, *restrict tilde, *restrict lhs, *restrict rhs, *restrict chunk;
7371 27           char **restrict terms = NULL, **restrict uniq_terms = NULL, **restrict exp_terms = NULL;
7372 27           bool *restrict is_dummy = NULL;
7373 27           char **restrict dummy_base = NULL, **restrict dummy_level = NULL;
7374 27           unsigned int term_cap = 64, exp_cap = 64, num_terms = 0, num_uniq = 0, p = 0, p_exp = 0;
7375 27           size_t n = 0, valid_n = 0, i, j, k, l;
7376 27           bool has_intercept = TRUE;
7377 27           char **restrict row_names = NULL, **restrict valid_row_names = NULL;
7378 27           HV **restrict row_hashes = NULL;
7379 27           HV *restrict data_hoa = NULL;
7380 27           SV *restrict ref = NULL;
7381 27           NV *restrict X = NULL, *restrict Y = NULL, *restrict XtX = NULL, *restrict XtY = NULL;
7382 27           bool *restrict aliased = NULL;
7383 27           NV *restrict beta = NULL;
7384 27           int final_rank = 0, df_res = 0;
7385             HV *restrict res_hv, *restrict coef_hv, *restrict fitted_hv, *restrict resid_hv, *restrict summary_hv;
7386             AV *restrict terms_av;
7387 27           NV rss = 0.0, rse_sq = 0.0;
7388             HE *restrict entry;
7389 27           char *rhs_expanded = NULL; /* heap, grows as needed */
7390 27           size_t rhs_len = 0, rhs_cap = 0;
7391              
7392 27 50         if (items % 2 != 0)
7393 0           croak("Usage: lm(formula => 'mpg ~ wt * hp', data => \\%%mtcars)");
7394              
7395 79 100         for (I32 i_arg = 0; i_arg < items; i_arg += 2) {
7396 52           const char *restrict key = SvPV_nolen(ST(i_arg));
7397 52           SV *restrict val = ST(i_arg + 1);
7398 52 100         if (strEQ(key, "formula")) formula = SvPV_nolen(val);
7399 26 50         else if (strEQ(key, "data")) data_sv = val;
7400 0           else croak("lm: unknown argument '%s'", key);
7401             }
7402 27 100         if (!formula) croak("lm: formula is required");
7403 26 100         if (!data_sv || !SvROK(data_sv)) croak("lm: data is required and must be a reference");
    100          
7404              
7405             /* PHASE 1: Data Extraction */
7406 24           ref = SvRV(data_sv);
7407 24 50         if (SvTYPE(ref) == SVt_PVHV) {
7408 24           HV *restrict hv = (HV*)ref;
7409 24 50         if (hv_iterinit(hv) == 0) croak("lm: Data hash is empty");
7410 24           entry = hv_iternext(hv);
7411 24 50         if (entry) {
7412 24           SV *restrict val = hv_iterval(hv, entry);
7413 24 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) {
    100          
7414 16           data_hoa = hv;
7415 16           n = (size_t)(av_len((AV*)SvRV(val)) + 1);
7416 16 50         Newx(row_names, n, char*);
7417 156 100         for (i = 0; i < n; i++) {
7418             char buf[32];
7419 140           snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i + 1));
7420 140           row_names[i] = savepv(buf);
7421             }
7422 8 50         } else if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) {
    50          
7423 8 50         n = (size_t)HvUSEDKEYS(hv);
7424 8 50         Newx(row_names, n, char*);
7425 8 50         Newx(row_hashes, n, HV*);
7426 8           hv_iterinit(hv);
7427 8           i = 0;
7428 233 100         while ((entry = hv_iternext(hv))) {
7429 226           SV *restrict rval = hv_iterval(hv, entry);
7430             /* BUG FIX: validate every row, not just the first */
7431 226 100         if (!SvROK(rval) || SvTYPE(SvRV(rval)) != SVt_PVHV) {
    50          
7432 2 100         for (k = 0; k < i; k++) Safefree(row_names[k]);
7433 1           Safefree(row_names); Safefree(row_hashes);
7434 1           croak("lm: Hash values must all be HashRefs (HoH)");
7435             }
7436             I32 klen;
7437 225           row_names[i] = savepv(hv_iterkey(entry, &klen));
7438 225           row_hashes[i] = (HV*)SvRV(rval);
7439 225           i++;
7440             }
7441 0           } else croak("lm: Hash values must be ArrayRefs (HoA) or HashRefs (HoH)");
7442             }
7443 0 0         } else if (SvTYPE(ref) == SVt_PVAV) {
7444 0           AV *restrict av = (AV*)ref;
7445 0           n = (size_t)(av_len(av) + 1);
7446 0 0         Newx(row_names, n, char*);
7447 0 0         Newx(row_hashes, n, HV*);
7448 0 0         for (i = 0; i < n; i++) {
7449 0           SV **restrict val = av_fetch(av, (SSize_t)i, 0);
7450 0 0         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVHV) {
    0          
    0          
7451 0           row_hashes[i] = (HV*)SvRV(*val);
7452             char buf[32];
7453 0           snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i + 1));
7454 0           row_names[i] = savepv(buf);
7455             } else {
7456 0 0         for (k = 0; k < i; k++) Safefree(row_names[k]);
7457 0           Safefree(row_names); Safefree(row_hashes);
7458 0           croak("lm: Array values must be HashRefs (AoH)");
7459             }
7460             }
7461 0           } else croak("lm: Data must be an Array or Hash reference");
7462              
7463             /* PHASE 2: Formula Parsing & `.` Expansion */
7464             /* IMPROVEMENT: copy the formula into a buffer sized to the formula
7465             * itself instead of a fixed 512-byte stack array (no truncation). */
7466 23           Newx(f_cpy, strlen(formula) + 1, char);
7467 23           src = (char*)formula; dst = f_cpy;
7468 2488 100         while (*src) { if (!isspace((unsigned char)*src)) *dst++ = *src; src++; }
    100          
7469 23           *dst = '\0';
7470              
7471 23           tilde = strchr(f_cpy, '~');
7472 23 100         if (!tilde) {
7473 3 100         for (i = 0; i < n; i++) Safefree(row_names[i]);
7474 1 50         Safefree(row_names); if (row_hashes) Safefree(row_hashes);
7475 1           Safefree(f_cpy);
7476 1           croak("lm: invalid formula, missing '~'");
7477             }
7478 22           *tilde = '\0';
7479 22           lhs = f_cpy;
7480 22           rhs = tilde + 1;
7481              
7482             /* Remove intercept-suppression markers from RHS, skipping I(...). */
7483             {
7484 22           char *restrict p_idx = rhs;
7485 2246 100         while (*p_idx) {
7486 2224 50         if (p_idx[0] == 'I' && p_idx[1] == '(') {
    0          
7487 0           int depth = 0;
7488 0 0         while (*p_idx) { if (*p_idx == '(') depth++; else if (*p_idx == ')') { depth--; if (depth == 0) { p_idx++; break; } } p_idx++; }
    0          
    0          
    0          
7489 0           continue;
7490             }
7491 2224 100         if (p_idx[0] == '-' && p_idx[1] == '1' &&
    50          
7492 1 50         (p_idx[2] == '\0' || p_idx[2] == '+' || p_idx[2] == '-')) {
    0          
    0          
7493 1           has_intercept = FALSE;
7494 1           memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1);
7495 1           continue;
7496             }
7497 2223 100         if (p_idx[0] == '+' && p_idx[1] == '0' &&
    50          
7498 0 0         (p_idx[2] == '\0' || p_idx[2] == '+' || p_idx[2] == '-')) {
    0          
    0          
7499 0           has_intercept = FALSE;
7500 0           memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1);
7501 0           continue;
7502             }
7503 2223 100         if (p_idx == rhs && p_idx[0] == '0' && p_idx[1] == '+') {
    50          
    0          
7504 0           has_intercept = FALSE;
7505 0           memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1);
7506 0           continue;
7507             }
7508 2223 100         if (p_idx == rhs && p_idx[0] == '0' && p_idx[1] == '\0') {
    50          
    0          
7509 0           has_intercept = FALSE; p_idx[0] = '\0'; break;
7510             }
7511 2223 100         if (p_idx[0] == '+' && p_idx[1] == '1' &&
    50          
7512 0 0         (p_idx[2] == '\0' || p_idx[2] == '+' || p_idx[2] == '-')) {
    0          
    0          
7513 0           memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1);
7514 0           continue;
7515             }
7516 2223 100         if (p_idx == rhs) {
7517 22 50         if (p_idx[0] == '1' && p_idx[1] == '\0') { p_idx[0] = '\0'; break; }
    0          
7518 22 50         if (p_idx[0] == '1' && p_idx[1] == '+') { memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1); continue; }
    0          
7519             }
7520 2223           p_idx++;
7521             }
7522             }
7523             /* Clean up stray `++`, leading `+`, trailing `+` */
7524             {
7525             char *restrict p_idx;
7526 22 50         while ((p_idx = strstr(rhs, "++")) != NULL)
7527 0           memmove(p_idx, p_idx + 1, strlen(p_idx + 1) + 1);
7528 22 50         if (rhs[0] == '+') memmove(rhs, rhs + 1, strlen(rhs + 1) + 1);
7529 22           size_t len_rhs = strlen(rhs);
7530 22 50         if (len_rhs > 0 && rhs[len_rhs - 1] == '+') rhs[len_rhs - 1] = '\0';
    50          
7531             }
7532              
7533             /* Expand `.` operator.
7534             * IMPROVEMENT: rhs_expanded is a heap buffer that grows on demand
7535             * (was a fixed 2048-byte array that silently truncated), and each
7536             * append is O(1) instead of strcat's O(n^2) rescan. */
7537 22           Newxz(rhs_expanded, 1, char); rhs_cap = 1; /* valid "" to start */
7538 22           chunk = strtok(rhs, "+");
7539 102 100         while (chunk != NULL) {
7540 80 100         if (strcmp(chunk, ".") == 0) {
7541 1           AV *restrict cols = get_all_columns(aTHX_ data_hoa, row_hashes, n);
7542 4 100         for (size_t c = 0; c <= (size_t)av_len(cols); c++) {
7543 3           SV **restrict col_sv = av_fetch(cols, (SSize_t)c, 0);
7544 3 50         if (col_sv && SvOK(*col_sv)) {
    50          
7545 3           const char *restrict col_name = SvPV_nolen(*col_sv);
7546 3 100         if (strcmp(col_name, lhs) != 0)
7547 2           lm_append(aTHX_ &rhs_expanded, &rhs_len, &rhs_cap, col_name);
7548             }
7549             }
7550 1           SvREFCNT_dec(cols);
7551             } else {
7552 79           lm_append(aTHX_ &rhs_expanded, &rhs_len, &rhs_cap, chunk);
7553             }
7554 80           chunk = strtok(NULL, "+");
7555             }
7556              
7557 22           Newx(terms, term_cap, char*); Newx(uniq_terms, term_cap, char*);
7558 22           Newx(exp_terms, exp_cap, char*); Newx(is_dummy, exp_cap, bool);
7559 22           Newx(dummy_base, exp_cap, char*); Newx(dummy_level, exp_cap, char*);
7560              
7561 22 100         if (has_intercept) terms[num_terms++] = savepv("Intercept");
7562              
7563 22 50         if (rhs_len > 0) {
7564 22           chunk = strtok(rhs_expanded, "+");
7565 103 100         while (chunk != NULL) {
7566 81 50         if (num_terms >= term_cap - 3) {
7567 0           term_cap *= 2;
7568 0           Renew(terms, term_cap, char*); Renew(uniq_terms, term_cap, char*);
7569             }
7570 81           char *restrict star = strchr(chunk, '*');
7571 81 100         if (star) {
7572 1           *star = '\0';
7573 1           char *restrict left = chunk;
7574 1           char *restrict right = star + 1;
7575 1           char *restrict c_l = strchr(left, '^');
7576 1 50         if (c_l && strncmp(left, "I(", 2) != 0) *c_l = '\0';
    0          
7577 1           char *restrict c_r = strchr(right, '^');
7578 1 50         if (c_r && strncmp(right, "I(", 2) != 0) *c_r = '\0';
    50          
7579 1           terms[num_terms++] = savepv(left);
7580 1           terms[num_terms++] = savepv(right);
7581 1           size_t inter_len = strlen(left) + strlen(right) + 2;
7582 1           terms[num_terms] = (char*)safemalloc(inter_len);
7583 1           snprintf(terms[num_terms++], inter_len, "%s:%s", left, right);
7584             } else {
7585 80           char *restrict c_chunk = strchr(chunk, '^');
7586 80 50         if (c_chunk && strncmp(chunk, "I(", 2) != 0) *c_chunk = '\0';
    0          
7587 80           terms[num_terms++] = savepv(chunk);
7588             }
7589 81           chunk = strtok(NULL, "+");
7590             }
7591             }
7592             /* done with the parsed RHS text */
7593 22           Safefree(rhs_expanded); rhs_expanded = NULL;
7594              
7595 126 100         for (i = 0; i < num_terms; i++) {
7596 104           bool found = FALSE;
7597 1424 50         for (j = 0; j < num_uniq; j++) { if (strcmp(terms[i], uniq_terms[j]) == 0) { found = TRUE; break; } }
    100          
7598 104 50         if (!found) uniq_terms[num_uniq++] = savepv(terms[i]);
7599             }
7600 22           p = num_uniq;
7601              
7602             /* PHASE 3: Categorical Expansion */
7603 126 100         for (j = 0; j < p; j++) {
7604 104 100         if (p_exp + 32 >= exp_cap) {
7605 1           exp_cap *= 2;
7606 1           Renew(exp_terms, exp_cap, char*); Renew(is_dummy, exp_cap, bool);
7607 1           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
7608             }
7609 104 100         if (strcmp(uniq_terms[j], "Intercept") == 0) {
7610 21           exp_terms[p_exp] = savepv("Intercept"); is_dummy[p_exp] = FALSE; p_exp++; continue;
7611             }
7612 83 100         if (is_column_categorical(aTHX_ data_hoa, row_hashes, n, uniq_terms[j])) {
7613 5           char **restrict levels = NULL;
7614 5           unsigned int num_levels = 0, levels_cap = 8;
7615 5           Newx(levels, levels_cap, char*);
7616 47 100         for (i = 0; i < n; i++) {
7617 42           char *restrict str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, uniq_terms[j]);
7618 42 50         if (str_val) {
7619 42           bool found = FALSE;
7620 81 100         for (l = 0; l < num_levels; l++) { if (strcmp(levels[l], str_val) == 0) { found = TRUE; break; } }
    100          
7621 42 100         if (!found) {
7622 14 50         if (num_levels >= levels_cap) { levels_cap *= 2; Renew(levels, levels_cap, char*); }
7623 14           levels[num_levels++] = savepv(str_val);
7624             }
7625 42           Safefree(str_val);
7626             }
7627             }
7628 5 50         if (num_levels > 0) {
7629             /* IMPROVEMENT: qsort instead of an O(n^2) bubble sort */
7630 5           qsort(levels, num_levels, sizeof(char*), lm_str_qsort);
7631 14 100         for (l = 1; l < num_levels; l++) {
7632 9 50         if (p_exp >= exp_cap) {
7633 0           exp_cap *= 2;
7634 0           Renew(exp_terms, exp_cap, char*); Renew(is_dummy, exp_cap, bool);
7635 0           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
7636             }
7637 9           size_t t_len = strlen(uniq_terms[j]) + strlen(levels[l]) + 1;
7638 9           exp_terms[p_exp] = (char*)safemalloc(t_len);
7639 9           snprintf(exp_terms[p_exp], t_len, "%s%s", uniq_terms[j], levels[l]);
7640 9           is_dummy[p_exp] = TRUE;
7641 9           dummy_base[p_exp] = savepv(uniq_terms[j]);
7642 9           dummy_level[p_exp] = savepv(levels[l]);
7643 9           p_exp++;
7644             }
7645 19 100         for (l = 0; l < num_levels; l++) Safefree(levels[l]);
7646 5           Safefree(levels);
7647             } else {
7648 0           Safefree(levels);
7649 0           exp_terms[p_exp] = savepv(uniq_terms[j]); is_dummy[p_exp] = FALSE; p_exp++;
7650             }
7651             } else {
7652 78           exp_terms[p_exp] = savepv(uniq_terms[j]); is_dummy[p_exp] = FALSE; p_exp++;
7653             }
7654             }
7655 22           p = p_exp;
7656 22 50         Newx(X, n * p, NV); Newx(Y, n, NV);
    50          
7657 22 50         Newx(valid_row_names, n, char*);
7658              
7659             /* PHASE 4: Matrix Construction & Listwise Deletion
7660             * IMPROVEMENT: write each candidate row straight into X at its
7661             * commit position instead of malloc/copy/free of a per-row scratch
7662             * buffer (removes n allocations and n*p copies). A dropped row's
7663             * partial writes are simply overwritten by the next candidate. */
7664 384 100         for (i = 0; i < n; i++) {
7665 362           NV y_val = evaluate_term(aTHX_ data_hoa, row_hashes, i, lhs);
7666 362 100         if (isnan(y_val)) { Safefree(row_names[i]); continue; }
7667              
7668 359           bool row_ok = TRUE;
7669 359           size_t base = valid_n * (size_t)p;
7670 4264 100         for (j = 0; j < p; j++) {
7671 3905 100         if (strcmp(exp_terms[j], "Intercept") == 0) {
7672 327           X[base + j] = 1.0;
7673 3578 100         } else if (is_dummy[j]) {
7674 78           char *restrict str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, dummy_base[j]);
7675 78 50         if (str_val) {
7676 78 100         X[base + j] = (strcmp(str_val, dummy_level[j]) == 0) ? 1.0 : 0.0;
7677 78           Safefree(str_val);
7678 0           } else { row_ok = FALSE; break; }
7679             } else {
7680 3500           NV v = evaluate_term(aTHX_ data_hoa, row_hashes, i, exp_terms[j]);
7681 3500 50         if (isnan(v)) { row_ok = FALSE; break; }
7682 3500           X[base + j] = v;
7683             }
7684             }
7685 359 50         if (!row_ok) { Safefree(row_names[i]); continue; }
7686 359           Y[valid_n] = y_val;
7687 359           valid_row_names[valid_n] = row_names[i];
7688 359           valid_n++;
7689             }
7690 22           Safefree(row_names);
7691              
7692 22 100         if (valid_n <= p) {
7693 11 100         for (i = 0; i < num_terms; i++) Safefree(terms[i]); Safefree(terms);
7694 11 100         for (i = 0; i < num_uniq; i++) Safefree(uniq_terms[i]); Safefree(uniq_terms);
7695 11 100         for (j = 0; j < p_exp; j++) {
7696 8           Safefree(exp_terms[j]);
7697 8 50         if (is_dummy[j]) { Safefree(dummy_base[j]); Safefree(dummy_level[j]); }
7698             }
7699 3           Safefree(exp_terms); Safefree(is_dummy); Safefree(dummy_base); Safefree(dummy_level);
7700             /* BUG FIX: free the committed row-name strings, not just the array */
7701 8 100         for (i = 0; i < valid_n; i++) Safefree(valid_row_names[i]);
7702 3           Safefree(X); Safefree(Y); Safefree(valid_row_names);
7703 3 50         if (row_hashes) Safefree(row_hashes);
7704 3           Safefree(f_cpy);
7705 3           croak("lm: 0 degrees of freedom (too many NAs or parameters > observations)");
7706             }
7707             /* lhs (into f_cpy) is no longer needed past PHASE 4 */
7708 19           Safefree(f_cpy); f_cpy = NULL;
7709              
7710             /* IMPROVEMENT: reclaim the tail of X left unused by listwise deletion */
7711 19 50         if (valid_n < n) Renew(X, valid_n * (size_t)p, NV);
    0          
7712              
7713             /* PHASE 5: OLS Math */
7714 19           Newxz(XtX, p * p, NV);
7715 119 100         for (i = 0; i < p; i++)
7716 2842 100         for (j = 0; j < p; j++) {
7717 2742           NV sum = 0.0;
7718 161321 100         for (k = 0; k < valid_n; k++) sum += X[k * p + i] * X[k * p + j];
7719 2742           XtX[i * p + j] = sum;
7720             }
7721 19           Newxz(XtY, p, NV);
7722 119 100         for (i = 0; i < p; i++) {
7723 100           NV sum = 0.0;
7724 3991 100         for (k = 0; k < valid_n; k++) sum += X[k * p + i] * Y[k];
7725 100           XtY[i] = sum;
7726             }
7727 19           Newx(aliased, p, bool);
7728 19           final_rank = sweep_matrix_ols(XtX, p, aliased);
7729 19           Newxz(beta, p, NV);
7730 119 100         for (i = 0; i < p; i++) {
7731 100 100         if (aliased[i]) { beta[i] = NAN; }
7732             else {
7733 51           NV sum = 0.0;
7734 342 100         for (j = 0; j < p; j++) if (!aliased[j]) sum += XtX[i * p + j] * XtY[j];
    100          
7735 51           beta[i] = sum;
7736             }
7737             }
7738              
7739             /* PHASE 6: Metrics & Cleanup */
7740 19           res_hv = newHV(); coef_hv = newHV(); fitted_hv = newHV(); resid_hv = newHV();
7741 19           summary_hv = newHV(); terms_av = newAV();
7742 19           df_res = (int)valid_n - final_rank;
7743 19           NV sum_y = 0.0, mss = 0.0;
7744 373 100         for (i = 0; i < valid_n; i++) sum_y += Y[i];
7745 19           NV mean_y = sum_y / (NV)valid_n;
7746 373 100         for (i = 0; i < valid_n; i++) {
7747 354           NV y_hat = 0.0;
7748 4245 100         for (j = 0; j < p; j++) if (!aliased[j]) y_hat += X[i * p + j] * beta[j];
    100          
7749 354           NV res = Y[i] - y_hat;
7750 354           rss += res * res;
7751 354 100         NV diff_m = has_intercept ? (y_hat - mean_y) : y_hat;
7752 354           mss += diff_m * diff_m;
7753 354           hv_store(fitted_hv, valid_row_names[i], strlen(valid_row_names[i]), newSVnv(y_hat), 0);
7754 354           hv_store(resid_hv, valid_row_names[i], strlen(valid_row_names[i]), newSVnv(res), 0);
7755 354           Safefree(valid_row_names[i]);
7756             }
7757 19           Safefree(valid_row_names);
7758 19 50         rse_sq = (df_res > 0) ? (rss / (NV)df_res) : NAN;
7759              
7760 19           int df_int = has_intercept ? 1 : 0;
7761 19           NV r_squared = 0.0, adj_r_squared = 0.0, f_stat = NAN, f_pvalue = NAN;
7762 19           int numdf = final_rank - df_int;
7763              
7764 19 50         if (final_rank != df_int && (mss + rss) > 0.0) {
    50          
7765 19           r_squared = mss / (mss + rss);
7766 19           adj_r_squared = 1.0 - (1.0 - r_squared) * ((NV)(valid_n - df_int) / (NV)df_res);
7767 19 100         if (rse_sq > 0.0 && numdf > 0) {
    50          
7768 17           f_stat = (mss / (NV)numdf) / rse_sq;
7769 17           f_pvalue = 1.0 - pf(f_stat, (NV)numdf, (NV)df_res);
7770 2 50         } else if (rse_sq == 0.0) {
7771 2           f_stat = INFINITY;
7772 2           f_pvalue = 0.0;
7773             }
7774 0 0         } else if (final_rank == df_int) {
7775 0           r_squared = 0.0; adj_r_squared = 0.0;
7776             }
7777 119 100         for (j = 0; j < p; j++) {
7778 100           hv_store(coef_hv, exp_terms[j], strlen(exp_terms[j]), newSVnv(beta[j]), 0);
7779 100           av_push(terms_av, newSVpv(exp_terms[j], 0));
7780 100           HV *restrict row_hv = newHV();
7781 100 100         if (aliased[j]) {
7782 49           hv_store(row_hv, "Estimate", 8, newSVpv("NaN", 0), 0);
7783 49           hv_store(row_hv, "Std. Error", 10, newSVpv("NaN", 0), 0);
7784 49           hv_store(row_hv, "t value", 7, newSVpv("NaN", 0), 0);
7785 49           hv_store(row_hv, "Pr(>|t|)", 8, newSVpv("NaN", 0), 0);
7786             } else {
7787 51           NV se = sqrt(rse_sq * XtX[j * p + j]);
7788 51 100         NV t_val = (se > 0.0) ? (beta[j] / se) : (INFINITY * (beta[j] >= 0.0 ? 1.0 : -1.0));
    50          
7789 51           NV p_val = get_t_pvalue(t_val, df_res, "two.sided");
7790 51           hv_store(row_hv, "Estimate", 8, newSVnv(beta[j]), 0);
7791 51           hv_store(row_hv, "Std. Error", 10, newSVnv(se), 0);
7792 51           hv_store(row_hv, "t value", 7, newSVnv(t_val), 0);
7793 51           hv_store(row_hv, "Pr(>|t|)", 8, newSVnv(p_val), 0);
7794             }
7795 100           hv_store(summary_hv, exp_terms[j], strlen(exp_terms[j]), newRV_noinc((SV*)row_hv), 0);
7796             }
7797 19           hv_store(res_hv, "coefficients", 12, newRV_noinc((SV*)coef_hv), 0);
7798 19           hv_store(res_hv, "fitted.values", 13, newRV_noinc((SV*)fitted_hv), 0);
7799 19           hv_store(res_hv, "residuals", 9, newRV_noinc((SV*)resid_hv), 0);
7800 19           hv_store(res_hv, "df.residual", 11, newSVuv(df_res), 0);
7801 19           hv_store(res_hv, "rank", 4, newSVuv(final_rank), 0);
7802 19           hv_store(res_hv, "rss", 3, newSVnv(rss), 0);
7803 19           hv_store(res_hv, "summary", 7, newRV_noinc((SV*)summary_hv),0);
7804 19           hv_store(res_hv, "terms", 5, newRV_noinc((SV*)terms_av), 0);
7805 19           hv_store(res_hv, "r.squared", 9, newSVnv(r_squared), 0);
7806 19           hv_store(res_hv, "adj.r.squared", 13, newSVnv(adj_r_squared), 0);
7807 19 50         if (!isnan(f_stat)) {
7808 19           AV *fstat_av = newAV();
7809 19           av_push(fstat_av, newSVnv(f_stat));
7810 19           av_push(fstat_av, newSViv(numdf));
7811 19           av_push(fstat_av, newSViv(df_res));
7812 19           hv_store(res_hv, "fstatistic", 10, newRV_noinc((SV*)fstat_av), 0);
7813 19           hv_store(res_hv, "f.pvalue", 8, newSVnv(f_pvalue), 0);
7814             }
7815             /* Deep Cleanup */
7816 115 100         for (i = 0; i < num_terms; i++) Safefree(terms[i]); Safefree(terms);
7817 115 100         for (i = 0; i < num_uniq; i++) Safefree(uniq_terms[i]); Safefree(uniq_terms);
7818 119 100         for (j = 0; j < p_exp; j++) {
7819 100           Safefree(exp_terms[j]);
7820 100 100         if (is_dummy[j]) { Safefree(dummy_base[j]); Safefree(dummy_level[j]); }
7821             }
7822 19           Safefree(exp_terms); Safefree(is_dummy); Safefree(dummy_base); Safefree(dummy_level);
7823 19           Safefree(X); Safefree(Y); Safefree(XtX); Safefree(XtY);
7824 19           Safefree(beta); Safefree(aliased);
7825 19 100         if (row_hashes) Safefree(row_hashes);
7826              
7827 19           RETVAL = newRV_noinc((SV*)res_hv);
7828             }
7829             OUTPUT:
7830             RETVAL
7831              
7832             void seq(from, to, by = 1.0)
7833             NV from
7834             NV to
7835             NV by
7836             PPCODE:
7837             {
7838             //Handle the zero 'by' case
7839 6 50         if (by == 0.0) {
7840 0 0         if (from == to) {
7841 0 0         EXTEND(SP, 1);
7842 0           mPUSHn(from);
7843 0           XSRETURN(1);
7844             } else {
7845 0           croak("invalid 'by' argument: cannot be zero when from != to");
7846             }
7847             }
7848             // Check for wrong direction / infinite loop
7849 6 100         if ((from < to && by < 0.0) || (from > to && by > 0.0)) {
    50          
    100          
    50          
7850 0           croak("wrong sign in 'by' argument");
7851             }
7852             /* * Calculate number of elements.
7853             * R uses a small epsilon (like 1e-10) to avoid dropping the last
7854             * element due to floating point inaccuracies.
7855             */
7856 6           NV n_elements_d = (to - from) / by;
7857 6 50         if (n_elements_d < 0.0) n_elements_d = 0.0;
7858 6           size_t n_elements = (n_elements_d + 1e-10) + 1;
7859             // Pre-extend the stack to avoid reallocating inside the loop
7860 6 50         EXTEND(SP, n_elements);
7861 3033 100         for (size_t i = 0; i < n_elements; i++) {
7862 3027           mPUSHn(from + i * by);
7863             }
7864 6           XSRETURN(n_elements);
7865             }
7866              
7867             SV* rnorm(...)
7868             CODE:
7869             {
7870             // Auto-seed the PRNG if the Perl script hasn't done so yet
7871 2 100         AUTO_SEED_PRNG();
7872 2           size_t n = 0;
7873 2           NV mean = 0.0, sd = 1.0;
7874 2           int arg_start = 0;
7875             // Check if the first argument is a simple integer (rnorm(33))
7876 2 50         if (items > 0 && SvIOK(ST(0)) && (items == 1 || items % 2 != 0)) {
    50          
    0          
    0          
7877 0           n = (unsigned int)SvUV(ST(0));
7878 0           arg_start = 1; // Start parsing named arguments from the second element
7879             }
7880              
7881             // --- Parse remaining named arguments from the flat stack ---
7882 2 50         if ((items - arg_start) % 2 != 0) {
7883 0           croak("Usage: rnorm(n), rnorm(n => 10, mean => 0, sd => 1), or rnorm(33, mean => 0)");
7884             }
7885              
7886 7 100         for (int i = arg_start; i < items; i += 2) {
7887 5           const char* restrict key = SvPV_nolen(ST(i));
7888 5           SV* restrict val = ST(i + 1);
7889              
7890 5 100         if (strEQ(key, "n")) n = (unsigned int)SvUV(val);
7891 3 100         else if (strEQ(key, "mean")) mean = SvNV(val);
7892 2 50         else if (strEQ(key, "sd")) sd = SvNV(val);
7893 0           else croak("rnorm: unknown argument '%s'", key);
7894             }
7895 2 100         if (sd < 0.0) croak("rnorm: standard deviation must be non-negative");
7896 1           AV *restrict result_av = newAV();
7897 1 50         if (n > 0) {
7898 1           av_extend(result_av, n - 1);
7899             // Generate random normals using the Box-Muller transform
7900 5002 100         for (size_t i = 0; i < n; ) {
7901             NV u, v, s;
7902             do {
7903             // Drand01() hooks into Perl's internal PRNG, respecting Perl's srand()
7904 6411           u = 2.0 * Drand01() - 1.0;
7905 6411           v = 2.0 * Drand01() - 1.0;
7906 6411           s = u * u + v * v;
7907 6411 100         } while (s >= 1.0 || s == 0.0);
    50          
7908 5000           NV mul = sqrt(-2.0 * log(s) / s);
7909             // Box-Muller generates two independent values per iteration
7910 5000           av_store(result_av, i++, newSVnv(mean + sd * u * mul));
7911 5000 100         if (i < n) {
7912 4999           av_store(result_av, i++, newSVnv(mean + sd * v * mul));
7913             }
7914             }
7915             }
7916 1           RETVAL = newRV_noinc((SV*)result_av);
7917             }
7918             OUTPUT:
7919             RETVAL
7920              
7921             SV* aov(data_sv, formula_sv = &PL_sv_undef)
7922             SV* data_sv
7923             SV* formula_sv
7924             CODE:
7925             {
7926             const char *restrict formula;
7927 10           SV *restrict orig_data_sv = data_sv;
7928 10           bool is_stacked = FALSE;
7929             //
7930             // PHASE 0: R-style stack() for missing formula
7931             //
7932 10 50         if (!formula_sv || !SvOK(formula_sv) || SvCUR(formula_sv) == 0) {
    100          
    50          
7933 1 50         if (!SvROK(data_sv) || SvTYPE(SvRV(data_sv)) != SVt_PVHV) {
    50          
7934 0           croak("aov: Without a formula, data must be a HashRef of ArrayRefs (mimicking R's named list)");
7935             }
7936              
7937 1           is_stacked = TRUE;
7938 1           HV *restrict input_hv = (HV*)SvRV(data_sv);
7939 1           HV *restrict stacked_hv = newHV();
7940 1           AV *restrict val_av = newAV();
7941 1           AV *restrict grp_av = newAV();
7942 1           hv_iterinit(input_hv);
7943             HE *restrict entry;
7944 3 100         while ((entry = hv_iternext(input_hv))) {
7945 2           SV *restrict grp_name_sv = hv_iterkeysv(entry);
7946 2           SV *restrict arr_ref = hv_iterval(input_hv, entry);
7947 4 50         if (SvROK(arr_ref) && SvTYPE(SvRV(arr_ref)) == SVt_PVAV) {
    50          
7948 2           AV *restrict arr = (AV*)SvRV(arr_ref);
7949 2           size_t len = av_len(arr);
7950 14 100         for (size_t k = 0; k <= len; k++) {
7951 12           SV **restrict v = av_fetch(arr, k, 0);
7952 12 50         if (v && *v && SvOK(*v)) {
    50          
    50          
7953 12           av_push(val_av, newSVsv(*v));
7954 12           av_push(grp_av, newSVsv(grp_name_sv));
7955             }
7956             }
7957             } else {
7958 0           SvREFCNT_dec(val_av); SvREFCNT_dec(grp_av); SvREFCNT_dec(stacked_hv);
7959 0           croak("aov: Hash values must be ArrayRefs when no formula is provided");
7960             }
7961             }
7962 1           hv_stores(stacked_hv, "Value", newRV_noinc((SV*)val_av));
7963 1           hv_stores(stacked_hv, "Group", newRV_noinc((SV*)grp_av));
7964             // sv_2mortal ensures memory is freed automatically on return or croak
7965 1           data_sv = sv_2mortal(newRV_noinc((SV*)stacked_hv));
7966 1           formula = "Value~Group";
7967             } else {
7968 9           formula = SvPV_nolen(formula_sv);
7969             }
7970             char f_cpy[512];
7971             char *restrict src, *restrict dst, *restrict tilde, *restrict lhs, *restrict rhs, *restrict chunk;
7972 10           char **restrict terms = NULL, **restrict uniq_terms = NULL, **restrict exp_terms = NULL, **restrict parent_term = NULL;
7973 10           bool *restrict is_dummy = NULL, *is_interact = NULL;
7974 10           char **restrict dummy_base = NULL, **restrict dummy_level = NULL;
7975 10           int *restrict term_map = NULL, *restrict left_idx = NULL, *restrict right_idx = NULL;
7976 10           unsigned int term_cap = 64, exp_cap = 64, num_terms = 0, num_uniq = 0, p = 0, p_exp = 0;
7977 10           size_t n = 0, valid_n = 0, i, j;
7978 10           bool has_intercept = TRUE;
7979 10           char **restrict row_names = NULL;
7980 10           HV **restrict row_hashes = NULL;
7981 10           HV *restrict data_hoa = NULL;
7982 10           SV *restrict ref = NULL;
7983             HE *restrict entry;
7984 10           NV **restrict X_mat = NULL;
7985 10           NV *restrict Y = NULL;
7986 10           char **restrict term_base_level = NULL; /* reference level for each uniq_term (NULL if not categorical) */
7987 10 50         if (!SvROK(data_sv)) croak("aov: data is required and must be a reference");
7988             //
7989             // PHASE 1: Data Extraction
7990             //
7991 10           ref = SvRV(data_sv);
7992 10 50         if (SvTYPE(ref) == SVt_PVHV) {
7993 10           HV*restrict hv = (HV*)ref;
7994 10 50         if (hv_iterinit(hv) == 0) croak("aov: Data hash is empty");
7995 10           entry = hv_iternext(hv);
7996 10 50         if (entry) {
7997 10           SV*restrict val = hv_iterval(hv, entry);
7998 10 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) {
    50          
7999 10           data_hoa = hv;
8000 10           n = av_len((AV*)SvRV(val)) + 1;
8001 10 50         Newx(row_names, n, char*);
8002 80 100         for(i = 0; i < n; i++) {
8003 70           char buf[32]; snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i+1));
8004 70           row_names[i] = savepv(buf);
8005             }
8006 0 0         } else if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) {
    0          
8007 0           n = hv_iterinit(hv);
8008 0 0         Newx(row_names, n, char*); Newx(row_hashes, n, HV*);
    0          
8009 0           i = 0;
8010 0 0         while ((entry = hv_iternext(hv))) {
8011             I32 len;
8012 0           row_names[i] = savepv(hv_iterkey(entry, &len));
8013 0           row_hashes[i] = (HV*)SvRV(hv_iterval(hv, entry));
8014 0           i++;
8015             }
8016 0           } else croak("aov: Hash values must be ArrayRefs (HoA) or HashRefs (HoH)");
8017             }
8018 0 0         } else if (SvTYPE(ref) == SVt_PVAV) {
8019 0           AV*restrict av = (AV*)ref;
8020 0           n = av_len(av) + 1;
8021 0 0         Newx(row_names, n, char*);
8022 0 0         Newx(row_hashes, n, HV*);
8023 0 0         for (i = 0; i < n; i++) {
8024 0           SV**restrict val = av_fetch(av, i, 0);
8025 0 0         if (val && SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVHV) {
    0          
    0          
8026 0           row_hashes[i] = (HV*)SvRV(*val);
8027             char buf[32];
8028 0           snprintf(buf, sizeof(buf), "%lu", (unsigned long)(i + 1));
8029 0           row_names[i] = savepv(buf);
8030             } else {
8031 0 0         for (size_t k = 0; k < i; k++) Safefree(row_names[k]);
8032 0           Safefree(row_names); Safefree(row_hashes);
8033 0           croak("aov: Array values must be HashRefs (AoH)");
8034             }
8035             }
8036 0           } else croak("aov: Data must be an Array or Hash reference");
8037             //
8038             // PHASE 2: Formula Parsing & `.` Expansion
8039             //
8040 10           src = (char*)formula; dst = f_cpy;
8041 123 100         while (*src && (dst - f_cpy < 511)) { if (!isspace(*src)) { *dst++ = *src; } src++; }
    100          
    50          
8042 10           *dst = '\0';
8043 10           tilde = strchr(f_cpy, '~');
8044 10 100         if (!tilde) {
8045 3 100         for (i = 0; i < n; i++) Safefree(row_names[i]);
8046 1 50         Safefree(row_names); if (row_hashes) Safefree(row_hashes);
8047 1           croak("aov: invalid formula, missing '~'");
8048             }
8049 9           *tilde = '\0';
8050 9           lhs = f_cpy;
8051 9           rhs = tilde + 1;
8052             char *restrict p_idx;
8053 9 50         while ((p_idx = strstr(rhs, "-1")) != NULL) { has_intercept = FALSE; memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1); }
8054 9 50         while ((p_idx = strstr(rhs, "+0")) != NULL) { has_intercept = FALSE; memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1); }
8055 9 50         while ((p_idx = strstr(rhs, "0+")) != NULL) { has_intercept = FALSE; memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1); }
8056 9 50         if (rhs[0] == '0' && rhs[1] == '\0') { has_intercept = FALSE; rhs[0] = '\0'; }
    0          
8057 9 50         while ((p_idx = strstr(rhs, "+1")) != NULL) { memmove(p_idx, p_idx + 2, strlen(p_idx + 2) + 1); }
8058 9 50         if (rhs[0] == '1' && rhs[1] == '\0') { rhs[0] = '\0'; }
    0          
8059 9 50         else if (rhs[0] == '1' && rhs[1] == '+') { memmove(rhs, rhs + 2, strlen(rhs + 2) + 1); }
    0          
8060              
8061 9 50         while ((p_idx = strstr(rhs, "++")) != NULL) memmove(p_idx, p_idx + 1, strlen(p_idx + 1) + 1);
8062 9 50         if (rhs[0] == '+') memmove(rhs, rhs + 1, strlen(rhs + 1) + 1);
8063 9           size_t len_rhs = strlen(rhs);
8064 9 50         if (len_rhs > 0 && rhs[len_rhs - 1] == '+') rhs[len_rhs - 1] = '\0';
    50          
8065 9           char rhs_expanded[2048] = "";
8066 9           size_t rhs_len = 0;
8067 9           chunk = strtok(rhs, "+");
8068 21 100         while (chunk != NULL) {
8069 12 100         if (strcmp(chunk, ".") == 0) {
8070 1           AV *restrict cols = get_all_columns(aTHX_ data_hoa, row_hashes, n);
8071 4 100         for (size_t c = 0; c <= av_len(cols); c++) {
8072 3           SV **restrict col_sv = av_fetch(cols, c, 0);
8073 3 50         if (col_sv && SvOK(*col_sv)) {
    50          
8074 3           const char *restrict col_name = SvPV_nolen(*col_sv);
8075 3 100         if (strcmp(col_name, lhs) != 0) {
8076 2           size_t slen = strlen(col_name);
8077 2 50         if (rhs_len + slen + 2 < sizeof(rhs_expanded)) {
8078 2 100         if (rhs_len > 0) { strcat(rhs_expanded, "+"); rhs_len++; }
8079 2           strcat(rhs_expanded, col_name);
8080 2           rhs_len += slen;
8081             }
8082             }
8083             }
8084             }
8085 1           SvREFCNT_dec(cols);
8086             } else {
8087 11           size_t slen = strlen(chunk);
8088 11 50         if (rhs_len + slen + 2 < sizeof(rhs_expanded)) {
8089 11 100         if (rhs_len > 0) { strcat(rhs_expanded, "+"); rhs_len++; }
8090 11           strcat(rhs_expanded, chunk);
8091 11           rhs_len += slen;
8092             }
8093             }
8094 12           chunk = strtok(NULL, "+");
8095             }
8096             // Setup arrays safely
8097 9           Newx(terms, term_cap, char*);
8098 9           Newx(uniq_terms, term_cap, char*);
8099 9           Newx(exp_terms, exp_cap, char*); Newx(parent_term, exp_cap, char*);
8100 9           Newx(is_dummy, exp_cap, bool); Newx(is_interact, exp_cap, bool);
8101 9           Newx(dummy_base, exp_cap, char*); Newx(dummy_level, exp_cap, char*);
8102 9           Newx(term_map, exp_cap, int); Newx(left_idx, exp_cap, int); Newx(right_idx, exp_cap, int);
8103 9 50         if (has_intercept) { terms[num_terms++] = savepv("Intercept"); }
8104 9 50         if (strlen(rhs_expanded) > 0) {
8105 9           chunk = strtok(rhs_expanded, "+");
8106 22 100         while (chunk != NULL) {
8107 13 50         if (num_terms >= term_cap - 3) {
8108 0           term_cap *= 2;
8109 0           Renew(terms, term_cap, char*); Renew(uniq_terms, term_cap, char*);
8110             }
8111 13           char *restrict star = strchr(chunk, '*');
8112 13 100         if (star) {
8113 1           *star = '\0';
8114 1           char *restrict left = chunk;
8115 1           char *restrict right = star + 1;
8116 1           char *restrict c_l = strchr(left, '^');
8117 1 50         if (c_l && strncmp(left, "I(", 2) != 0) *c_l = '\0';
    0          
8118 1 50         char *restrict c_r = strchr(right, '^'); if (c_r && strncmp(right, "I(", 2) != 0) *c_r = '\0';
    0          
8119 1           terms[num_terms++] = savepv(left);
8120 1           terms[num_terms++] = savepv(right);
8121 1           size_t inter_len = strlen(left) + strlen(right) + 2;
8122 1           terms[num_terms] = (char*)safemalloc(inter_len);
8123 1           snprintf(terms[num_terms++], inter_len, "%s:%s", left, right);
8124             } else {
8125 12           char *restrict c_chunk = strchr(chunk, '^');
8126 12 50         if (c_chunk && strncmp(chunk, "I(", 2) != 0) *c_chunk = '\0';
    0          
8127 12           terms[num_terms++] = savepv(chunk);
8128             }
8129 13           chunk = strtok(NULL, "+");
8130             }
8131             }
8132              
8133 33 100         for (i = 0; i < num_terms; i++) {
8134 24           bool found = FALSE;
8135 46 100         for (size_t k = 0; k < num_uniq; k++) {
8136 22 50         if (strcmp(terms[i], uniq_terms[k]) == 0) { found = TRUE; break; }
8137             }
8138 24 50         if (!found) uniq_terms[num_uniq++] = savepv(terms[i]);
8139             }
8140 9           p = num_uniq;
8141              
8142 9           Newxz(term_base_level, num_uniq, char*);
8143              
8144             /* PHASE 3: Categorical & Interaction Expansion */
8145 32 100         for (j = 0; j < p; j++) {
8146 24 100         if (p_exp + 64 >= exp_cap) {
8147 9           exp_cap *= 2;
8148 9           Renew(exp_terms, exp_cap, char*); Renew(parent_term, exp_cap, char*);
8149 9           Renew(is_dummy, exp_cap, bool); Renew(is_interact, exp_cap, bool);
8150 9           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
8151 9           Renew(term_map, exp_cap, int); Renew(left_idx, exp_cap, int); Renew(right_idx, exp_cap, int);
8152             }
8153              
8154 24 100         if (strcmp(uniq_terms[j], "Intercept") == 0) {
8155 9           exp_terms[p_exp] = savepv("Intercept");
8156 9           parent_term[p_exp] = savepv("Intercept");
8157 9           is_dummy[p_exp] = FALSE; is_interact[p_exp] = FALSE;
8158 9           term_map[p_exp] = j;
8159 9           p_exp++;
8160 9           continue;
8161             }
8162              
8163 15           char *restrict colon = strchr(uniq_terms[j], ':');
8164 15 100         if (colon) {
8165             char left[256], right[256];
8166 2           strncpy(left, uniq_terms[j], colon - uniq_terms[j]);
8167 2           left[colon - uniq_terms[j]] = '\0';
8168 2           strcpy(right, colon + 1);
8169              
8170 2           int *restrict l_indices = (int*)safemalloc(p_exp * sizeof(int)); int l_count = 0;
8171 2           int *restrict r_indices = (int*)safemalloc(p_exp * sizeof(int)); int r_count = 0;
8172 6 100         for (size_t e = 0; e < p_exp; e++) {
8173 4 100         if (strcmp(parent_term[e], left) == 0) l_indices[l_count++] = e;
8174 4 100         if (strcmp(parent_term[e], right) == 0) r_indices[r_count++] = e;
8175             }
8176              
8177 2 100         if (l_count == 0 || r_count == 0) {
    50          
8178 1           Safefree(l_indices); Safefree(r_indices);
8179 1           croak("aov: Interaction term '%s' requires its main effects to be explicitly included in the formula", uniq_terms[j]);
8180             } else {
8181 2 100         for (unsigned int li = 0; li < l_count; li++) {
8182 2 100         for (unsigned int ri = 0; ri < r_count; ri++) {
8183 1 50         if (p_exp >= exp_cap) {
8184 0           exp_cap *= 2;
8185 0           Renew(exp_terms, exp_cap, char*); Renew(parent_term, exp_cap, char*);
8186 0           Renew(is_dummy, exp_cap, bool); Renew(is_interact, exp_cap, bool);
8187 0           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
8188 0           Renew(term_map, exp_cap, int); Renew(left_idx, exp_cap, int); Renew(right_idx, exp_cap, int);
8189             }
8190 1           size_t t_len = strlen(exp_terms[l_indices[li]]) + strlen(exp_terms[r_indices[ri]]) + 2;
8191 1           exp_terms[p_exp] = (char*)safemalloc(t_len);
8192 1           snprintf(exp_terms[p_exp], t_len, "%s:%s", exp_terms[l_indices[li]], exp_terms[r_indices[ri]]);
8193 1           parent_term[p_exp] = savepv(uniq_terms[j]);
8194 1           is_dummy[p_exp] = FALSE; is_interact[p_exp] = TRUE;
8195 1           left_idx[p_exp] = l_indices[li];
8196 1           right_idx[p_exp] = r_indices[ri];
8197 1           term_map[p_exp] = j;
8198 1           p_exp++;
8199             }
8200             }
8201             }
8202 1           Safefree(l_indices); Safefree(r_indices);
8203             } else {
8204 13 100         if (is_column_categorical(aTHX_ data_hoa, row_hashes, n, uniq_terms[j])) {
8205 4           char **restrict levels = NULL;
8206 4           unsigned int num_levels = 0, levels_cap = 8;
8207 4           Newx(levels, levels_cap, char*);
8208 65 100         for (i = 0; i < n; i++) {
8209 61           char*restrict str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, uniq_terms[j]);
8210 61 50         if (str_val) {
8211 61           bool found = FALSE;
8212 96 100         for (size_t l = 0; l < num_levels; l++) {
8213 87 100         if (strcmp(levels[l], str_val) == 0) { found = TRUE; break; }
8214             }
8215 61 100         if (!found) {
8216 9 50         if (num_levels >= levels_cap) { levels_cap *= 2; Renew(levels, levels_cap, char*); }
8217 9           levels[num_levels++] = savepv(str_val);
8218             }
8219 61           Safefree(str_val);
8220             }
8221             }
8222 4 50         if (num_levels > 0) {
8223 9 100         for (size_t l1 = 0; l1 < num_levels - 1; l1++) {
8224 11 100         for (size_t l2 = l1 + 1; l2 < num_levels; l2++) {
8225 6 100         if (strcmp(levels[l1], levels[l2]) > 0) {
8226 2           char *tmp = levels[l1]; levels[l1] = levels[l2]; levels[l2] = tmp;
8227             }
8228             }
8229             }
8230              
8231 4           term_base_level[j] = savepv(levels[0]);
8232              
8233 9 100         for (size_t l = 1; l < num_levels; l++) {
8234 5 50         if (p_exp >= exp_cap) {
8235 0           exp_cap *= 2;
8236 0           Renew(exp_terms, exp_cap, char*); Renew(parent_term, exp_cap, char*);
8237 0           Renew(is_dummy, exp_cap, bool); Renew(is_interact, exp_cap, bool);
8238 0           Renew(dummy_base, exp_cap, char*); Renew(dummy_level, exp_cap, char*);
8239 0           Renew(term_map, exp_cap, int); Renew(left_idx, exp_cap, int); Renew(right_idx, exp_cap, int);
8240             }
8241 5           size_t t_len = strlen(uniq_terms[j]) + strlen(levels[l]) + 1;
8242 5           exp_terms[p_exp] = (char*)safemalloc(t_len);
8243 5           snprintf(exp_terms[p_exp], t_len, "%s%s", uniq_terms[j], levels[l]);
8244 5           parent_term[p_exp] = savepv(uniq_terms[j]);
8245 5           is_dummy[p_exp] = TRUE; is_interact[p_exp] = FALSE;
8246 5           dummy_base[p_exp] = savepv(uniq_terms[j]);
8247 5           dummy_level[p_exp] = savepv(levels[l]);
8248 5           term_map[p_exp] = j;
8249 5           p_exp++;
8250             }
8251 13 100         for (size_t l = 0; l < num_levels; l++) Safefree(levels[l]);
8252 4           Safefree(levels);
8253             } else {
8254 0           Safefree(levels);
8255 0           exp_terms[p_exp] = savepv(uniq_terms[j]);
8256 0           parent_term[p_exp] = savepv(uniq_terms[j]);
8257 0           is_dummy[p_exp] = FALSE; is_interact[p_exp] = FALSE;
8258 0           term_map[p_exp] = j;
8259 0           p_exp++;
8260             }
8261             } else {
8262 9           exp_terms[p_exp] = savepv(uniq_terms[j]);
8263 9           parent_term[p_exp] = savepv(uniq_terms[j]);
8264 9           is_dummy[p_exp] = FALSE; is_interact[p_exp] = FALSE;
8265 9           term_map[p_exp] = j;
8266 9           p_exp++;
8267             }
8268             }
8269             }
8270 8           X_mat = (NV**)safemalloc(n * sizeof(NV*));
8271 72 100         for(i = 0; i < n; i++) X_mat[i] = (NV*)safemalloc(p_exp * sizeof(NV));
8272 8 50         Newx(Y, n, NV);
8273             // PHASE 4: Matrix Construction & Listwise Deletion
8274 72 100         for (i = 0; i < n; i++) {
8275 64           NV y_val = evaluate_term(aTHX_ data_hoa, row_hashes, i, lhs);
8276 64 50         if (isnan(y_val)) { Safefree(row_names[i]); continue; }
8277 64           bool row_ok = TRUE;
8278 64           NV *restrict row_x = (NV*)safemalloc(p_exp * sizeof(NV));
8279 258 100         for (j = 0; j < p_exp; j++) {
8280 194 100         if (strcmp(exp_terms[j], "Intercept") == 0) {
8281 64           row_x[j] = 1.0;
8282 130 100         } else if (is_interact[j]) {
8283 20           row_x[j] = row_x[left_idx[j]] * row_x[right_idx[j]];
8284 110 100         } else if (is_dummy[j]) {
8285 70           char*restrict str_val = get_data_string_alloc(aTHX_ data_hoa, row_hashes, i, dummy_base[j]);
8286 70 50         if (str_val) {
8287 70 100         row_x[j] = (strcmp(str_val, dummy_level[j]) == 0) ? 1.0 : 0.0;
8288 70           Safefree(str_val);
8289 0           } else { row_ok = FALSE; break; }
8290             } else {
8291 40           row_x[j] = evaluate_term(aTHX_ data_hoa, row_hashes, i, parent_term[j]);
8292 40 50         if (isnan(row_x[j])) { row_ok = FALSE; break; }
8293             }
8294             }
8295 64 50         if (!row_ok) { Safefree(row_names[i]); Safefree(row_x); continue; }
8296 64           Y[valid_n] = y_val;
8297 258 100         for (j = 0; j < p_exp; j++) X_mat[valid_n][j] = row_x[j];
8298 64           valid_n++;
8299 64           Safefree(row_x);
8300 64           Safefree(row_names[i]);
8301             }
8302 8           Safefree(row_names);
8303 8 100         if (valid_n <= p_exp) {
8304             // Full Clean Up
8305 4 100         for (i = 0; i < num_terms; i++) Safefree(terms[i]); Safefree(terms);
8306 4 100         for (i = 0; i < num_uniq; i++) Safefree(uniq_terms[i]); Safefree(uniq_terms);
8307 4 100         for (j = 0; j < p_exp; j++) {
8308 3           Safefree(exp_terms[j]); Safefree(parent_term[j]);
8309 3 50         if (is_dummy[j]) { Safefree(dummy_base[j]); Safefree(dummy_level[j]); }
8310             }
8311 1           Safefree(exp_terms); Safefree(parent_term);
8312 1           Safefree(is_dummy); Safefree(is_interact);
8313 1           Safefree(dummy_base); Safefree(dummy_level);
8314 1           Safefree(term_map); Safefree(left_idx); Safefree(right_idx);
8315 3 100         for(i = 0; i < n; i++) Safefree(X_mat[i]);
8316 1           Safefree(X_mat); Safefree(Y);
8317 1 50         if (row_hashes) Safefree(row_hashes);
8318 4 50         for (i = 0; i < num_uniq; i++) { if (term_base_level[i]) Safefree(term_base_level[i]); }
    100          
8319 1           Safefree(term_base_level);
8320 1           croak("aov: 0 degrees of freedom (too many NAs or parameters > observations)");
8321             }
8322             // PHASE 5: Math & Output Formatting
8323 7           bool *restrict aliased_qr = (bool*)safemalloc(p_exp * sizeof(bool));
8324 7           size_t *restrict rank_map = (size_t*)safemalloc(p_exp * sizeof(size_t));
8325 7           apply_householder_aov(X_mat, Y, valid_n, p_exp, aliased_qr, rank_map);
8326             NV *restrict term_ss;
8327             int *restrict term_df;
8328 7           Newxz(term_ss, num_uniq, NV);
8329 7           Newxz(term_df, num_uniq, int);
8330 27 100         for (i = 0; i < p_exp; i++) {
8331 20 100         if (strcmp(exp_terms[i], "Intercept") == 0) continue;
8332 13 100         if (aliased_qr[i]) continue;
8333 12           int t_idx = term_map[i];
8334 12           size_t r_k = rank_map[i];
8335 12           term_ss[t_idx] += Y[r_k] * Y[r_k];
8336 12           term_df[t_idx] += 1;
8337             }
8338 7           int rank = 0;
8339 27 100         for (i = 0; i < p_exp; i++) {
8340 20 100         if (!aliased_qr[i]) rank++;
8341             }
8342 7           NV rss_prev = 0.0;
8343 50 100         for (i = rank; i < valid_n; i++) {
8344 43           rss_prev += Y[i] * Y[i];
8345             }
8346 7           int res_df = valid_n - rank;
8347 7 50         NV ms_res = (res_df > 0) ? rss_prev / res_df : 0.0;
8348 7           HV*restrict ret_hash = newHV();
8349 26 100         for (j = 0; j < num_uniq; j++) {
8350 19 100         if (strcmp(uniq_terms[j], "Intercept") == 0) continue;
8351 12           HV*restrict term_stats = newHV();
8352 12           NV ss = term_ss[j];
8353 12           int df = term_df[j];
8354 12 100         NV ms = (df > 0) ? ss / df : 0.0;
8355              
8356 12           hv_stores(term_stats, "Df", newSViv(df));
8357 12           hv_stores(term_stats, "Sum Sq", newSVnv(ss));
8358 12           hv_stores(term_stats, "Mean Sq", newSVnv(ms));
8359 23 50         if (ms_res > 0.0 && df > 0) {
    100          
8360 11           NV f_val = ms / ms_res;
8361 11           hv_stores(term_stats, "F value", newSVnv(f_val));
8362 11           hv_stores(term_stats, "Pr(>F)", newSVnv(1.0 - pf(f_val, (NV)df, (NV)res_df)));
8363             } else {
8364 1           hv_stores(term_stats, "F value", newSVnv(NAN));
8365 1           hv_stores(term_stats, "Pr(>F)", newSVnv(NAN));
8366             }
8367 12           hv_store(ret_hash, uniq_terms[j], strlen(uniq_terms[j]), newRV_noinc((SV*)term_stats), 0);
8368             }
8369 7           HV*restrict res_stats = newHV();
8370 7           hv_stores(res_stats, "Df", newSViv(res_df));
8371 7           hv_stores(res_stats, "Sum Sq", newSVnv(rss_prev));
8372 7           hv_stores(res_stats, "Mean Sq", newSVnv(ms_res));
8373 7           hv_stores(ret_hash, "Residuals", newRV_noinc((SV*)res_stats));
8374             {
8375 7           HV *restrict tgt_hoa = data_hoa;
8376 7           HV **restrict tgt_row_hashes = row_hashes;
8377 7           size_t tgt_n = n;
8378             // Route evaluation to the original unstacked HoA when a formula was implied
8379 7 100         if (is_stacked) {
8380 1           tgt_hoa = (HV*)SvRV(orig_data_sv);
8381 1           tgt_row_hashes = NULL;
8382 1           hv_iterinit(tgt_hoa);
8383 1           HE *restrict e = hv_iternext(tgt_hoa);
8384 1 50         if (e) {
8385 1           SV *val = hv_iterval(tgt_hoa, e);
8386 1 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) {
    50          
8387 1           tgt_n = av_len((AV*)SvRV(val)) + 1;
8388             }
8389             }
8390             }
8391 7           AV *restrict all_cols = get_all_columns(aTHX_ tgt_hoa, tgt_row_hashes, tgt_n);
8392 7           HV *restrict mean_hv = newHV();
8393 7           HV *restrict size_hv = newHV();
8394 25 100         for (size_t c = 0; c <= (size_t)av_len(all_cols); c++) {
8395 18           SV **restrict col_sv = av_fetch(all_cols, c, 0);
8396 18 50         if (!col_sv || !SvOK(*col_sv)) continue;
    50          
8397 18           const char *restrict col_name = SvPV_nolen(*col_sv);
8398 18           NV col_sum = 0.0;
8399 18           IV col_count = 0;
8400 165 100         for (i = 0; i < tgt_n; i++) {
8401 147           NV val = evaluate_term(aTHX_ tgt_hoa, tgt_row_hashes, i, col_name);
8402 147 100         if (!isnan(val)) { col_sum += val; col_count++; }
8403             }
8404 18 100         NV col_mean = (col_count > 0) ? col_sum / col_count : NAN;
8405 18           hv_store(mean_hv, col_name, strlen(col_name), newSVnv(col_mean), 0);
8406 18           hv_store(size_hv, col_name, strlen(col_name), newSViv(col_count), 0);
8407             }
8408 7           SvREFCNT_dec(all_cols);
8409 7           HV *restrict gs_hv = newHV();
8410 7           hv_stores(gs_hv, "mean", newRV_noinc((SV*)mean_hv));
8411 7           hv_stores(gs_hv, "size", newRV_noinc((SV*)size_hv));
8412 7           hv_stores(ret_hash, "group_stats", newRV_noinc((SV*)gs_hv));
8413             }
8414             // Deep Cleanup
8415 26 100         for (i = 0; i < num_terms; i++) Safefree(terms[i]); Safefree(terms);
8416 26 100         for (i = 0; i < num_uniq; i++) Safefree(uniq_terms[i]); Safefree(uniq_terms);
8417 27 100         for (j = 0; j < p_exp; j++) {
8418 20           Safefree(exp_terms[j]); Safefree(parent_term[j]);
8419 20 100         if (is_dummy[j]) { Safefree(dummy_base[j]); Safefree(dummy_level[j]); }
8420             }
8421 7           Safefree(exp_terms); Safefree(parent_term);
8422 7           Safefree(is_dummy); Safefree(is_interact);
8423 7           Safefree(dummy_base); Safefree(dummy_level);
8424 7           Safefree(term_map); Safefree(left_idx); Safefree(right_idx);
8425 7           Safefree(term_ss); Safefree(term_df);
8426 69 100         for (i = 0; i < n; i++) Safefree(X_mat[i]);
8427 7           Safefree(X_mat); Safefree(Y);
8428 7           Safefree(aliased_qr); Safefree(rank_map);
8429 26 100         for (i = 0; i < num_uniq; i++) { if (term_base_level[i]) Safefree(term_base_level[i]); }
    100          
8430 7           Safefree(term_base_level);
8431 7 50         if (row_hashes) Safefree(row_hashes);
8432 7           RETVAL = newRV_noinc((SV*)ret_hash);
8433             }
8434             OUTPUT:
8435             RETVAL
8436              
8437             PROTOTYPES: DISABLE
8438              
8439              
8440             SV* fisher_test(...)
8441             CODE:
8442             {
8443 18 100         if (items < 1) croak("fisher_test requires at least a data reference");
8444              
8445 17           SV *restrict data_ref = ST(0);
8446 17           NV conf_level = 0.95;
8447 17           const char *restrict alternative = "two.sided";
8448              
8449 21 100         for (unsigned int i = 1; i < items; i += 2) {
8450 6 50         if (i + 1 >= items) croak("fisher_test: odd number of named arguments");
8451 6           const char *restrict key = SvPV_nolen(ST(i));
8452 6           SV *restrict val = ST(i + 1);
8453 6 100         if (strEQ(key, "conf_level") || strEQ(key, "conf.level")) {
    50          
8454 1           conf_level = SvNV(val);
8455 1 50         if (!(conf_level > 0 && conf_level < 1))
    50          
8456 1           croak("fisher_test: conf_level must be between 0 and 1");
8457 5 50         } else if (strEQ(key, "alternative")) {
8458 5           alternative = SvPV_nolen(val);
8459 5 50         if (strNE(alternative, "two.sided") && strNE(alternative, "less") &&
    100          
8460 3 100         strNE(alternative, "greater"))
8461 1           croak("fisher_test: alternative must be 'two.sided', 'less' or 'greater'");
8462             } else {
8463 0           croak("fisher_test: unknown argument '%s'", key);
8464             }
8465             }
8466 15 50         if (!SvROK(data_ref)) croak("fisher_test requires a reference to a 2x2 Array or Hash");
8467 15           SV *restrict deref = SvRV(data_ref);
8468 15           long a = 0, b = 0, c = 0, d = 0;
8469 15 100         if (SvTYPE(deref) == SVt_PVAV) {
8470 11           AV *restrict outer = (AV *)deref;
8471 11 50         if (av_len(outer) != 1) croak("Outer array must have exactly 2 rows");
8472 11           SV **restrict r1p = av_fetch(outer, 0, 0);
8473 11           SV **restrict r2p = av_fetch(outer, 1, 0);
8474 11 50         if (!(r1p && r2p && SvROK(*r1p) && SvROK(*r2p)
    50          
    50          
    50          
8475 11 50         && SvTYPE(SvRV(*r1p)) == SVt_PVAV && SvTYPE(SvRV(*r2p)) == SVt_PVAV))
    50          
8476 0           croak("Invalid 2D array structure: need two array-ref rows");
8477 11           AV *restrict r1 = (AV *)SvRV(*r1p), *r2 = (AV *)SvRV(*r2p);
8478 11 100         if (av_len(r1) != 1 || av_len(r2) != 1)
    50          
8479 1           croak("Each row must have exactly 2 columns");
8480 10           a = ft_cell(aTHX_ *av_fetch(r1, 0, 0), "cell [0][0]");
8481 10           b = ft_cell(aTHX_ *av_fetch(r1, 1, 0), "cell [0][1]");
8482 10           c = ft_cell(aTHX_ *av_fetch(r2, 0, 0), "cell [1][0]");
8483 10           d = ft_cell(aTHX_ *av_fetch(r2, 1, 0), "cell [1][1]");
8484 4 50         } else if (SvTYPE(deref) == SVt_PVHV) {
8485             /* 2x2 hash; rows and columns are ordered by lexical key sort so the
8486             * result is deterministic regardless of Perl's hash randomization. */
8487 4           HV *restrict outer = (HV *)deref;
8488 4 50         if (HvUSEDKEYS(outer) != 2) croak("Outer hash must have exactly 2 keys");
    50          
8489 4           hv_iterinit(outer);
8490 4           HE *restrict e1 = hv_iternext(outer), *e2 = hv_iternext(outer);
8491 4           const char *restrict ok1 = SvPV_nolen(hv_iterkeysv(e1));
8492 4           int swap_rows = strcmp(ok1, SvPV_nolen(hv_iterkeysv(e2))) > 0;
8493 4 100         SV *restrict row1_sv = hv_iterval(outer, swap_rows ? e2 : e1);
8494 4 100         SV *restrict row2_sv = hv_iterval(outer, swap_rows ? e1 : e2);
8495 4 50         if (!SvROK(row1_sv) || SvTYPE(SvRV(row1_sv)) != SVt_PVHV ||
    50          
8496 4 50         !SvROK(row2_sv) || SvTYPE(SvRV(row2_sv)) != SVt_PVHV)
    50          
8497 0           croak("Inner elements must be hash refs");
8498              
8499 4           HV *restrict rows[2]; rows[0] = (HV *)SvRV(row1_sv); rows[1] = (HV *)SvRV(row2_sv);
8500             long cells[2][2];
8501 12 100         for (unsigned int rr = 0; rr < 2; rr++) {
8502 8           HV *restrict in = rows[rr];
8503 8 50         if (HvUSEDKEYS(in) != 2) croak("Inner hashes must have exactly 2 keys");
    50          
8504 8           hv_iterinit(in);
8505 8           HE *c1 = hv_iternext(in), *c2 = hv_iternext(in);
8506 8           const char *k1 = SvPV_nolen(hv_iterkeysv(c1));
8507 8           int swap_cols = strcmp(k1, SvPV_nolen(hv_iterkeysv(c2))) > 0;
8508 8 100         HE *col0 = swap_cols ? c2 : c1;
8509 8 100         HE *col1 = swap_cols ? c1 : c2;
8510 8           cells[rr][0] = ft_cell(aTHX_ hv_iterval(in, col0), "hash cell");
8511 8           cells[rr][1] = ft_cell(aTHX_ hv_iterval(in, col1), "hash cell");
8512             }
8513 4           a = cells[0][0]; b = cells[0][1]; c = cells[1][0]; d = cells[1][1];
8514             } else {
8515 0           croak("Input must be a 2D Array or 2D Hash");
8516             }
8517 13 50         if (a + b + c + d == 0) croak("fisher_test: table is all zeros");
8518 13           NV p_val = exact_p_value(a, b, c, d, alternative);
8519             NV mle_or, ci_low, ci_high;
8520 13           calculate_exact_stats(a, b, c, d, conf_level, alternative, &mle_or, &ci_low, &ci_high);
8521              
8522 13           HV *restrict ret = newHV();
8523 13           hv_stores(ret, "method", newSVpv("Fisher's Exact Test for Count Data", 0));
8524 13           hv_stores(ret, "alternative", newSVpv(alternative, 0));
8525 13           AV *restrict ci = newAV();
8526 13           av_push(ci, newSVnv(ci_low));
8527 13           av_push(ci, newSVnv(ci_high));
8528 13           hv_stores(ret, "conf_int", newRV_noinc((SV *)ci));
8529 13           HV *restrict est = newHV();
8530 13           hv_stores(est, "odds ratio", newSVnv(mle_or));
8531 13           hv_stores(ret, "estimate", newRV_noinc((SV *)est));
8532 13           hv_stores(ret, "p_value", newSVnv(p_val));
8533 13           hv_stores(ret, "conf_level", newSVnv(conf_level));
8534 13           RETVAL = newRV_noinc((SV *)ret);
8535             }
8536             OUTPUT:
8537             RETVAL
8538              
8539             SV* power_t_test(...)
8540             CODE:
8541             {
8542 7           SV*restrict sv_n = NULL;
8543 7           SV*restrict sv_delta = NULL;
8544 7           SV*restrict sv_sd = NULL;
8545 7           SV*restrict sv_sig_level = NULL;
8546 7           SV*restrict sv_power = NULL;
8547              
8548 7           const char* restrict type = "two.sample";
8549 7           const char* restrict alternative = "two.sided";
8550 7           bool strict = FALSE;
8551 7           NV tol = pow(2.2204460492503131e-16, 0.25);
8552              
8553 7 50         if (items % 2 != 0) croak("Usage: power_t_test(n => 30, delta => 0.5, sd => 1.0, ...)");
8554 34 100         for (unsigned short int i = 0; i < items; i += 2) {
8555 27           const char* restrict key = SvPV_nolen(ST(i));
8556 27           SV* restrict val = ST(i+1);
8557              
8558 27 100         if (strEQ(key, "n")) sv_n = val;
8559 26 100         else if (strEQ(key, "delta")) sv_delta = val;
8560 19 100         else if (strEQ(key, "sd")) sv_sd = val;
8561 12 50         else if (strEQ(key, "sig.level") || strEQ(key, "sig_level")) sv_sig_level = val;
    100          
8562 11 100         else if (strEQ(key, "power")) sv_power = val;
8563 5 100         else if (strEQ(key, "type")) type = SvPV_nolen(val);
8564 2 50         else if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
8565 0 0         else if (strEQ(key, "strict")) strict = SvTRUE(val);
8566 0 0         else if (strEQ(key, "tol")) tol = SvNV(val);
8567 0           else croak("power_t_test: unknown argument '%s'", key);
8568             }
8569              
8570 7 100         bool is_null_n = (!sv_n || !SvOK(sv_n));
    50          
8571 7 50         bool is_null_delta = (!sv_delta || !SvOK(sv_delta));
    50          
8572 7 100         bool is_null_power = (!sv_power || !SvOK(sv_power));
    50          
8573 7 50         bool is_null_sd = (sv_sd && !SvOK(sv_sd));
    50          
8574 7 100         bool is_null_sig_level = (sv_sig_level && !SvOK(sv_sig_level));
    50          
8575              
8576 7           unsigned int missing_count = 0;
8577 7 100         if (is_null_n) missing_count++;
8578 7 50         if (is_null_delta) missing_count++;
8579 7 100         if (is_null_power) missing_count++;
8580 7 50         if (is_null_sd) missing_count++;
8581 7 50         if (is_null_sig_level) missing_count++;
8582              
8583 7 50         if (missing_count != 1) {
8584 0           croak("power_t_test: exactly one of 'n', 'delta', 'sd', 'power', and 'sig_level' must be undef/NULL");
8585             }
8586              
8587 7 100         NV n = is_null_n ? 0.0 : SvNV(sv_n);
8588 7 50         NV delta = is_null_delta ? 0.0 : SvNV(sv_delta);
8589 7 50         NV sd = (!sv_sd || is_null_sd) ? 1.0 : SvNV(sv_sd);
    50          
8590 7 100         NV sig_level = (!sv_sig_level || is_null_sig_level) ? 0.05 : SvNV(sv_sig_level);
    50          
8591 7 100         NV power = is_null_power ? 0.0 : SvNV(sv_power);
8592 7 100         short int tsample = (strEQ(type, "one.sample") || strEQ(type, "paired")) ? 1 : 2;
    100          
8593 7 100         short int tside = (strEQ(alternative, "one.sided") || strEQ(alternative, "greater") || strEQ(alternative, "less")) ? 1 : 2;
    50          
    50          
8594 7 100         if (tside == 2 && !is_null_delta) delta = fabs(delta);
    50          
8595 7 100         if (is_null_power) {
8596 1           power = p_body(n, delta, sd, sig_level, tsample, tside, strict);
8597 6 50         } else if (is_null_n) {
8598 6           NV low = 2.0, high = 1e7;
8599 6 50         while (p_body(high, delta, sd, sig_level, tsample, tside, strict) < power && high < 1e12) high *= 2.0;
    0          
8600 228 100         while (high - low > tol) {
8601 222           NV mid = low + (high - low) / 2.0;
8602 222 100         if (p_body(mid, delta, sd, sig_level, tsample, tside, strict) < power) low = mid;
8603 173           else high = mid;
8604             }
8605 6           n = low + (high - low) / 2.0;
8606 0 0         } else if (is_null_sd) {
8607 0           NV low = delta * 1e-7, high = delta * 1e7;
8608 0 0         while (high - low > tol) {
8609 0           NV mid = low + (high - low) / 2.0;
8610 0 0         if (p_body(n, delta, mid, sig_level, tsample, tside, strict) > power) low = mid;
8611 0           else high = mid;
8612             }
8613 0           sd = low + (high - low) / 2.0;
8614 0 0         } else if (is_null_delta) {
8615 0           NV low = sd * 1e-7, high = sd * 1e7;
8616 0 0         while (p_body(n, high, sd, sig_level, tsample, tside, strict) < power && high < 1e12) high *= 2.0;
    0          
8617 0 0         while (high - low > tol) {
8618 0           NV mid = low + (high - low) / 2.0;
8619 0 0         if (p_body(n, mid, sd, sig_level, tsample, tside, strict) < power) low = mid;
8620 0           else high = mid;
8621             }
8622 0           delta = low + (high - low) / 2.0;
8623 0 0         } else if (is_null_sig_level) {
8624 0           NV low = 1e-10, high = 1.0 - 1e-10;
8625 0 0         while (high - low > tol) {
8626 0           NV mid = low + (high - low) / 2.0;
8627 0 0         if (p_body(n, delta, sd, mid, tsample, tside, strict) < power) low = mid;
8628 0           else high = mid;
8629             }
8630 0           sig_level = low + (high - low) / 2.0;
8631             }
8632 7           HV*restrict ret = newHV();
8633 7           hv_stores(ret, "n", newSVnv(n));
8634 7           hv_stores(ret, "delta", newSVnv(delta));
8635 7           hv_stores(ret, "sd", newSVnv(sd));
8636 7           hv_stores(ret, "sig.level", newSVnv(sig_level));
8637 7           hv_stores(ret, "power", newSVnv(power));
8638 7           hv_stores(ret, "alternative", newSVpv(alternative, 0));
8639 7 100         const char*restrict m_str = (tsample == 1) ? (strEQ(type, "paired") ? "Paired t test power calculation" : "One-sample t test power calculation") : "Two-sample t test power calculation";
    100          
8640 7           hv_stores(ret, "method", newSVpv(m_str, 0));
8641 7 100         const char*restrict n_str = (tsample == 2) ? "n is number in *each* group" : (strEQ(type, "paired") ? "n is number of *pairs*, sd is std.dev. of *differences* within pairs" : "");
    100          
8642 7 100         if (n_str[0] != '\0') hv_stores(ret, "note", newSVpv(n_str, 0));
8643 7           RETVAL = newRV_noinc((SV*)ret);
8644             }
8645             OUTPUT:
8646             RETVAL
8647              
8648             SV* kruskal_test(...)
8649             CODE:
8650             {
8651 3           SV *restrict x_sv = NULL, *restrict g_sv = NULL, *restrict h_sv = NULL;
8652 3           unsigned int arg_idx = 0;
8653             // 1. Shift positional arguments
8654             // Accept either: (arrayref, arrayref) or (hashref)
8655 3 50         if (arg_idx < items && SvROK(ST(arg_idx))) {
    100          
8656 2           svtype t = SvTYPE(SvRV(ST(arg_idx)));
8657 2 100         if (t == SVt_PVAV) {
8658 1           x_sv = ST(arg_idx++);
8659 1 50         } else if (t == SVt_PVHV) {
8660 1           h_sv = ST(arg_idx++); /* hash-of-arrays shortcut */
8661             }
8662             }
8663 3 100         if (!h_sv && arg_idx < items
    50          
8664 2 100         && SvROK(ST(arg_idx))
8665 1 50         && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
8666 1           g_sv = ST(arg_idx++);
8667             }
8668             // 2. Parse named arguments (fallback)
8669 5 100         for (; arg_idx < items; arg_idx += 2) {
8670 2           const char *restrict key = SvPV_nolen(ST(arg_idx));
8671 2           SV *restrict val = ST(arg_idx + 1);
8672 2 100         if (strEQ(key, "x")) x_sv = val;
8673 1 50         else if (strEQ(key, "g")) g_sv = val;
8674 0 0         else if (strEQ(key, "h")) h_sv = val;
8675 0           else croak("kruskal_test: unknown argument '%s'", key);
8676             }
8677             // 3. Mutual-exclusion guard
8678 3 100         if (h_sv && (x_sv || g_sv))
    50          
    50          
8679 0           croak("kruskal_test: cannot mix 'h' (hash-of-arrays) with 'x'/'g' inputs");
8680              
8681             // Shared state filled by whichever input branch runs
8682 3           RankInfo *restrict ri = NULL;
8683 3           char **restrict group_names = NULL; /* Track names to build group_stats */
8684 3           size_t valid_n = 0, k = 0;
8685             /* 4a. Hash-of-arrays input path */
8686             /* my %x = ( group1 => [...], group2 => [...], ... ) */
8687             /* ------------------------------------------------------------------ */
8688 3 100         if (h_sv) {
8689 1 50         if (!SvROK(h_sv) || SvTYPE(SvRV(h_sv)) != SVt_PVHV)
    50          
8690 0           croak("kruskal_test: 'h' must be a HASH reference");
8691 1           HV *restrict h_hv = (HV*)SvRV(h_sv);
8692             // First pass – validate values and tally total elements
8693 1           size_t total = 0;
8694 1           hv_iterinit(h_hv);
8695             HE *restrict he;
8696 4 100         while ((he = hv_iternext(h_hv))) {
8697 3           SV *restrict val = HeVAL(he);
8698 3 50         if (!SvROK(val) || SvTYPE(SvRV(val)) != SVt_PVAV)
    50          
8699 0           croak("kruskal_test: every value in 'h' must be an ARRAY reference");
8700 3           total += (size_t)(av_len((AV*)SvRV(val)) + 1);
8701             }
8702 1 50         if (total < 2) croak("not enough observations");
8703 1           ri = (RankInfo *)safemalloc(total * sizeof(RankInfo));
8704 1 50         size_t num_keys = HvKEYS(h_hv);
8705 1           group_names = (char **)safecalloc(num_keys, sizeof(char*));
8706             /* 2nd pass – fill ri[], assigning one group_id per hash key */
8707 1           size_t group_id = 0;
8708 1           hv_iterinit(h_hv);
8709 4 100         while ((he = hv_iternext(h_hv))) {
8710             STRLEN klen;
8711 3 50         const char *restrict key_str = HePV(he, klen);
8712 3           group_names[group_id] = savepvn(key_str, klen); // Save string key
8713 3           AV *restrict av = (AV*)SvRV(HeVAL(he));
8714 3           size_t n_g = (size_t)(av_len(av) + 1);
8715 17 100         for (size_t i = 0; i < n_g; i++) {
8716 14           SV **restrict el = av_fetch(av, i, 0);
8717 14 50         if (el && SvOK(*el) && looks_like_number(*el)) {
    50          
    50          
8718 14           ri[valid_n].val = SvNV(*el);
8719 14           ri[valid_n].idx = group_id; /* group identity */
8720 14           valid_n++;
8721             }
8722             }
8723 3           group_id++;
8724             }
8725 1           k = group_id; /* number of unique groups = number of hash keys */
8726             /* 4b. Original x / g array-pair input path */
8727             } else {
8728 2 50         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
    50          
8729 0           croak("kruskal_test: 'x' is a required argument and must be an ARRAY reference");
8730 2 50         if (!g_sv || !SvROK(g_sv) || SvTYPE(SvRV(g_sv)) != SVt_PVAV)
    50          
    50          
8731 0           croak("kruskal_test: 'g' is a required argument and must be an ARRAY reference");
8732              
8733 2           AV *restrict x_av = (AV*)SvRV(x_sv);
8734 2           AV *restrict g_av = (AV*)SvRV(g_sv);
8735 2           size_t nx = (size_t)(av_len(x_av) + 1);
8736 2           size_t ng = (size_t)(av_len(g_av) + 1);
8737 2 50         if (nx != ng) croak("kruskal_test: 'x' and 'g' must have the same length");
8738 2 50         if (nx < 2) croak("not enough observations");
8739              
8740 2           ri = (RankInfo *)safemalloc(nx * sizeof(RankInfo));
8741 2           group_names = (char **)safecalloc(nx, sizeof(char*)); // Upper bound
8742              
8743             // Map string group names → contiguous integer IDs
8744 2           HV *restrict group_map = newHV();
8745 2           size_t next_group_id = 0;
8746              
8747 30 100         for (size_t i = 0; i < nx; i++) {
8748 28           SV **restrict x_el = av_fetch(x_av, i, 0);
8749 28           SV **restrict g_el = av_fetch(g_av, i, 0);
8750 28 50         if (x_el && SvOK(*x_el) && looks_like_number(*x_el)
    50          
    50          
8751 28 50         && g_el && SvOK(*g_el)) {
    50          
8752 28           const char *restrict g_str = SvPV_nolen(*g_el);
8753 28           STRLEN glen = strlen(g_str);
8754 28           SV **restrict id_sv = hv_fetch(group_map, g_str, glen, 0);
8755             size_t group_id;
8756 28 100         if (id_sv) {
8757 22           group_id = SvUV(*id_sv);
8758             } else {
8759 6           group_id = next_group_id++;
8760 6           hv_store(group_map, g_str, glen, newSVuv(group_id), 0);
8761 6           group_names[group_id] = savepvn(g_str, glen); // Save string key
8762             }
8763 28           ri[valid_n].val = SvNV(*x_el);
8764 28           ri[valid_n].idx = group_id;
8765 28           valid_n++;
8766             }
8767             }
8768 2           k = next_group_id;
8769 2           SvREFCNT_dec(group_map);
8770             }
8771             /* 5. Shared post-extraction validation */
8772 3 50         if (valid_n < 2 || k < 2) {
    50          
8773 0           Safefree(ri);
8774 0 0         if (group_names) {
8775 0 0         for (size_t i = 0; i < k; i++) { if (group_names[i]) Safefree(group_names[i]); }
    0          
8776 0           Safefree(group_names);
8777             }
8778 0 0         if (valid_n < 2) croak("not enough observations");
8779 0           croak("all observations are in the same group");
8780             }
8781             // 6. Ranking and Tie Accumulation (Reusing LikeR Helper)
8782 3           bool has_ties = 0;
8783 3           NV tie_adj = rank_and_count_ties(ri, valid_n, &has_ties);
8784             // 7. Aggregate Sum of Ranks AND Actual Values by Group
8785 3           NV *restrict group_rank_sums = (NV *)safecalloc(k, sizeof(NV));
8786 3           NV *restrict group_val_sums = (NV *)safecalloc(k, sizeof(NV)); // For Mean
8787 3           size_t *restrict group_counts = (size_t *)safecalloc(k, sizeof(size_t));
8788 45 100         for (size_t i = 0; i < valid_n; i++) {
8789 42           size_t g_id = ri[i].idx;
8790 42           group_rank_sums[g_id] += ri[i].rank;
8791 42           group_val_sums[g_id] += ri[i].val;
8792 42           group_counts[g_id]++;
8793             }
8794             // 8. Calculate STATISTIC
8795 3           NV stat_base = 0.0;
8796 12 100         for (size_t i = 0; i < k; i++) {
8797 9 50         if (group_counts[i] > 0)
8798 9           stat_base += (group_rank_sums[i] * group_rank_sums[i])
8799 9           / (NV)group_counts[i];
8800             }
8801 3           NV n_d = (NV)valid_n;
8802 3           NV stat = (12.0 * stat_base / (n_d * (n_d + 1.0))) - 3.0 * (n_d + 1.0);
8803 3 50         if (tie_adj > 0.0) {
8804 0           NV tie_denom = 1.0 - (tie_adj / (n_d * n_d * n_d - n_d));
8805 0           stat /= tie_denom;
8806             }
8807 3           int df = (int)k - 1;
8808 3           NV p_val = get_p_value(stat, df);
8809             // 9. Return structured data exactly like R's htest
8810 3           HV *restrict res = newHV();
8811 3           hv_stores(res, "statistic", newSVnv(stat));
8812 3           hv_stores(res, "parameter", newSViv(df));
8813 3           hv_stores(res, "p_value", newSVnv(p_val));
8814 3           hv_stores(res, "p.value", newSVnv(p_val));
8815 3           hv_stores(res, "method", newSVpv("Kruskal-Wallis rank sum test", 0));
8816             // 10. Build the group_stats hash
8817 3           HV *restrict group_stats = newHV();
8818 3           HV *restrict stats_mean = newHV();
8819 3           HV *restrict stats_size = newHV();
8820 12 100         for (size_t i = 0; i < k; i++) {
8821 9 50         if (group_counts[i] > 0 && group_names[i]) {
    50          
8822 9           NV mean = group_val_sums[i] / (NV)group_counts[i];
8823 9           size_t nlen = strlen(group_names[i]);
8824 9           hv_store(stats_mean, group_names[i], nlen, newSVnv(mean), 0);
8825 9           hv_store(stats_size, group_names[i], nlen, newSVuv(group_counts[i]), 0);
8826             }
8827 9 50         if (group_names[i]) Safefree(group_names[i]); // Clean up name copy
8828             }
8829             // Embed the nested hashes
8830 3           hv_stores(group_stats, "mean", newRV_noinc((SV*)stats_mean));
8831 3           hv_stores(group_stats, "size", newRV_noinc((SV*)stats_size));
8832 3           hv_stores(res, "group_stats", newRV_noinc((SV*)group_stats));
8833             // Memory Cleanup
8834 3           Safefree(group_names); Safefree(group_rank_sums);
8835 3           Safefree(group_val_sums); Safefree(group_counts); Safefree(ri);
8836              
8837 3           RETVAL = newRV_noinc((SV*)res);
8838             }
8839             OUTPUT:
8840             RETVAL
8841              
8842             SV* var_test(...)
8843             CODE:
8844             {
8845 6           SV* restrict x_sv = NULL;
8846 6           SV* restrict y_sv = NULL;
8847 6           NV ratio = 1.0, conf_level = 0.95;
8848 6           const char* restrict alternative = "two.sided";
8849 6           unsigned int arg_idx = 0;
8850              
8851             // 1. Shift positional argument 'x' if it's an array reference
8852 6 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    50          
    50          
8853 6           x_sv = ST(arg_idx);
8854 6           arg_idx++;
8855             }
8856              
8857             // 2. Shift positional argument 'y' if it's an array reference
8858 6 50         if (arg_idx < items && SvROK(ST(arg_idx)) && SvTYPE(SvRV(ST(arg_idx))) == SVt_PVAV) {
    50          
    50          
8859 6           y_sv = ST(arg_idx);
8860 6           arg_idx++;
8861             }
8862             // Ensure the remaining arguments form complete key-value pairs
8863 6 50         if ((items - arg_idx) % 2 != 0) {
8864 0           croak("Usage: var_test(\\@x, \\@y, key => value, ...)");
8865             }
8866             // --- Parse named arguments from the remaining flat stack ---
8867 8 100         for (; arg_idx < items; arg_idx += 2) {
8868 2           const char* restrict key = SvPV_nolen(ST(arg_idx));
8869 2           SV* restrict val = ST(arg_idx + 1);
8870              
8871 2 50         if (strEQ(key, "x")) x_sv = val;
8872 2 50         else if (strEQ(key, "y")) y_sv = val;
8873 2 100         else if (strEQ(key, "ratio")) ratio = SvNV(val);
8874 1 50         else if (strEQ(key, "conf_level") || strEQ(key, "conf.level")) conf_level = SvNV(val);
    0          
8875 0 0         else if (strEQ(key, "alternative")) alternative = SvPV_nolen(val);
8876 0           else croak("var_test: unknown argument '%s'", key);
8877             }
8878             // --- Validate required inputs / types ---
8879 6 50         if (!x_sv || !SvROK(x_sv) || SvTYPE(SvRV(x_sv)) != SVt_PVAV)
    50          
    50          
8880 0           croak("var_test: 'x' is a required argument and must be an ARRAY reference");
8881 6 50         if (!y_sv || !SvROK(y_sv) || SvTYPE(SvRV(y_sv)) != SVt_PVAV)
    50          
    50          
8882 0           croak("var_test: 'y' is a required argument and must be an ARRAY reference");
8883              
8884 6 50         if (ratio <= 0.0 || !isfinite(ratio))
    50          
8885 0           croak("var_test: 'ratio' must be a single positive number");
8886 6 50         if (conf_level <= 0.0 || conf_level >= 1.0 || !isfinite(conf_level))
    50          
    50          
8887 0           croak("var_test: 'conf.level' must be a single number between 0 and 1");
8888 6           AV* restrict x_av = (AV*)SvRV(x_sv);
8889 6           AV* restrict y_av = (AV*)SvRV(y_sv);
8890 6           size_t nx_raw = av_len(x_av) + 1;
8891 6           size_t ny_raw = av_len(y_av) + 1;
8892             // --- Computation via Welford's Algorithm (ignoring NaNs) ---
8893 6           NV mean_x = 0.0, M2_x = 0.0;
8894 6           size_t nx = 0;
8895 32 100         for (size_t i = 0; i < nx_raw; i++) {
8896 26           SV** restrict tv = av_fetch(x_av, i, 0);
8897 26 50         if (tv && SvOK(*tv) && looks_like_number(*tv)) {
    50          
    50          
8898 26           NV val = SvNV(*tv);
8899 26 50         if (!isnan(val) && isfinite(val)) {
    50          
8900 26           nx++;
8901 26           NV delta = val - mean_x;
8902 26           mean_x += delta / nx;
8903 26           M2_x += delta * (val - mean_x);
8904             }
8905             }
8906             }
8907              
8908 6           NV mean_y = 0.0, M2_y = 0.0;
8909 6           size_t ny = 0;
8910 27 100         for (size_t i = 0; i < ny_raw; i++) {
8911 21           SV** restrict tv = av_fetch(y_av, i, 0);
8912 21 50         if (tv && SvOK(*tv) && looks_like_number(*tv)) {
    50          
    50          
8913 21           NV val = SvNV(*tv);
8914 21 50         if (!isnan(val) && isfinite(val)) {
    50          
8915 21           ny++;
8916 21           NV delta = val - mean_y;
8917 21           mean_y += delta / ny;
8918 21           M2_y += delta * (val - mean_y);
8919             }
8920             }
8921             }
8922              
8923 6 100         if (nx < 2) croak("not enough 'x' observations");
8924 5 100         if (ny < 2) croak("not enough 'y' observations");
8925              
8926 4           NV df_x = (NV)(nx - 1);
8927 4           NV df_y = (NV)(ny - 1);
8928 4           NV var_x = M2_x / df_x;
8929 4           NV var_y = M2_y / df_y;
8930 4 100         if (var_y == 0.0) croak("var_test: variance of 'y' is zero (cannot divide by zero)");
8931             // --- Statistics Math ---
8932 3           NV estimate = var_x / var_y;
8933 3           NV statistic = estimate / ratio;
8934 3           NV p_val = pf(statistic, df_x, df_y);
8935 3           NV ci_lower = 0.0, ci_upper = INFINITY;
8936 3 50         if (strcmp(alternative, "less") == 0) {
8937 0           ci_upper = estimate / qf_bisection(1.0 - conf_level, df_x, df_y);
8938 3 50         } else if (strcmp(alternative, "greater") == 0) {
8939 0           p_val = 1.0 - p_val;
8940 0           ci_lower = estimate / qf_bisection(conf_level, df_x, df_y);
8941             } else {
8942             // two.sided
8943 3           NV p1 = p_val;
8944 3           NV p2 = 1.0 - p_val;
8945 3 50         p_val = 2.0 * (p1 < p2 ? p1 : p2);
8946 3           NV beta = (1.0 - conf_level) / 2.0;
8947 3           ci_lower = estimate / qf_bisection(1.0 - beta, df_x, df_y);
8948 3           ci_upper = estimate / qf_bisection(beta, df_x, df_y);
8949             }
8950             // --- Pack Results ---
8951 3           HV* restrict results = newHV();
8952 3           hv_store(results, "statistic", 9, newSVnv(statistic), 0);
8953 3           AV* restrict param_av = newAV();
8954 3           av_push(param_av, newSVnv(df_x));
8955 3           av_push(param_av, newSVnv(df_y));
8956 3           hv_store(results, "parameter", 9, newRV_noinc((SV*)param_av), 0);
8957 3           hv_store(results, "p_value", 7, newSVnv(p_val), 0);
8958 3           AV* restrict conf_int = newAV();
8959 3           av_push(conf_int, newSVnv(ci_lower));
8960 3           av_push(conf_int, newSVnv(ci_upper));
8961 3           hv_store(results, "conf_int", 8, newRV_noinc((SV*)conf_int), 0);
8962 3           hv_store(results, "estimate", 8, newSVnv(estimate), 0);
8963 3           hv_store(results, "null_value", 10, newSVnv(ratio), 0);
8964 3           hv_store(results, "alternative", 11, newSVpv(alternative, 0), 0);
8965 3           hv_store(results, "method", 6, newSVpv("F test to compare two variances", 0), 0);
8966 3           RETVAL = newRV_noinc((SV*)results);
8967             }
8968             OUTPUT:
8969             RETVAL
8970              
8971             SV *sample(ref, n = 1)
8972             SV *ref
8973             IV n
8974             PREINIT:
8975 6 50         SV *restrict ret = &PL_sv_undef;
8976             CODE:
8977 6 50         if (!PL_srand_called) {
8978 0           (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
8979 0           PL_srand_called = TRUE;
8980             }
8981 6 50         if (n < 0) n = 0;
8982 6 50         if (SvROK(ref)) {
8983 6           SV *restrict rv = SvRV(ref);
8984             /* --- HASH REFERENCE --- */
8985 6 100         if (SvTYPE(rv) == SVt_PVHV) {
8986 3           HV *restrict hv = (HV *)rv;
8987 3           unsigned count = hv_iterinit(hv);
8988 3 50         unsigned limit = (n < (IV)count) ? (I32)n : count;
8989 3           HV *restrict ret_hv = newHV();
8990              
8991 3 50         if (count > 0 && limit > 0) {
    50          
8992             HE **restrict entries;
8993             HE *restrict entry;
8994             unsigned i;
8995 3           Newx(entries, count, HE *);
8996             /* Collect all HE pointers in one pass */
8997 3           i = 0;
8998 15 100         while ((entry = hv_iternext(hv)))
8999 12           entries[i++] = entry;
9000              
9001             /* Partial Fisher-Yates (only 'limit' passes) */
9002 9 100         for (i = 0; i < limit; i++) {
9003 6           I32 j = i + (I32)(Drand01() * (count - i));
9004 6           HE *restrict tmp = entries[i];
9005 6           entries[i] = entries[j];
9006 6           entries[j] = tmp;
9007             }
9008              
9009             /* Pre-size result hash to avoid rehashing during population */
9010 3           hv_ksplit(ret_hv, limit);
9011              
9012 9 100         for (i = 0; i < limit; i++) {
9013 6           HEK *restrict hek = HeKEY_hek(entries[i]);
9014             /*
9015             * hv_store() with a precomputed hash skips the hash
9016             * computation entirely. Negative klen signals UTF-8.
9017             */
9018 6 50         (void)hv_store(
9019             ret_hv,
9020             HEK_KEY(hek),
9021             HEK_UTF8(hek) ? -(I32)HEK_LEN(hek) : (I32)HEK_LEN(hek),
9022             SvREFCNT_inc(HeVAL(entries[i])), /* HeVAL: direct macro, no call */
9023             HeHASH(entries[i]) /* reuse precomputed hash */
9024             );
9025             }
9026 3           Safefree(entries);
9027             }
9028 3           ret = newRV_noinc((SV *)ret_hv);
9029 3 50         } else if (SvTYPE(rv) == SVt_PVAV) {/* --- ARRAY REFERENCE --- */
9030 3           AV *restrict av = (AV *)rv;
9031 3 50         size_t count = av_top_index(av) + 1; /* signed; 0 for empty AV */
9032 3           size_t limit = (n < count) ? (size_t)n : count;
9033 3           AV *restrict ret_av = newAV();
9034             /* Pre-allocate the result array to avoid incremental reallocs */
9035 3 50         if (n > 0)
9036 3           av_extend(ret_av, (size_t)n - 1);
9037 3 50         if (count > 0) {
9038 3           SV **restrict src = AvARRAY(av); /* direct pointer into AV's C array */
9039             size_t *restrict idx;
9040              
9041             /* Shuffle indices rather than SV** to keep the original AV intact */
9042 3 50         Newx(idx, count, size_t);
9043 18 100         for (size_t i = 0; i < count; i++)
9044 15           idx[i] = i;
9045             // Partial Fisher-Yates on the index array
9046 9 100         for (size_t i = 0; i < limit; i++) {
9047 6           size_t j = i + (size_t)(Drand01() * (count - i));
9048 6           size_t tmp = idx[i];
9049 6           idx[i] = idx[j];
9050 6           idx[j] = tmp;
9051             }
9052              
9053 9 100         for (size_t i = 0; i < (size_t)n; i++) {
9054 6 50         if (i < limit) {
9055 6           SV *restrict sv = src[idx[i]]; /* AvARRAY direct access — no av_fetch call */
9056             SV *restrict push_sv;
9057 6 50         if (sv && sv != &PL_sv_undef)
    50          
9058 6           push_sv = SvREFCNT_inc(sv);
9059             else
9060 0           push_sv = newSV(0);
9061 6           av_push(ret_av, push_sv);
9062             } else {
9063 0           av_push(ret_av, newSV(0));
9064             }
9065             }
9066 3           Safefree(idx);
9067             } else {
9068 0 0         for (size_t i = 0; i < (size_t)n; i++)
9069 0           av_push(ret_av, newSV(0));
9070             }
9071 3           ret = newRV_noinc((SV *)ret_av);
9072             }
9073             }
9074 6           RETVAL = ret;
9075             OUTPUT:
9076             RETVAL
9077              
9078             SV* dnorm(...)
9079             CODE:
9080             {
9081 23 50         if (items < 1) {
9082 0           croak("Usage: dnorm(x), dnorm(x, mean => 0, sd => 1, log => 0)");
9083             }
9084 23           SV*restrict x_sv = ST(0);
9085 23           NV mean = 0.0, sd = 1.0; /*defaults*/
9086 23           bool give_log = 0;
9087             // --- Parse remaining named arguments from the flat stack ---
9088 23 50         if ((items - 1) % 2 != 0) {
9089 0           croak("dnorm: Expected an even number of key-value named arguments after 'x'");
9090             }
9091 32 100         for (size_t i = 1; i < items; i += 2) {
9092 9           const char* restrict key = SvPV_nolen(ST(i));
9093 9           SV* restrict val = ST(i + 1);
9094 9 100         if (strEQ(key, "mean")) mean = SvNV(val);
9095 6 100         else if (strEQ(key, "sd")) sd = SvNV(val);
9096 2 50         else if (strEQ(key, "log")) give_log = SvTRUE(val) ? 1 : 0;
9097 0           else croak("dnorm: unknown argument '%s'", key);
9098             }
9099             // --- Branch based on scalar vs. arrayref for 'x' ---
9100 24 100         if (SvROK(x_sv) && SvTYPE(SvRV(x_sv)) == SVt_PVAV) {
    50          
9101             // x is an array reference
9102 1           AV *restrict x_av = (AV*)SvRV(x_sv);
9103 1           IV n = av_len(x_av) + 1;
9104 1           AV *restrict result_av = newAV();
9105 1 50         if (n > 0) {
9106 1           av_extend(result_av, n - 1);
9107 4 100         for (IV i = 0; i < n; i++) {
9108 3           SV **restrict elem = av_fetch(x_av, i, 0);
9109 3 50         NV x_val = (elem && *elem) ? SvNV(*elem) : NAN;
    50          
9110 3           NV res = c_dnorm(x_val, mean, sd, give_log);
9111 3           av_store(result_av, i, newSVnv(res));
9112             }
9113             }
9114 1           RETVAL = newRV_noinc((SV*)result_av);
9115             } else {
9116             // x is a single numeric scalar
9117 22           NV x_val = SvNV(x_sv);
9118 22           NV res = c_dnorm(x_val, mean, sd, give_log);
9119 22           RETVAL = newSVnv(res);
9120             }
9121             }
9122             OUTPUT:
9123             RETVAL
9124              
9125             void ljoin(h_ref, i_ref)
9126             SV *h_ref;
9127             SV *i_ref;
9128             PREINIT:
9129             HV *restrict h_hv, *restrict i_hv;
9130             HE *restrict h_entry;
9131             CODE:
9132             /* 1. Validate inputs are hash references */
9133 4 50         if (!SvROK(h_ref) || SvTYPE(SvRV(h_ref)) != SVt_PVHV) {
    50          
9134 0           croak("First argument to ljoin must be a hash reference");
9135             }
9136 4 50         if (!SvROK(i_ref) || SvTYPE(SvRV(i_ref)) != SVt_PVHV) {
    50          
9137 0           croak("Second argument to ljoin must be a hash reference");
9138             }
9139 4           h_hv = (HV *)SvRV(h_ref);
9140 4           i_hv = (HV *)SvRV(i_ref);
9141             /* 2. Iterate through the primary hash ($h) */
9142 4           hv_iterinit(h_hv);
9143 8 100         while ((h_entry = hv_iternext(h_hv))) {
9144 4           SV *restrict row_key_sv = hv_iterkeysv(h_entry);
9145 4           SV *restrict h_row_sv = hv_iterval(h_hv, h_entry);
9146             // 3. Check if this row key exists in the secondary hash ($i)
9147 4           HE *restrict i_fetch_he = hv_fetch_ent(i_hv, row_key_sv, 0, 0);
9148 4 50         if (i_fetch_he) {
9149 4           SV *restrict i_row_sv = HeVAL(i_fetch_he);
9150             // 4. Ensure $h->{row} is a Hash and $i->{row} is a valid reference
9151 4 100         if (SvROK(h_row_sv) && SvTYPE(SvRV(h_row_sv)) == SVt_PVHV && SvROK(i_row_sv)) {
    50          
    50          
9152 3           HV *restrict h_row_hv = (HV *)SvRV(h_row_sv);
9153             /* Case A: $i->{row} is a Hash Reference */
9154 3 100         if (SvTYPE(SvRV(i_row_sv)) == SVt_PVHV) {
9155 2           HV *restrict i_row_hv = (HV *)SvRV(i_row_sv);
9156             HE *restrict i_entry;
9157 2           hv_iterinit(i_row_hv);
9158 4 100         while ((i_entry = hv_iternext(i_row_hv))) {
9159 2           SV *restrict col_key_sv = hv_iterkeysv(i_entry);
9160 2           SV *restrict col_val = hv_iterval(i_row_hv, i_entry);
9161 2           hv_store_ent(h_row_hv, col_key_sv, SvREFCNT_inc(col_val), 0);
9162             }
9163 1 50         } else if (SvTYPE(SvRV(i_row_sv)) == SVt_PVAV) {
9164             // Case B: $i->{row} is an Array Reference
9165 1           AV *restrict i_row_av = (AV *)SvRV(i_row_sv);
9166             // av_len returns the top index (length - 1)
9167 1           SSize_t top_idx = av_len(i_row_av);
9168             // Iterate through the array in chunks of 2 (key-value pairs)
9169 3 100         for (SSize_t idx = 0; idx < top_idx; idx += 2) {
9170 2           SV **restrict key_svp = av_fetch(i_row_av, idx, 0);
9171 2           SV **restrict val_svp = av_fetch(i_row_av, idx + 1, 0);
9172             // Ensure both the key and value exist in the array
9173 2 50         if (key_svp && val_svp) {
    50          
9174 2           hv_store_ent(h_row_hv, *key_svp, SvREFCNT_inc(*val_svp), 0);
9175             }
9176             }
9177             }
9178             }
9179             }
9180             }
9181              
9182             void add_data(h_ref, i_ref)
9183             SV *h_ref;
9184             SV *i_ref;
9185             PREINIT:
9186 14           short int target_root_mode = 0; // 1 = Hash, 2 = Array
9187 14           short int i_root_mode = 0; // 1 = Hash, 2 = Array
9188 14           short int target_inner_mode = 0; // 0 = Unknown, 1 = Hash, 2 = Array
9189             CODE:
9190             // 1. Validate inputs (Allow both Hash and Array references at the root)
9191 14 100         if (!SvROK(h_ref) || (SvTYPE(SvRV(h_ref)) != SVt_PVHV && SvTYPE(SvRV(h_ref)) != SVt_PVAV)) {
    100          
    50          
9192 1           croak("1st argument to add_data must be a hash or array reference");
9193             }
9194 13 100         if (!SvROK(i_ref) || (SvTYPE(SvRV(i_ref)) != SVt_PVHV && SvTYPE(SvRV(i_ref)) != SVt_PVAV)) {
    100          
    50          
9195 1           croak("2nd argument to add_data must be a hash or array reference");
9196             }
9197 12 100         target_root_mode = (SvTYPE(SvRV(h_ref)) == SVt_PVHV) ? 1 : 2;
9198 12 100         i_root_mode = (SvTYPE(SvRV(i_ref)) == SVt_PVHV) ? 1 : 2;
9199             // Probe h_ref for inner structure
9200 12 100         if (target_root_mode == 1) {
9201 10           HV *restrict h_hv = (HV *)SvRV(h_ref);
9202 10 50         if (HvKEYS(h_hv) > 0) {
    100          
9203 8           HE **restrict probe_array = HvARRAY(h_hv);
9204 8           STRLEN probe_max = HvMAX(h_hv);
9205 43 50         for (STRLEN p_idx = 0; p_idx <= probe_max && target_inner_mode == 0; p_idx++) {
    100          
9206 43 100         for (HE *restrict p_entry = probe_array[p_idx]; p_entry && target_inner_mode == 0; p_entry = HeNEXT(p_entry)) {
    50          
9207 8           SV *restrict val = HeVAL(p_entry);
9208 8 50         if (SvROK(val)) {
9209 8 100         if (SvTYPE(SvRV(val)) == SVt_PVHV) target_inner_mode = 1;
9210 3 50         else if (SvTYPE(SvRV(val)) == SVt_PVAV) target_inner_mode = 2;
9211             }
9212             }
9213             }
9214             }
9215             } else {
9216 2           AV *restrict h_av = (AV *)SvRV(h_ref);
9217 2           SSize_t top = av_len(h_av);
9218 4 100         for (SSize_t p_idx = 0; p_idx <= top && target_inner_mode == 0; p_idx++) {
    50          
9219 2           SV **restrict svp = av_fetch(h_av, p_idx, 0);
9220 2 50         if (svp && *svp && SvROK(*svp)) {
    50          
    50          
9221 2 50         if (SvTYPE(SvRV(*svp)) == SVt_PVHV) target_inner_mode = 1;
9222 0 0         else if (SvTYPE(SvRV(*svp)) == SVt_PVAV) target_inner_mode = 2;
9223             }
9224             }
9225             }
9226             // Target is empty, infer intent from source hash/array
9227 12 100         if (target_inner_mode == 0) {
9228 2 50         if (i_root_mode == 1) {
9229 2           HV *restrict i_hv = (HV *)SvRV(i_ref);
9230 2 50         if (HvKEYS(i_hv) > 0) {
    50          
9231 2           HE **restrict probe_array = HvARRAY(i_hv);
9232 2           STRLEN probe_max = HvMAX(i_hv);
9233 16 100         for (STRLEN p_idx = 0; p_idx <= probe_max && target_inner_mode == 0; p_idx++) {
    100          
9234 16 100         for (HE *restrict p_entry = probe_array[p_idx]; p_entry && target_inner_mode == 0; p_entry = HeNEXT(p_entry)) {
    50          
9235 2           SV *restrict val = HeVAL(p_entry);
9236 2 50         if (SvROK(val)) {
9237 2 100         if (SvTYPE(SvRV(val)) == SVt_PVHV) target_inner_mode = 1;
9238 1 50         else if (SvTYPE(SvRV(val)) == SVt_PVAV) target_inner_mode = 2;
9239             }
9240             }
9241             }
9242             }
9243             } else {
9244 0           AV *restrict i_av = (AV *)SvRV(i_ref);
9245 0           SSize_t top = av_len(i_av);
9246 0 0         for (SSize_t p_idx = 0; p_idx <= top && target_inner_mode == 0; p_idx++) {
    0          
9247 0           SV **restrict svp = av_fetch(i_av, p_idx, 0);
9248 0 0         if (svp && *svp && SvROK(*svp)) {
    0          
    0          
9249 0 0         if (SvTYPE(SvRV(*svp)) == SVt_PVHV) target_inner_mode = 1;
9250 0 0         else if (SvTYPE(SvRV(*svp)) == SVt_PVAV) target_inner_mode = 2;
9251             }
9252             }
9253             }
9254             }
9255 12 50         if (target_inner_mode == 0) { target_inner_mode = 1; }
9256             // 2. Iterate through the SECONDARY structure ($i) using a unified loop
9257 12           SSize_t i_idx = 0, i_top = -1;
9258 12           HV *restrict i_hv = NULL;
9259 12           AV *restrict i_av = NULL;
9260 12 100         if (i_root_mode == 1) {
9261 10           i_hv = (HV *)SvRV(i_ref);
9262 10           hv_iterinit(i_hv);
9263             } else {
9264 2           i_av = (AV *)SvRV(i_ref);
9265 2           i_top = av_len(i_av);
9266             }
9267 24           while (1) {
9268 36           SV *restrict row_key_sv = NULL;
9269 36           SV *restrict i_row_sv = NULL;
9270 36           SSize_t current_idx = 0;
9271 36 100         if (i_root_mode == 1) {
9272 30           HE *restrict i_entry = hv_iternext(i_hv);
9273 30 100         if (!i_entry) break;
9274 20           row_key_sv = hv_iterkeysv(i_entry);
9275 20           i_row_sv = hv_iterval(i_hv, i_entry);
9276             // Prep integer index in case target is an Array (Suppress warnings for non-numeric string keys)
9277 20 100         current_idx = looks_like_number(row_key_sv) ? SvIV(row_key_sv) : -1;
9278             } else {
9279 6 100         if (i_idx > i_top) break;
9280 4           current_idx = i_idx++;
9281 4           SV **restrict svp = av_fetch(i_av, current_idx, 0);
9282 4 50         if (!svp || !*svp) continue;
    50          
9283 4           i_row_sv = *svp;
9284             // Prep string key in case target is a Hash
9285 4           row_key_sv = sv_2mortal(newSViv(current_idx));
9286             }
9287 24 100         if (SvROK(i_row_sv)) {
9288 23           SV *restrict h_row_sv = NULL;
9289 23           HV *restrict h_row_hv = NULL;
9290 23           AV *restrict h_row_av = NULL;
9291             // 3. Fetch from $h
9292 23 100         if (target_root_mode == 1) {
9293 18           HE *restrict h_fetch_he = hv_fetch_ent((HV *)SvRV(h_ref), row_key_sv, 0, 0);
9294 18 100         if (h_fetch_he) h_row_sv = HeVAL(h_fetch_he);
9295             } else {
9296 5 100         if (current_idx >= 0) {
9297 4           SV **restrict h_fetch_svp = av_fetch((AV *)SvRV(h_ref), current_idx, 0);
9298 4 100         if (h_fetch_svp && *h_fetch_svp) h_row_sv = *h_fetch_svp;
    50          
9299             }
9300             }
9301 23 100         if (h_row_sv && SvROK(h_row_sv)) {
    50          
9302 11 100         if (SvTYPE(SvRV(h_row_sv)) == SVt_PVHV) {
9303 7           h_row_hv = (HV *)SvRV(h_row_sv);
9304 4 50         } else if (SvTYPE(SvRV(h_row_sv)) == SVt_PVAV) {
9305 4           h_row_av = (AV *)SvRV(h_row_sv);
9306             }
9307             }
9308             // 4. Row DOES NOT exist (or is incompatible type): Create it matching target_inner_mode
9309 23 100         if (!h_row_hv && !h_row_av) {
    100          
9310 12 100         if (target_inner_mode == 2) {
9311 3           h_row_av = newAV();
9312 3           h_row_sv = newRV_noinc((SV *)h_row_av);
9313             } else {
9314 9           h_row_hv = newHV();
9315 9           h_row_sv = newRV_noinc((SV *)h_row_hv);
9316             }
9317 12 100         if (target_root_mode == 1) {
9318 9           hv_store_ent((HV *)SvRV(h_ref), row_key_sv, h_row_sv, 0);
9319             } else {
9320 3 100         if (current_idx >= 0) {
9321 2           av_store((AV *)SvRV(h_ref), current_idx, h_row_sv);
9322             }
9323             }
9324             }
9325             // 5. Merge data across potentially mismatched inner structures
9326 23 100         if (h_row_hv) {
9327 16 100         if (SvTYPE(SvRV(i_row_sv)) == SVt_PVHV) {
9328             // Hash into Hash (Direct copy)
9329 12           HV *restrict i_inner_hv = (HV *)SvRV(i_row_sv);
9330             HE *restrict i_inner_entry;
9331 12           hv_iterinit(i_inner_hv);
9332 25 100         while ((i_inner_entry = hv_iternext(i_inner_hv))) {
9333 13           SV *restrict col_key_sv = hv_iterkeysv(i_inner_entry);
9334 13           SV *restrict col_val = hv_iterval(i_inner_hv, i_inner_entry);
9335 13           hv_store_ent(h_row_hv, col_key_sv, SvREFCNT_inc(col_val), 0);
9336             }
9337 4 50         } else if (SvTYPE(SvRV(i_row_sv)) == SVt_PVAV) {
9338             // Array into Hash (Read pairs)
9339 4           AV *restrict i_inner_av = (AV *)SvRV(i_row_sv);
9340 4           SSize_t inner_top_idx = av_len(i_inner_av);
9341 10 100         for (SSize_t idx = 0; idx < inner_top_idx; idx += 2) {
9342 6           SV **restrict key_svp = av_fetch(i_inner_av, idx, 0);
9343 6           SV **restrict val_svp = av_fetch(i_inner_av, idx + 1, 0);
9344 6 50         if (key_svp && *key_svp && val_svp) {
    50          
    50          
9345 6 50         SV *restrict val_to_store = *val_svp ? *val_svp : &PL_sv_undef;
9346 6           hv_store_ent(h_row_hv, *key_svp, SvREFCNT_inc(val_to_store), 0);
9347             }
9348             }
9349             }
9350 7 50         } else if (h_row_av) {
9351 7 100         if (SvTYPE(SvRV(i_row_sv)) == SVt_PVAV) {
9352             // Array into Array (Direct push with non-null pointer assurance)
9353 5           AV *restrict i_inner_av = (AV *)SvRV(i_row_sv);
9354 5           SSize_t inner_top_idx = av_len(i_inner_av);
9355 16 100         for (SSize_t idx = 0; idx <= inner_top_idx; ++idx) {
9356 11           SV **restrict val_svp = av_fetch(i_inner_av, idx, 0);
9357 11 50         if (val_svp) {
9358 11 50         SV *restrict val_to_push = *val_svp ? *val_svp : &PL_sv_undef;
9359 11           SV *restrict sv_inc = SvREFCNT_inc(val_to_push);
9360 11 50         if (sv_inc) {
9361 11           av_push(h_row_av, sv_inc);
9362             }
9363             }
9364             }
9365 2 50         } else if (SvTYPE(SvRV(i_row_sv)) == SVt_PVHV) {
9366             // Hash into Array (Flatten and push pairs with non-null pointer assurance)
9367 2           HV *restrict i_inner_hv = (HV *)SvRV(i_row_sv);
9368             HE *restrict i_inner_entry;
9369 2           hv_iterinit(i_inner_hv);
9370 4 100         while ((i_inner_entry = hv_iternext(i_inner_hv))) {
9371 2           SV *restrict col_key_sv = hv_iterkeysv(i_inner_entry);
9372 2           SV *restrict col_val = hv_iterval(i_inner_hv, i_inner_entry);
9373 2 50         if (col_key_sv && col_val) {
    50          
9374 2           SV *restrict sv_key_inc = SvREFCNT_inc(col_key_sv);
9375 2           SV *restrict sv_val_inc = SvREFCNT_inc(col_val);
9376 2 50         if (sv_key_inc && sv_val_inc) {
    50          
9377 2           av_push(h_row_av, sv_key_inc);
9378 2           av_push(h_row_av, sv_val_inc);
9379             }
9380             }
9381             }
9382             }
9383             }
9384             }
9385             }
9386              
9387             SV* value_counts(...)
9388             PREINIT:
9389             HV*restrict counts_hv;
9390             SV*restrict arg1;
9391             CODE:
9392             // 1. CHECK FOR DATA FIRST to prevent memory leaks if we die
9393 11 100         if (items == 0) {
9394 1           croak("value_counts: no data provided. At least one argument is required.");
9395             }
9396 10           arg1 = ST(0);
9397 10 100         if (!SvOK(arg1)) {
9398 1           croak("First argument to value_counts is NOT defined");
9399             }
9400             // 2. Allocate memory only after we know we are proceeding
9401 9           counts_hv = newHV();
9402             // CASE 1: Flattened Array (or single scalar)
9403 9 100         if (!SvROK(arg1)) {
9404 6 100         for (unsigned i = 0; i < items; i++) {
9405 4           increment_count(aTHX_ counts_hv, ST(i));
9406             }
9407             } else {// CASE 2: Array Reference
9408 7           SV*restrict rv = SvRV(arg1);
9409 7 100         if (SvTYPE(rv) == SVt_PVAV) {
9410 1           AV*restrict av = (AV*)rv;
9411 1           SSize_t len = av_len(av) + 1;
9412 4 100         for (unsigned i = 0; i < len; i++) {
9413 3           SV**restrict valp = av_fetch(av, i, 0);
9414 3 50         if (valp) increment_count(aTHX_ counts_hv, *valp);
9415             }
9416 6 50         } else if (SvTYPE(rv) == SVt_PVHV) { // CASES 3, 4, 5: Hash Reference
9417 6           HV*restrict hv = (HV*)rv;
9418             // CASES 4 & 5: Nested Structure requiring a 2nd Argument
9419 6 100         if (items > 1) {
9420 3           SV*restrict arg2 = ST(1);
9421             STRLEN klen;
9422 3           const char*restrict key = SvPV(arg2, klen);
9423             // DataFrame-style Column-Oriented data check
9424 3           SV**restrict col_svp = hv_fetch(hv, key, klen, 0);
9425 4 100         if (col_svp && SvROK(*col_svp) && SvTYPE(SvRV(*col_svp)) == SVt_PVAV) {
    50          
    50          
9426 1           AV*restrict av = (AV*)SvRV(*col_svp);
9427 1           SSize_t len = av_len(av) + 1;
9428 4 100         for (unsigned i = 0; i < len; i++) {
9429 3           SV**restrict valp = av_fetch(av, i, 0);
9430 3 50         if (valp) increment_count(aTHX_ counts_hv, *valp);
9431             }
9432             } else {
9433             // Fallback: Row-Oriented nested structure
9434             HE*restrict he;
9435 2           hv_iterinit(hv);
9436 8 100         while ((he = hv_iternext(hv))) {
9437 6           SV*restrict inner_sv = HeVAL(he);
9438 6 50         if (SvROK(inner_sv)) {
9439 6           SV*restrict inner_rv = SvRV(inner_sv);
9440 6 50         if (SvTYPE(inner_rv) == SVt_PVHV) {// CASE 5: Hash of Hashes
9441 6           HV*restrict inner_hv = (HV*)inner_rv;
9442 6           SV**restrict valp = hv_fetch(inner_hv, key, klen, 0);
9443 6 100         if (valp) increment_count(aTHX_ counts_hv, *valp);
9444 0 0         } else if (SvTYPE(inner_rv) == SVt_PVAV) {// CASE 4: Hash of Arrays (Row-Oriented)
9445 0 0         if (looks_like_number(arg2)) {
9446 0           AV*restrict inner_av = (AV*)inner_rv;
9447 0           SSize_t idx = SvIV(arg2);
9448 0           SV**restrict valp = av_fetch(inner_av, idx, 0);
9449 0 0         if (valp) increment_count(aTHX_ counts_hv, *valp);
9450             }
9451             }
9452             }
9453             }
9454             }
9455             } else { // CASE 3: Hash Reference (No 2nd argument)
9456             HE*restrict he;
9457 3           hv_iterinit(hv);
9458 11 100         while ((he = hv_iternext(hv))) {
9459 8           SV*restrict val = HeVAL(he);
9460 8 100         if (SvROK(val)) {// --- SAFETY CHECK
9461 5           SV*restrict inner_rv = SvRV(val);
9462             // If it's a Hash of Arrays, count ALL elements in the inner arrays
9463 5 100         if (SvTYPE(inner_rv) == SVt_PVAV) {
9464 2           AV*restrict inner_av = (AV*)inner_rv;
9465 2           SSize_t len = av_len(inner_av) + 1;
9466 8 100         for (unsigned i = 0; i < len; i++) {
9467 6           SV**restrict valp = av_fetch(inner_av, i, 0);
9468 6 50         if (valp) increment_count(aTHX_ counts_hv, *valp);
9469             }
9470 3 50         } else if (SvTYPE(inner_rv) == SVt_PVHV) {
9471             // If it's a Hash of Hashes, count ALL elements across all inner keys
9472 3           HV*restrict inner_hv = (HV*)inner_rv;
9473             HE*restrict inner_he;
9474 3           hv_iterinit(inner_hv);
9475 7 100         while ((inner_he = hv_iternext(inner_hv))) {
9476 4           SV*restrict inner_val = HeVAL(inner_he);
9477 4           increment_count(aTHX_ counts_hv, inner_val);
9478             }
9479             } else { /* Unrecognized nested reference type */
9480 0           SvREFCNT_dec((SV*)counts_hv);
9481 0           croak("value_counts: Unsupported nested reference type.");
9482             }
9483             } else {
9484             /* Simple scalar value */
9485 3           increment_count(aTHX_ counts_hv, val);
9486             }
9487             }
9488             }
9489             } else {
9490             /* Safely decrement the reference count of our hash before dying to prevent a leak */
9491 0           SvREFCNT_dec((SV*)counts_hv);
9492 0           croak("value_counts: Unsupported reference type.");
9493             }
9494             }
9495 9           RETVAL = newRV_noinc((SV*)counts_hv);
9496             OUTPUT:
9497             RETVAL
9498              
9499             #define EVAL_FILTER(sub_sv, val_sv, keep) do { \
9500             dSP; \
9501             unsigned int count; \
9502             SV *restrict _ef_arg = (val_sv) ? (val_sv) : &PL_sv_undef; \
9503             ENTER; \
9504             SAVETMPS; \
9505             SAVE_DEFSV; \
9506             SvREFCNT_inc(_ef_arg); /* Prevent LEAVE from stealing the refcount */ \
9507             DEFSV_set(_ef_arg); \
9508             PUSHMARK(SP); \
9509             XPUSHs(_ef_arg); \
9510             PUTBACK; \
9511             count = call_sv(sub_sv, G_SCALAR | G_EVAL); \
9512             SPAGAIN; \
9513             if (SvTRUE(ERRSV)) { FREETMPS; LEAVE; croak(NULL); } \
9514             if (count > 0) { \
9515             SV *restrict ret_sv = POPs; \
9516             keep = SvTRUE(ret_sv); \
9517             } else { \
9518             keep = 0; \
9519             } \
9520             PUTBACK; \
9521             FREETMPS; \
9522             LEAVE; \
9523             } while (0)
9524              
9525             SV *group_by(data_ref, target_key_sv, group_key_sv, ...)
9526             SV *data_ref;
9527             SV *target_key_sv;
9528             SV *group_key_sv;
9529             PREINIT:
9530             HV *restrict result_hv;
9531 8           HV *restrict filter_hv = NULL;
9532             SV *restrict result_ref;
9533             CODE:
9534 8 100         if (!SvOK(data_ref)) {
9535 1           croak("First argument to group_by is NOT defined");
9536             }
9537 7 100         if (!SvOK(target_key_sv)) {
9538 1           croak("Second argument to group_by is NOT defined");
9539             }
9540 6 100         if (!SvOK(group_key_sv)) {
9541 1           croak("Third argument to group_by is NOT defined");
9542             }
9543             /* 1. Validate the primary input is a reference */
9544 5 50         if (!SvROK(data_ref)) {
9545 0           croak("First argument to group_by must be a reference (Array of Hashes, Hash of Arrays, or Hash of Hashes)");
9546             }
9547 5 100         if (items > 3) { /* Capture the optional filter argument */
9548 2           SV *restrict filter_ref = ST(3);
9549 2 50         if (SvROK(filter_ref) && SvTYPE(SvRV(filter_ref)) == SVt_PVHV) {
    50          
9550 2           filter_hv = (HV *)SvRV(filter_ref);
9551             }
9552             }
9553 5           result_hv = newHV(); /* 2. Allocate the hash that we will return */
9554             /* Mortalize immediately! If the callback croaks, the tmps stack
9555             * will safely clean this up. */
9556 5           result_ref = sv_2mortal(newRV_noinc((SV *)result_hv));
9557 5 100         if (SvTYPE(SvRV(data_ref)) == SVt_PVAV) { /* Input is an Array of Hashes (AoH) */
9558 2           AV *restrict data_av = (AV *)SvRV(data_ref);
9559 2           SSize_t len = av_len(data_av) + 1;
9560 10 100         for (SSize_t i = 0; i < len; i++) {
9561 8           SV **restrict row_svp = av_fetch(data_av, i, 0);
9562 8 50         if (row_svp && SvROK(*row_svp) && SvTYPE(SvRV(*row_svp)) == SVt_PVHV) {
    50          
    50          
9563 8           HV *restrict row_hv = (HV *)SvRV(*row_svp);
9564 8           HE *restrict group_he = hv_fetch_ent(row_hv, group_key_sv, 0, 0);
9565 8           HE *restrict target_he = hv_fetch_ent(row_hv, target_key_sv, 0, 0);
9566 8 50         if (group_he) {
9567 8           SV *restrict group_val = HeVAL(group_he);
9568 8 100         SV *restrict target_val = target_he ? HeVAL(target_he) : NULL;
9569 8 100         if (target_val && SvOK(target_val)) {
    50          
9570 7           bool pass_filter = 1;
9571 7 100         if (filter_hv) {
9572             HE *restrict f_he;
9573 4           hv_iterinit(filter_hv);
9574 6 100         while ((f_he = hv_iternext(filter_hv))) {
9575 4           SV *restrict f_col = hv_iterkeysv(f_he);
9576 4           SV *restrict f_sub = hv_iterval(filter_hv, f_he);
9577 4           HE *restrict val_he = hv_fetch_ent(row_hv, f_col, 0, 0);
9578 4 50         SV *restrict val_sv = val_he ? HeVAL(val_he) : NULL;
9579             bool keep;
9580 4 50         EVAL_FILTER(f_sub, val_sv, keep);
    50          
    50          
    50          
    50          
    0          
    50          
    50          
9581 4 100         if (!keep) {
9582 2           pass_filter = 0;
9583 2           break;
9584             }
9585             }
9586             }
9587 7 100         if (pass_filter) {
9588 5           HE *restrict res_he = hv_fetch_ent(result_hv, group_val, 0, 0);
9589             AV *restrict res_av;
9590 5 100         if (res_he) {
9591 1           res_av = (AV *)SvRV(HeVAL(res_he));
9592             } else {
9593 4           res_av = newAV();
9594 4           hv_store_ent(result_hv, group_val, newRV_noinc((SV *)res_av), 0);
9595             }
9596 5           av_push(res_av, newSVsv(target_val));
9597             }
9598             }
9599             }
9600             }
9601             }
9602 3 50         } else if (SvTYPE(SvRV(data_ref)) == SVt_PVHV) {
9603 3           HV *restrict data_hv = (HV *)SvRV(data_ref);
9604 3           HE *restrict group_he = hv_fetch_ent(data_hv, group_key_sv, 0, 0);
9605 3           HE *restrict target_he = hv_fetch_ent(data_hv, target_key_sv, 0, 0);
9606 3 100         if (group_he && target_he &&
    50          
9607 2 50         SvROK(HeVAL(group_he)) && SvTYPE(SvRV(HeVAL(group_he))) == SVt_PVAV &&
    50          
9608 4 50         SvROK(HeVAL(target_he)) && SvTYPE(SvRV(HeVAL(target_he))) == SVt_PVAV) {
    50          
9609 2           AV *restrict group_av = (AV *)SvRV(HeVAL(group_he));
9610 2           AV *restrict target_av = (AV *)SvRV(HeVAL(target_he));
9611 2           SSize_t g_len = av_len(group_av) + 1;
9612 2           SSize_t t_len = av_len(target_av) + 1;
9613 2           SSize_t len = g_len < t_len ? g_len : t_len;
9614 10 100         for (SSize_t i = 0; i < len; i++) {
9615 8           SV **restrict g_svp = av_fetch(group_av, i, 0);
9616 8           SV **restrict t_svp = av_fetch(target_av, i, 0);
9617 8 50         if (g_svp && *g_svp) {
    50          
9618 8           SV *restrict g_val = *g_svp;
9619 8 50         SV *restrict t_val = (t_svp && *t_svp) ? *t_svp : NULL;
    50          
9620 8 50         if (t_val && SvOK(t_val)) {
    100          
9621 7           bool pass_filter = 1;
9622 7 100         if (filter_hv) {
9623             HE *restrict f_he;
9624 4           hv_iterinit(filter_hv);
9625 6 100         while ((f_he = hv_iternext(filter_hv))) {
9626 4           SV *restrict f_col = hv_iterkeysv(f_he);
9627 4           SV *restrict f_sub = hv_iterval(filter_hv, f_he);
9628 4           SV *restrict val_sv = NULL;
9629 4           HE *restrict arr_he = hv_fetch_ent(data_hv, f_col, 0, 0);
9630 4 50         if (arr_he && SvROK(HeVAL(arr_he)) && SvTYPE(SvRV(HeVAL(arr_he))) == SVt_PVAV) {
    50          
    50          
9631 4           AV *restrict col_av = (AV *)SvRV(HeVAL(arr_he));
9632 4           SV **restrict val_svp = av_fetch(col_av, i, 0);
9633 4 50         if (val_svp) val_sv = *val_svp;
9634             }
9635             bool keep;
9636 4 50         EVAL_FILTER(f_sub, val_sv, keep);
    50          
    50          
    50          
    50          
    0          
    50          
    50          
9637 4 100         if (!keep) {
9638 2           pass_filter = 0;
9639 2           break;
9640             }
9641             }
9642             }
9643 7 100         if (pass_filter) {
9644 5           HE *restrict res_he = hv_fetch_ent(result_hv, g_val, 0, 0);
9645             AV *restrict res_av;
9646 5 100         if (res_he) {
9647 1           res_av = (AV *)SvRV(HeVAL(res_he));
9648             } else {
9649 4           res_av = newAV();
9650 4           hv_store_ent(result_hv, g_val, newRV_noinc((SV *)res_av), 0);
9651             }
9652 5           av_push(res_av, newSVsv(t_val));
9653             }
9654             }
9655             }
9656             }
9657             } else {
9658             HE *restrict row_he;
9659 1           hv_iterinit(data_hv);
9660 6 100         while ((row_he = hv_iternext(data_hv))) {
9661 5           SV *restrict row_val = hv_iterval(data_hv, row_he);
9662 5 50         if (SvROK(row_val) && SvTYPE(SvRV(row_val)) == SVt_PVHV) {
    50          
9663 5           HV *restrict inner_hv = (HV *)SvRV(row_val);
9664 5           HE *restrict inner_group_he = hv_fetch_ent(inner_hv, group_key_sv, 0, 0);
9665 5           HE *restrict inner_target_he = hv_fetch_ent(inner_hv, target_key_sv, 0, 0);
9666 5 50         if (inner_group_he) {
9667 5           SV *restrict g_val = HeVAL(inner_group_he);
9668 5 100         SV *restrict t_val = inner_target_he ? HeVAL(inner_target_he) : NULL;
9669 5 100         if (t_val && SvOK(t_val)) {
    100          
9670 3           bool pass_filter = 1;
9671 3 50         if (filter_hv) {
9672             HE *restrict f_he;
9673 0           hv_iterinit(filter_hv);
9674 0 0         while ((f_he = hv_iternext(filter_hv))) {
9675 0           SV *restrict f_col = hv_iterkeysv(f_he);
9676 0           SV *restrict f_sub = hv_iterval(filter_hv, f_he);
9677 0           HE *restrict val_he = hv_fetch_ent(inner_hv, f_col, 0, 0);
9678 0 0         SV *restrict val_sv = val_he ? HeVAL(val_he) : NULL;
9679             bool keep;
9680 0 0         EVAL_FILTER(f_sub, val_sv, keep);
    0          
    0          
    0          
    0          
    0          
    0          
    0          
9681 0 0         if (!keep) {
9682 0           pass_filter = 0;
9683 0           break;
9684             }
9685             }
9686             }
9687 3 50         if (pass_filter) {
9688 3           HE *restrict res_he = hv_fetch_ent(result_hv, g_val, 0, 0);
9689             AV *restrict res_av;
9690 3 100         if (res_he) {
9691 1           res_av = (AV *)SvRV(HeVAL(res_he));
9692             } else {
9693 2           res_av = newAV();
9694 2           hv_store_ent(result_hv, g_val, newRV_noinc((SV *)res_av), 0);
9695             }
9696 3           av_push(res_av, newSVsv(t_val));
9697             }
9698             }
9699             }
9700             }
9701             }
9702             }
9703             } else {
9704 0           croak("First argument to group_by must be an Array or Hash reference");
9705             }
9706             // Balance xsubpp's automatic sv_2mortal to prevent refcount dropping to -1
9707 5           RETVAL = SvREFCNT_inc(result_ref);
9708             OUTPUT:
9709             RETVAL
9710              
9711             SV* prcomp(...)
9712             CODE:
9713             {
9714 12           SV *restrict x_sv = NULL;
9715 12           bool retx = TRUE, center = TRUE, do_scale = FALSE;
9716 12           NV tol = -1.0;
9717 12           long rank_opt = -1;
9718 12           unsigned int arg_idx = 0;
9719             // 1. Shift positional 'x' argument if provided
9720 12 100         if (arg_idx < items && SvROK(ST(arg_idx))) {
    100          
9721 10           int t = SvTYPE(SvRV(ST(arg_idx)));
9722 10 100         if (t == SVt_PVAV || t == SVt_PVHV) {
    50          
9723 10           x_sv = ST(arg_idx);
9724 10           arg_idx++;
9725             }
9726             }
9727             // 2. Parse named arguments
9728 12 100         if ((items - arg_idx) % 2 != 0) croak("Usage: prcomp($data, key => value, ...)");
9729 14 100         for (; arg_idx < items; arg_idx += 2) {
9730 4           const char *restrict key = SvPV_nolen(ST(arg_idx));
9731 4           SV *restrict val = ST(arg_idx + 1);
9732 4 50         if (strEQ(key, "x")) x_sv = val;
9733 4 50         else if (strEQ(key, "retx")) retx = SvTRUE(val);
9734 4 50         else if (strEQ(key, "center")) center = SvTRUE(val);
9735 4 100         else if (strEQ(key, "scale")) do_scale = SvTRUE(val);
9736 2 100         else if (strEQ(key, "tol")) tol = SvOK(val) ? SvNV(val) : -1.0;
    50          
9737 1 50         else if (strEQ(key, "rank")) rank_opt = SvOK(val) ? (long)SvIV(val) : -1;
    50          
9738 0           else croak("prcomp: unknown argument '%s'", key);
9739             }
9740              
9741 10 100         if (!x_sv || !SvROK(x_sv))
    50          
9742 1           croak("prcomp: 'x' is a required argument and must be a reference");
9743              
9744             // 3. Detect Data Structure (AoA, HoA, HoH)
9745 9           bool is_aoa = FALSE, is_hoa = FALSE, is_hoh = FALSE;
9746 9           size_t n_raw = 0, p = 0;
9747 9           char **restrict colnames = NULL;
9748 9           SV *restrict ref = SvRV(x_sv);
9749              
9750 9 100         if (SvTYPE(ref) == SVt_PVAV) {
9751 7           AV *restrict av = (AV*)ref;
9752 7           n_raw = av_len(av) + 1;
9753 7 100         if (n_raw > 0) {
9754 6           SV **restrict first = av_fetch(av, 0, 0);
9755 6 50         if (first && SvROK(*first) && SvTYPE(SvRV(*first)) == SVt_PVAV) {
    50          
    50          
9756 6           is_aoa = TRUE;
9757 6           p = av_len((AV*)SvRV(*first)) + 1;
9758 0           } else croak("prcomp: Array reference must contain ArrayRefs (AoA)");
9759             }
9760 2 50         } else if (SvTYPE(ref) == SVt_PVHV) {
9761 2           HV *restrict hv = (HV*)ref;
9762 2 50         if (hv_iterinit(hv) > 0) {
9763 2           HE *restrict entry = hv_iternext(hv);
9764 2           SV *restrict val = hv_iterval(hv, entry);
9765 2 50         if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) {
    100          
9766 1           is_hoa = TRUE;
9767 1           n_raw = av_len((AV*)SvRV(val)) + 1;
9768 1 50         } else if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) {
    50          
9769 1           is_hoh = TRUE;
9770 1           n_raw = hv_iterinit(hv);
9771 0           } else croak("prcomp: Hash reference must contain ArrayRefs (HoA) or HashRefs (HoH)");
9772             }
9773             }
9774              
9775 9 100         if (n_raw == 0 || (p == 0 && !is_hoa && !is_hoh)) croak("prcomp: input matrix is empty or has zero columns");
    100          
    100          
    50          
9776              
9777             // 4. Extract and Sort Column Names (for Hash inputs)
9778 8 100         if (is_hoh) {
9779 1           HV *restrict hv = (HV*)ref;
9780 1           hv_iterinit(hv);
9781 1           HE *restrict entry = hv_iternext(hv);
9782 1           HV *restrict inner = (HV*)SvRV(hv_iterval(hv, entry));
9783 1           p = hv_iterinit(inner);
9784 1 50         if (p == 0) croak("prcomp: inner hashes cannot be empty");
9785              
9786 1           colnames = (char**)safemalloc(p * sizeof(char*));
9787 1           size_t c = 0;
9788 3 100         while ((entry = hv_iternext(inner))) {
9789 2           colnames[c++] = savepv(SvPV_nolen(hv_iterkeysv(entry)));
9790             }
9791 1           qsort(colnames, p, sizeof(char*), cmp_string_wt);
9792 7 100         } else if (is_hoa) {
9793 1           HV *restrict hv = (HV*)ref;
9794 1           p = hv_iterinit(hv);
9795 1 50         if (p == 0) croak("prcomp: input hash is empty");
9796 1           colnames = (char**)safemalloc(p * sizeof(char*));
9797 1           size_t c = 0;
9798             HE *restrict entry;
9799 3 100         while ((entry = hv_iternext(hv))) {
9800 2           colnames[c++] = savepv(SvPV_nolen(hv_iterkeysv(entry)));
9801             }
9802 1           qsort(colnames, p, sizeof(char*), cmp_string_wt);
9803             }
9804             // 5. Extract data & apply listwise deletion for NaNs
9805 8           NV *restrict X_mat = (NV*)safemalloc(n_raw * p * sizeof(NV));
9806 8           size_t n = 0;
9807 8 100         if (is_aoa) {
9808 6           AV *restrict av = (AV*)ref;
9809 24 100         for (size_t i = 0; i < n_raw; i++) {
9810 18           SV **restrict row_sv = av_fetch(av, i, 0);
9811 18 50         if (row_sv && SvROK(*row_sv) && SvTYPE(SvRV(*row_sv)) == SVt_PVAV) {
    50          
    50          
9812 18           AV *restrict row_av = (AV*)SvRV(*row_sv);
9813 18           bool row_ok = TRUE;
9814 54 100         for (size_t j = 0; j < p; j++) {
9815 36           SV **restrict cell_sv = av_fetch(row_av, j, 0);
9816 71 50         if (cell_sv && SvOK(*cell_sv) && looks_like_number(*cell_sv)) {
    50          
    100          
9817 35           NV v = SvNV(*cell_sv);
9818 35 50         if (!isfinite(v)) row_ok = FALSE;
9819 35           else X_mat[n * p + j] = v;
9820 1           } else row_ok = FALSE;
9821             }
9822 18 100         if (row_ok) n++;
9823             }
9824             }
9825 2 100         } else if (is_hoa) {
9826 1           HV *restrict hv = (HV*)ref;
9827 1           AV **restrict col_arrays = (AV**)safemalloc(p * sizeof(AV*));
9828 3 100         for (size_t j = 0; j < p; j++) {
9829 2           SV **restrict val = hv_fetch(hv, colnames[j], strlen(colnames[j]), 0);
9830 2           col_arrays[j] = (AV*)SvRV(*val);
9831             }
9832 4 100         for (size_t i = 0; i < n_raw; i++) {
9833 3           bool row_ok = TRUE;
9834 9 100         for (size_t j = 0; j < p; j++) {
9835 6           SV **restrict cell = av_fetch(col_arrays[j], i, 0);
9836 12 50         if (cell && SvOK(*cell) && looks_like_number(*cell)) {
    50          
    50          
9837 6           NV v = SvNV(*cell);
9838 6 50         if (!isfinite(v)) row_ok = FALSE;
9839 6           else X_mat[n * p + j] = v;
9840 0           } else row_ok = FALSE;
9841             }
9842 3 50         if (row_ok) n++;
9843             }
9844 1           Safefree(col_arrays);
9845 1 50         } else if (is_hoh) {
9846 1           HV *restrict hv = (HV*)ref;
9847 1           hv_iterinit(hv);
9848             HE *restrict entry;
9849 4 100         while ((entry = hv_iternext(hv))) {
9850 3           HV *restrict row_hv = (HV*)SvRV(hv_iterval(hv, entry));
9851 3           bool row_ok = TRUE;
9852 9 100         for (size_t j = 0; j < p; j++) {
9853 6           SV **restrict cell = hv_fetch(row_hv, colnames[j], strlen(colnames[j]), 0);
9854 12 50         if (cell && SvOK(*cell) && looks_like_number(*cell)) {
    50          
    50          
9855 6           NV v = SvNV(*cell);
9856 6 50         if (!isfinite(v)) row_ok = FALSE;
9857 6           else X_mat[n * p + j] = v;
9858 0           } else row_ok = FALSE;
9859             }
9860 3 50         if (row_ok) n++;
9861             }
9862             }
9863 8 50         if (n == 0) {
9864 0 0         if (colnames) {
9865 0 0         for (size_t i = 0; i < p; i++) Safefree(colnames[i]);
9866 0           Safefree(colnames);
9867             }
9868 0           Safefree(X_mat);
9869 0           croak("prcomp: 0 valid observations after listwise NA deletion");
9870             }
9871             // 6. Center and Scale
9872 8           NV *restrict cen_vec = (NV*)safecalloc(p, sizeof(NV));
9873 8           NV *restrict sc_vec = (NV*)safecalloc(p, sizeof(NV));
9874 22 100         for (size_t j = 0; j < p; j++) {
9875 15           NV col_sum = 0.0;
9876 58 100         for (size_t i = 0; i < n; i++) col_sum += X_mat[i * p + j];
9877 15 50         if (center) {
9878 15           cen_vec[j] = col_sum / n;
9879 58 100         for (size_t i = 0; i < n; i++) X_mat[i * p + j] -= cen_vec[j];
9880             }
9881 15 100         if (do_scale) {
9882 3           NV sum_sq = 0.0;
9883 12 100         for (size_t i = 0; i < n; i++) {
9884 9 50         NV val = X_mat[i * p + j] - (center ? 0 : (col_sum / n));
9885 9           sum_sq += val * val;
9886             }
9887 3 50         sc_vec[j] = (n > 1) ? sqrt(sum_sq / (n - 1)) : 0.0;
9888 3 100         if (sc_vec[j] <= 1e-15) {
9889 1           Safefree(X_mat); Safefree(cen_vec); Safefree(sc_vec);
9890 1 50         if (colnames) { for (size_t k = 0; k < p; k++) Safefree(colnames[k]); Safefree(colnames); }
    0          
9891 1           croak("prcomp: cannot rescale a constant/zero column to unit variance");
9892             }
9893 8 100         for (size_t i = 0; i < n; i++) X_mat[i * p + j] /= sc_vec[j];
9894             }
9895             }
9896             // 7. Construct Covariance Matrix X^T X
9897 7           NV *restrict XtX = (NV*)safecalloc(p * p, sizeof(NV));
9898 27 100         for (size_t i = 0; i < n; i++) {
9899 60 100         for (size_t j = 0; j < p; j++) {
9900 100 100         for (size_t k = j; k < p; k++) {
9901 60           XtX[j * p + k] += X_mat[i * p + j] * X_mat[i * p + k];
9902             }
9903             }
9904             }
9905             // Mirror the symmetric lower triangle
9906 21 100         for (size_t j = 0; j < p; j++) {
9907 21 100         for (size_t k = 0; k < j; k++) {
9908 7           XtX[j * p + k] = XtX[k * p + j];
9909             }
9910             }
9911             // 8. Jacobi Eigen Decomposition
9912 7           NV *restrict eigen_val = (NV*)safemalloc(p * sizeof(NV));
9913 7           NV *restrict eigen_vec = (NV*)safemalloc(p * p * sizeof(NV));
9914 7           jacobi_eigen(XtX, p, eigen_val, eigen_vec);
9915             // 9. Calculate singular values (sdev) & handle dimensions (rank/tol)
9916 7           size_t k_cols = (n < p) ? n : p;
9917 7 100         if (rank_opt > 0 && rank_opt < (long)k_cols) k_cols = (size_t)rank_opt;
    50          
9918 7           NV *restrict sdev = (NV*)safemalloc(k_cols * sizeof(NV));
9919 7 50         NV n_adj = (n > 1) ? (NV)(n - 1) : 1.0;
9920 20 100         for (size_t j = 0; j < k_cols; j++) {
9921 13           NV e_val = eigen_val[j];
9922 13 50         if (e_val < 0.0) e_val = 0.0; // clamp floating point inaccuracy
9923 13           sdev[j] = sqrt(e_val / n_adj);
9924             }
9925 7 100         if (tol >= 0.0) {
9926 1           size_t rank_est = 0;
9927 1           NV threshold = sdev[0] * tol;
9928 3 100         for (size_t j = 0; j < k_cols; j++) {
9929 2 100         if (sdev[j] > threshold) rank_est++;
9930             }
9931 1 50         if (rank_est < k_cols) k_cols = rank_est;
9932             }
9933             // 10. Build Return Hash
9934 7           HV *restrict res_hv = newHV();
9935 7           AV *restrict sdev_av = newAV();
9936 19 100         for (size_t j = 0; j < k_cols; j++) av_push(sdev_av, newSVnv(sdev[j]));
9937 7           hv_stores(res_hv, "sdev", newRV_noinc((SV*)sdev_av));
9938 7           AV *restrict rot_av = newAV();
9939 21 100         for (size_t j = 0; j < p; j++) {
9940 14           AV *restrict row_rot = newAV();
9941 38 100         for (size_t m = 0; m < k_cols; m++) {
9942 24           av_push(row_rot, newSVnv(eigen_vec[j * p + m]));
9943             }
9944 14           av_push(rot_av, newRV_noinc((SV*)row_rot));
9945             }
9946 7           hv_stores(res_hv, "rotation", newRV_noinc((SV*)rot_av));
9947 7 50         if (retx) {
9948 7           AV *restrict x_ret_av = newAV();
9949 27 100         for (size_t i = 0; i < n; i++) {
9950 20           AV *restrict row_x = newAV();
9951 54 100         for (size_t m = 0; m < k_cols; m++) {
9952 34           NV x_rot_val = 0.0;
9953 102 100         for (size_t c = 0; c < p; c++) {
9954 68           x_rot_val += X_mat[i * p + c] * eigen_vec[c * p + m];
9955             }
9956 34           av_push(row_x, newSVnv(x_rot_val));
9957             }
9958 20           av_push(x_ret_av, newRV_noinc((SV*)row_x));
9959             }
9960 7           hv_stores(res_hv, "x", newRV_noinc((SV*)x_ret_av));
9961             }
9962 7 100         if (colnames) {
9963 2           AV *restrict names_av = newAV();
9964 6 100         for (size_t j = 0; j < p; j++) {
9965 4           av_push(names_av, newSVpv(colnames[j], 0));
9966             }
9967 2           hv_stores(res_hv, "varnames", newRV_noinc((SV*)names_av));
9968             }
9969 7 50         if (center) {
9970 7           AV *restrict c_av = newAV();
9971 21 100         for (size_t j = 0; j < p; j++) av_push(c_av, newSVnv(cen_vec[j]));
9972 7           hv_stores(res_hv, "center", newRV_noinc((SV*)c_av));
9973             } else {
9974 0           hv_stores(res_hv, "center", newSVsv(&PL_sv_no));
9975             }
9976 7 100         if (do_scale) {
9977 1           AV *restrict sc_av = newAV();
9978 3 100         for (size_t j = 0; j < p; j++) av_push(sc_av, newSVnv(sc_vec[j]));
9979 1           hv_stores(res_hv, "scale", newRV_noinc((SV*)sc_av));
9980             } else {
9981 6           hv_stores(res_hv, "scale", newSVsv(&PL_sv_no));
9982             }
9983             // Cleanup
9984 7 100         if (colnames) {
9985 6 100         for (size_t i = 0; i < p; i++) Safefree(colnames[i]);
9986 2           Safefree(colnames);
9987             }
9988 7           Safefree(X_mat); Safefree(cen_vec); Safefree(sc_vec);
9989 7           Safefree(XtX); Safefree(eigen_val); Safefree(eigen_vec); Safefree(sdev);
9990              
9991 7           RETVAL = newRV_noinc((SV*)res_hv);
9992             }
9993             OUTPUT:
9994             RETVAL
9995              
9996             SV *transpose(input_ref)
9997             SV *input_ref
9998             PREINIT:
9999             svtype ref_type;
10000             SV *restrict retval_sv;
10001             CODE:
10002 38 50         SvGETMAGIC(input_ref);
    0          
10003 38 100         if (!SvROK(input_ref))
10004 1           croak("Stats::LikeR::transpose: Input must be a hash ref or array ref");
10005 37           ref_type = SvTYPE(SvRV(input_ref));
10006 37 100         if (ref_type == SVt_PVHV) {// ── Hash-of-Hashes
10007 14           HV *restrict in_hv = (HV *)SvRV(input_ref);
10008 14           HV *restrict out_hv = newHV();
10009             HE *restrict he_row, *restrict he_col, *restrict out_inner_he;
10010 14           retval_sv = sv_2mortal(newRV_noinc((SV *)out_hv));
10011 14           hv_iterinit(in_hv);
10012 35 100         while ((he_row = hv_iternext(in_hv))) {
10013 23           SV *restrict row_key_sv = hv_iterkeysv(he_row);
10014 23           SV *restrict row_val = hv_iterval(in_hv, he_row);
10015             HV *restrict in_inner_hv;
10016 23 50         SvGETMAGIC(row_val);
    0          
10017              
10018 23 100         if (!SvROK(row_val) || SvTYPE(SvRV(row_val)) != SVt_PVHV)
    100          
10019 2           croak("Stats::LikeR::transpose: Hash mode – inner element is not a hash ref");
10020 21           in_inner_hv = (HV *)SvRV(row_val);
10021 21           hv_iterinit(in_inner_hv);
10022 54 100         while ((he_col = hv_iternext(in_inner_hv))) {
10023 33           SV *restrict col_key_sv = hv_iterkeysv(he_col);
10024 33           SV *restrict val = hv_iterval(in_inner_hv, he_col);
10025             HV *restrict out_inner_hv;
10026             SV *restrict inner_ref;
10027 33 50         SvGETMAGIC(val);
    0          
10028 33           out_inner_he = hv_fetch_ent(out_hv, col_key_sv, 0, 0);
10029 33 100         if (out_inner_he) {
10030 14           inner_ref = HeVAL(out_inner_he);
10031 14 50         if (!SvROK(inner_ref) || SvTYPE(SvRV(inner_ref)) != SVt_PVHV)
    50          
10032 0           croak("Stats::LikeR::transpose: Internal error – output structure corrupted");
10033 14           out_inner_hv = (HV *)SvRV(inner_ref);
10034             } else {
10035 19           out_inner_hv = newHV();
10036 19           inner_ref = newRV_noinc((SV *)out_inner_hv);
10037 19 50         if (!hv_store_ent(out_hv, col_key_sv, inner_ref, 0)) {
10038 0           SvREFCNT_dec(inner_ref);
10039 0           croak("Stats::LikeR::transpose: Failed to allocate inner hash");
10040             }
10041             }
10042 33           SvREFCNT_inc(val);
10043 33 50         if (!hv_store_ent(out_inner_hv, row_key_sv, val, 0)) {
10044 0           SvREFCNT_dec(val);
10045 0           croak("Stats::LikeR::transpose: Failed to store transposed value");
10046             }
10047             }
10048             }
10049 23 100         } else if (ref_type == SVt_PVAV) { // Array-of-Arrays
10050 22           AV *restrict in_av = (AV *)SvRV(input_ref);
10051 22           AV *restrict out_av = newAV();
10052 22           SSize_t nrows = av_len(in_av) + 1;
10053 22           SSize_t ncols = 0;
10054 22           retval_sv = sv_2mortal(newRV_noinc((SV *)out_av));
10055 22 100         if (nrows > 0) {// Pass 1: validate all rows; fix ncols from row 0
10056             {
10057 21           SV **restrict elem = av_fetch(in_av, 0, 0);
10058 21 100         if (!elem || !*elem)
    50          
10059 1           croak("Stats::LikeR::transpose: Array mode – row 0 is missing");
10060 20 50         SvGETMAGIC(*elem);
    0          
10061 20 100         if (!SvROK(*elem) || SvTYPE(SvRV(*elem)) != SVt_PVAV)
    100          
10062 2           croak("Stats::LikeR::transpose: Array mode – row 0 is not an array ref");
10063 18           ncols = av_len((AV *)SvRV(*elem)) + 1;
10064             }
10065 35 100         for (SSize_t i = 1; i < nrows; i++) {
10066 19           SV **restrict elem = av_fetch(in_av, i, 0);
10067             SSize_t row_ncols;
10068 19 50         if (!elem || !*elem)
    50          
10069 0           croak("Stats::LikeR::transpose: Array mode – row %d is missing", (int)i);
10070 19 50         SvGETMAGIC(*elem);
    0          
10071 19 50         if (!SvROK(*elem) || SvTYPE(SvRV(*elem)) != SVt_PVAV)
    50          
10072 0           croak("Stats::LikeR::transpose: Array mode – row %d is not an array ref", (int)i);
10073 19           row_ncols = av_len((AV *)SvRV(*elem)) + 1;
10074 19 100         if (row_ncols != ncols)
10075 2           croak("Stats::LikeR::transpose: Array mode – ragged array: "
10076             "row 0 has %d cols, row %d has %d",
10077             (int)ncols, (int)i, (int)row_ncols);
10078             }
10079             // Pass 2: output[j][i] = input[i][j]
10080 16 100         if (ncols > 0) {
10081 15           av_extend(out_av, ncols - 1);
10082 47 100         for (SSize_t j = 0; j < ncols; j++) {
10083 32           AV *restrict out_col_av = newAV();
10084 32           SV *restrict col_ref = newRV_noinc((SV *)out_col_av);
10085 32 50         if (!av_store(out_av, j, col_ref)) {
10086 0           SvREFCNT_dec(col_ref);
10087 0           croak("Stats::LikeR::transpose: Array mode – "
10088             "failed to allocate output column %d", (int)j);
10089             }
10090 32           av_extend(out_col_av, nrows - 1);
10091 99 100         for (SSize_t i = 0; i < nrows; i++) {
10092 67           SV **restrict elem = av_fetch(in_av, i, 0);
10093 67 50         if (elem && *elem) {
    50          
10094 67 50         SvGETMAGIC(*elem);
    0          
10095             }
10096 67           AV *restrict in_row_av = (AV *)SvRV(*elem);
10097 67           SV **restrict val_ptr = av_fetch(in_row_av, j, 0);
10098 67 100         SV *restrict val = (val_ptr && *val_ptr) ? *val_ptr : &PL_sv_undef;
    50          
10099 67 50         SvGETMAGIC(val);
    0          
10100 67           SvREFCNT_inc(val);
10101 67 50         if (!av_store(out_col_av, i, val)) {
10102 0           SvREFCNT_dec(val);
10103 0           croak("Stats::LikeR::transpose: Array mode – "
10104             "failed to store [%d][%d]", (int)j, (int)i);
10105             }
10106             }
10107             }
10108             }
10109             }
10110             } else { // Unsupported
10111 1           croak("Stats::LikeR::transpose: Input must be a hash ref or array ref");
10112             }
10113 29           RETVAL = SvREFCNT_inc(retval_sv);
10114             OUTPUT:
10115             RETVAL