From c6380fd7593c9b52e877e62c8beb766f26070839 Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 11:18:02 +0100 Subject: [PATCH 01/30] Fix likelihood correctness: rounding, zero-values, mean/SD moments - Treat mean+SD (Eq 14/15) via a joint bivariate-normal likelihood on sample mean/variance using exact 3rd/4th central moments, replacing the independent-normal-theory approximation. - Treat reported order statistics, frequency-table counts, and double-censoring point observations as rounded values (resolution inferred per dataset) rather than exact continuous observations. - Fix a NaN-gradient/crash bug at delay=0 across all 5 families by special-casing F_D(0)=0 in the CDF functions, and revert the 0.1-day floor workaround this bug required across 16 real datasets. --- ...archical_data_synthesis_summary_stats.stan | 522 ++++++++++++------ 1 file changed, 351 insertions(+), 171 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index ca9fab2..abfff3b 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -57,6 +57,16 @@ functions { // Used in order statistic and interval-censored likelihoods to avoid // probability-scale clipping and catastrophic cancellation. real dist_log_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // F_D(0) = 0 for every family here (support starts at 0), handled as an + // exact special case rather than the general per-family formula below. + // For Burr XII/generalised gamma (and empirically, Weibull's own + // weibull_lcdf), that formula involves u = exp(shape * log(x/scale)); + // differentiating w.r.t. shape gives a factor of log(x/scale), which at + // x=0 is -Inf * 0 = NaN even though the true limit is 0 (a removable + // singularity). Verified this bypass leaves log-likelihood values + // unchanged on non-zero x, while giving finite gradients at x=0 for all + // 5 families. + if (x <= 0) return negative_infinity(); if (dist_type == 1) { // lognormal return lognormal_lcdf(x | loc, phi); } else if (dist_type == 2) { // gamma @@ -77,61 +87,43 @@ functions { return negative_infinity(); } - // Log likelihood for order statistic: - // k-th order statistic out of n observations. - // - // Uses log-scale CDF (_lcdf) and CCDF (_lccdf) directly rather than - // computing the CDF on the probability scale and clipping. Clipping - // (fmax/fmin) is not differentiable at its boundaries, causing zero - // gradients whenever F ~ 0 or F ~ 1 — a common occurrence for tightly - // concentrated distributions such as gamma with large shape. - // - // Safeguard: terms with coefficient 0 are omitted explicitly to avoid - // 0 * (-Inf) = NaN in Stan's autodiff: - // k == 1 (minimum): coefficient of log_F is (k-1) = 0 — term omitted - // k == n (maximum): coefficient of log_1mF is (n-k) = 0 — term omitted - real order_stat_logpdf_fun(real x, int n, int k, int dist_type, real loc, real phi, real kappa) { - real log_f; - real log_F = 0.0; // log CDF = log P(X <= x); default safe (unused when k==1) - real log_1mF = 0.0; // log CCDF = log P(X > x); default safe (unused when k==n) - + // Log-scale CCDF (log survivor function) for each distribution. + real dist_log_ccdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // 1 - F_D(0) = 1 for every family here; see dist_log_cdf_fun for why this + // must be special-cased rather than left to the general formula. + if (x <= 0) return 0; if (dist_type == 1) { // lognormal - log_f = lognormal_lpdf(x | loc, phi); - log_F = lognormal_lcdf(x | loc, phi); - log_1mF = lognormal_lccdf(x | loc, phi); - + return lognormal_lccdf(x | loc, phi); } else if (dist_type == 2) { // gamma real mean_d = exp(loc); real rate = phi / mean_d; - log_f = gamma_lpdf(x | phi, rate); - log_F = gamma_lcdf(x | phi, rate); - log_1mF = gamma_lccdf(x | phi, rate); - + return gamma_lccdf(x | phi, rate); } else if (dist_type == 3) { // weibull real scale = exp(loc); - log_f = weibull_lpdf(x | phi, scale); - log_F = weibull_lcdf(x | phi, scale); - log_1mF = weibull_lccdf(x | phi, scale); - - } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa - real u = log(x) - loc; - real log_term = log1p_exp(phi * u); // log(1 + (x/lambda)^c) - log_f = log(phi) + log(kappa) + (phi - 1) * u - loc - (kappa + 1) * log_term; - log_1mF = -kappa * log_term; // log CCDF = log((1+(x/lam)^c)^(-k)) - log_F = log1m_exp(log_1mF); // log CDF = log(1 - CCDF) - - } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + return weibull_lccdf(x | phi, scale); + } else if (dist_type == 4) { // burr XII: log CCDF = -k * log(1 + (x/lambda)^c) + real u = log(x) - loc; + return -kappa * log1p_exp(phi * u); + } else if (dist_type == 5) { // generalised gamma (Prentice) real gamma_shape = 1.0 / (kappa * kappa); - real w = (log(x) - loc) / phi; - real arg = gamma_shape * exp(kappa * w); // gamma_shape * exp(Q*w) - log_f = log(kappa) - log(phi) - log(x) - + gamma_shape * log(gamma_shape) - + gamma_shape * kappa * w - - arg - - lgamma(gamma_shape); - if (k > 1) log_F = gamma_lcdf(arg | gamma_shape, 1); - if (k < n) log_1mF = gamma_lccdf(arg | gamma_shape, 1); + real w = (log(x) - loc) / phi; + return gamma_lccdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); } + return negative_infinity(); + } + + // Log-density of the k-th order statistic (k out of n observations). + // Fully log-scale: uses _lcdf/_lccdf directly and never exponentiates a + // CDF/CCDF value, so it stays well-conditioned arbitrarily deep in either + // tail. Terms with a zero coefficient are omitted explicitly to avoid + // 0 * (-Inf) = NaN in Stan's autodiff (k==1: coefficient of log_F is 0; + // k==n: coefficient of log_1mF is 0). + real order_stat_logpdf_fun(real x, int n, int k, int dist_type, real loc, real phi, real kappa) { + real log_f = dist_logpdf_fun(x, dist_type, loc, phi, kappa); + real log_F = 0.0; + real log_1mF = 0.0; + if (k > 1) log_F = dist_log_cdf_fun(x, dist_type, loc, phi, kappa); + if (k < n) log_1mF = dist_log_ccdf_fun(x, dist_type, loc, phi, kappa); real log_dens = lchoose(n, k) + log_f; if (k > 1) log_dens += (k - 1) * log_F; @@ -139,6 +131,115 @@ functions { return log_dens; } + // Log-likelihood contribution for a reported order statistic that has been + // rounded to the nearest multiple of `resolution` days (1 = whole day, + // 1/24 = hourly, etc.): log P(v - resolution/2 <= X_(k) < v + resolution/2), + // rather than treating v as an exact continuous observation (which discards + // a material part of the uncertainty for short-incubation pathogens). + // Lower bound is clamped just above 0 since delays are non-negative. + // + // Computed by composite Gauss-Legendre quadrature (24 panels x 7-point + // rule = 168 nodes) directly on order_stat_logpdf_fun, entirely in log + // space via log_sum_exp. + // + // This deliberately avoids computing the order-statistic CDF via Stan's + // beta_lcdf(F_D(x) | k, n-k+1): that looks like the natural closed form + // (F_{X(k)}(x) = I_{F_D(x)}(k, n-k+1), the regularized incomplete beta), + // but Stan's beta_lcdf evaluates the incomplete beta on the linear + // probability scale first and only takes its log afterwards, so it + // silently returns -Inf whenever the true value is below ~1e-308, which + // happens routinely for large n even when F_D(x) itself is an entirely + // ordinary, well-represented number (e.g. n=1000, k=500, F_D=0.01 has an + // exact log-CDF of -1618, but beta_lcdf(0.01 | 500, 501) returns -Inf). + // A single-panel Gauss-Legendre rule over the full box has the opposite + // failure mode at large n: the order statistic's own sampling distribution + // can be far narrower than the box (SE ~ 1/sqrt(n)), so a low-order + // polynomial rule cannot resolve it and does not reliably converge with + // more points at a single panel. Composite (multi-panel) quadrature + // resolves both problems: validated in R against a high-precision adaptive + // reference for n = 15 to 50,000 at resolution = 1 (the widest, hence + // hardest to resolve, box this function is used with), both near the mode + // and deep in the tail (the exact regime that broke beta_lcdf); error is + // below 1e-9 near the mode (where posterior mass concentrates) even at + // n=50,000, and the residual error deep in an implausible-parameter tail + // region is at most ~0.02 log-units, immaterial next to a log-density of + // that magnitude (around -450 in the case tested). A narrower box (finer + // resolution) is strictly easier to resolve, since the accuracy problem is + // driven by the box being wide relative to the order statistic's SE. + real order_stat_rounded_loglik_fun(real v, int n, int k, int dist_type, real loc, real phi, real kappa, real resolution) { + int n_panels = 24; + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real half_res = resolution / 2; + real v_lo = fmax(v - half_res, 1e-6); + real v_hi = v + half_res; + real panel_width = (v_hi - v_lo) / n_panels; + array[n_panels * 7] real log_terms; + int idx = 1; + for (p in 1:n_panels) { + real a = v_lo + (p - 1) * panel_width; + real mid = a + 0.5 * panel_width; + real half = 0.5 * panel_width; + for (j in 1:7) { + real x = mid + half * t[j]; + log_terms[idx] = log(w[j]) + log(half) + + order_stat_logpdf_fun(x, n, k, dist_type, loc, phi, kappa); + idx += 1; + } + } + return log_sum_exp(log_terms); + } + + // Log-likelihood contribution for a raw frequency-table count that has + // been rounded to the nearest multiple of `resolution` days: log P(v - + // resolution/2 <= X < v + resolution/2), rather than treating v as an + // exact continuous observation (summary_type 4's freq_value, and + // summary_type 5's degenerate freq_lower==freq_upper point entries). + // This is the same rounding treatment already applied to reported order + // statistics (see order_stat_rounded_loglik_fun), for consistency across + // every summary type where a single reported value stands in for an + // underlying continuous, day-rounded observation. + // + // No explicit clamp is needed on the lower bound, even when it goes + // negative (v < resolution/2): unlike the order statistic case, this uses + // a CDF *difference*, never the point density, so dist_log_cdf_fun's own + // x<=0 special case (identical for any x<=0, negative or not) already + // gives the correct result directly. + real rounded_freq_loglik_fun(real v, int dist_type, real loc, real phi, real kappa, real resolution) { + real half_res = resolution / 2; + return log_diff_exp( + dist_log_cdf_fun(v + half_res, dist_type, loc, phi, kappa), + dist_log_cdf_fun(v - half_res, dist_type, loc, phi, kappa) + ); + } + + // Log-density of a bivariate normal with mean (mx, my), variances (vx, vy) + // and covariance cxy. Used for the joint mean/SD likelihood (summary_type + // 3), which needs a nonzero covariance term for every right-skewed family + // used here. + // + // Guards against a non-positive-definite or non-finite covariance (which + // can arise from floating-point cancellation, or from the 3rd/4th central + // moments overflowing at extreme parameter draws explored during warmup) + // by treating it as a rejected region of parameter space (-Inf) rather + // than propagating a NaN into target. + real bvn_log_dens(real x, real y, real mx, real my, real vx, real vy, real cxy) { + real det = vx * vy - cxy * cxy; + if (!(vx > 0) || !(vy > 0) || !(det > 0) || !(det < positive_infinity())) { + return negative_infinity(); + } + real dx = x - mx; + real dy = y - my; + real quad = (dx * dx * vy - 2 * dx * dy * cxy + dy * dy * vx) / det; + return -log(2 * pi()) - 0.5 * log(det) - 0.5 * quad; + } + // Helper function to compute gamma quantile approximation real gamma_quantile_approx(real p, real shape, real scale) { // Wilson-Hilferty approximation for gamma quantiles @@ -150,7 +251,7 @@ functions { } } - // Log of integral_{ex_l}^{ex_r} F_D(T - e) de — the truncation denominator + // Log of integral_{ex_l}^{ex_r} F_D(T - e) de: the truncation denominator // for type 7 (right-truncated, doubly censored). Uses 7-point GL quadrature. // Degenerates to log F_D(T - ex_l) when ex_l == ex_r (point exposure). real trunc_denom_log(real ex_l, real ex_r, real T, @@ -177,7 +278,7 @@ functions { return log_sum_exp(log_terms); } - // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de — right-censored contribution + // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de: right-censored contribution // for type 7 (onset not yet observed by T). Uses 7-point GL quadrature. real right_censor_log_lik(real ex_l, real ex_r, real T, int dist_type, real loc, real phi, real kappa) { @@ -213,15 +314,20 @@ functions { // and is dropped, consistent with how type 5 drops 1/(ex_r - ex_l). // // Four cases: - // Both endpoints point-observed -> log f_D(ev_l - ex_l) + // Both endpoints point-observed -> rounded to `resolution`, like summary_type 4/5 // Point exposure, interval event -> log[F(ev_r - ex_l) - F(ev_l - ex_l)] // Interval exposure, point event (= type 5) -> log[F(ev_l - ex_l) - F(ev_l - ex_r)] // Both interval-censored (general) -> 7-point Gauss-Legendre quadrature real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, - int dist_type, real loc, real phi, real kappa) { - // Case 1: both endpoints point-observed + int dist_type, real loc, real phi, real kappa, real resolution) { + // Case 1: both endpoints point-observed. The implied delay ev_l - ex_l is + // itself a rounded reported value (like summary_type 4/5's degenerate + // case), not an exact continuous observation, and is treated the same + // way via rounded_freq_loglik_fun rather than the raw point density + // dist_logpdf_fun (which is singular/undefined at a delay of exactly 0 + // for several families). if (ex_l == ex_r && ev_l == ev_r) { - return dist_logpdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa); + return rounded_freq_loglik_fun(ev_l - ex_l, dist_type, loc, phi, kappa, resolution); } // Case 2: point exposure, interval event if (ex_l == ex_r) { @@ -230,14 +336,14 @@ functions { dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa) ); } - // Case 3: interval exposure, point event — reduces to type 5 + // Case 3: interval exposure, point event (reduces to type 5) if (ev_l == ev_r) { return log_diff_exp( dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa), dist_log_cdf_fun(ev_l - ex_r, dist_type, loc, phi, kappa) ); } - // Case 4: both interval-censored — 7-point Gauss-Legendre quadrature on [ex_l, ex_r]. + // Case 4: both interval-censored (7-point Gauss-Legendre quadrature on [ex_l, ex_r]). // Nodes and weights on [-1, 1] (Abramowitz & Stegun table 25.4). // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. array[7] real t = {-0.9491079123427585, -0.7415311855993945, @@ -273,18 +379,27 @@ data { array[n_datasets] real obs_stat2; // min, q25, or sd array[n_datasets] real obs_stat3; // max, q75, or placeholder + // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see + // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported + // order statistics), summary_type 4/5 (raw/degenerate frequency-table + // counts), and summary_type 6/7's own degenerate (both-endpoints-point- + // observed) case in dc_log_lik, all treated as rounded point values. + // Ignored for summary_type 3 (populate with 1, unused). + array[n_datasets] real resolution; + // --- Frequency table data for summary_type == 4 --- // All datasets' frequency tables are stored in flat arrays. // For dataset d, its entries occupy indices freq_start[d] .. freq_start[d] + freq_len[d] - 1. int n_freq_total; // Total number of (value, count) pairs across all type-4 datasets - array[n_freq_total] real freq_value; // Observed day values for type 4 (must be > 0 for continuous distributions) + array[n_freq_total] real freq_value; // Observed day values for type 4, rounded to `resolution`; 0 allowed array[n_freq_total] int freq_count; // Number of individuals with that day value (types 4 and 5) array[n_datasets] int freq_start; // 1-based start index into freq arrays for dataset d array[n_datasets] int freq_len; // Number of distinct values for dataset d (0 if not type 4 or 5) // Interval bounds for summary_type == 5 (interval-censored frequency table). // For type 4 datasets these arrays are ignored (populate with zeros). - // When freq_lower[i] == freq_upper[i] the contribution falls back to the log-PDF. + // When freq_lower[i] == freq_upper[i] (no reported range), the value is + // treated as a rounded point observation, like summary_type 4. array[n_freq_total] real freq_lower; // lower bound of censoring interval array[n_freq_total] real freq_upper; // upper bound of censoring interval @@ -332,22 +447,43 @@ transformed data { if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { reject("For summary_type=1, must have min <= median <= max"); } + if (resolution[d] <= 0) { + reject("For summary_type=1, resolution must be > 0"); + } } else if (summary_type[d] == 2) { if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { reject("For summary_type=2, must have q25 <= median <= q75"); } + if (resolution[d] <= 0) { + reject("For summary_type=2, resolution must be > 0"); + } + } else if (summary_type[d] == 3) { + // A sample SD is undefined for a single observation; the mean/SD + // likelihood also divides by (n-1), which is degenerate at n=1. + if (n_obs[d] < 2) { + reject("For summary_type=3, n_obs must be >= 2 (a sample SD requires at least 2 observations)"); + } } else if (summary_type[d] == 4) { if (freq_len[d] == 0) { reject("For summary_type=4, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=4, resolution must be > 0"); + } } else if (summary_type[d] == 5) { if (freq_len[d] == 0) { reject("For summary_type=5, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=5, resolution must be > 0"); + } } else if (summary_type[d] == 6) { if (freq_len[d] == 0) { reject("For summary_type=6, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=6, resolution must be > 0"); + } } else if (summary_type[d] == 7) { if (freq_len[d] == 0) { reject("For summary_type=7, freq_len must be > 0"); @@ -355,6 +491,9 @@ transformed data { if (truncation_time[d] <= 0) { reject("For summary_type=7, truncation_time must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=7, resolution must be > 0"); + } } } } @@ -386,122 +525,143 @@ model { real loc = loc_d[d]; int n = n_obs[d]; - if (summary_type[d] == 1) { // median + range (min, max) + if (summary_type[d] == 1) { // median + range (min, max), rounded to `resolution[d]` int k_median = (n + 1) %/% 2; - target += order_stat_logpdf_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa); - target += order_stat_logpdf_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa); - target += order_stat_logpdf_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa); + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); } - else if (summary_type[d] == 2) { // median + IQR (q25, q75) + else if (summary_type[d] == 2) { // median + IQR (q25, q75), rounded to `resolution[d]` int k_median = (n + 1) %/% 2; - target += order_stat_logpdf_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa); + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); int k_q25 = (n + 1) %/% 4; if (k_q25 < 1) k_q25 = 1; - target += order_stat_logpdf_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa); + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); int k_q75 = (3 * (n + 1)) %/% 4; if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - target += order_stat_logpdf_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa); + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); } else if (summary_type[d] == 3) { // mean + sd - real expected_mean; - real expected_sd; - real se_mean; - real se_sd; + // Joint likelihood for (sample mean, sample variance), using the + // exact finite-sample moments of these two statistics rather than + // the univariate normal-theory Var(SD) and independence assumption + // (correct only for Gaussian data). For the unbiased sample variance + // S^2 (divisor n-1): + // Var(mean) = sigma^2 / n [exact] + // Cov(mean,S^2) = mu3 / n [exact] + // Var(S^2) = (mu4 - ((n-3)/(n-1)) * sigma^4) / n [exact] + // The likelihood is built for (mean, S^2) rather than (mean, SD) + // because these two identities hold exactly for any n, whereas + // transforming to SD via the delta method (S = sqrt(S^2)) adds an + // extra approximation that a Monte Carlo check showed is inaccurate + // at realistic sample sizes for skewed families. The S^2 -> SD + // Jacobian depends only on the observed data, not on the model + // parameters, so it is dropped without affecting inference. + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; if (dist_type == 1) { // lognormal - expected_mean = exp(loc + phi^2 / 2); - real var_ = (exp(phi^2) - 1) * exp(2 * loc + phi^2); - expected_sd = sqrt(var_); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; } else if (dist_type == 2) { // gamma - real mean_d = exp(loc); real shape = phi; - real scale_param = mean_d / shape; - expected_mean = mean_d; - expected_sd = sqrt(shape * scale_param^2); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; } else if (dist_type == 3) { // weibull - real scale = exp(loc); real shape = phi; - expected_mean = scale * tgamma(1 + 1.0 / shape); - real var_ = scale^2 * (tgamma(1 + 2.0 / shape) - pow(tgamma(1 + 1.0 / shape), 2)); - expected_sd = sqrt(var_); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa - // E[X^r] = lambda^r * k * B(k - r/c, 1 + r/c), requires k*c > r - // Mean requires kappa*phi > 1; variance requires kappa*phi > 2. - // Hard barrier: reject this region of parameter space. - if (kappa * phi <= 2.0) { + // E[X^r] = lambda^r * k * B(k - r/c, 1 + r/c), requires k*c > r. + // The 4th moment (needed for Var(S^2)) requires k*c > 4, stricter + // than the k*c > 2 needed for the variance alone. Hard barrier: + // reject this region of parameter space for datasets that report + // a mean and SD. + if (kappa * phi <= 4.0) { + moments_ok = 0; target += negative_infinity(); } else { real lam = exp(loc); - expected_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); - real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); - expected_sd = sqrt(fabs(e2 - expected_mean^2)); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa - // E[T^r] = exp(r*loc) * kappa^(2*r*phi/kappa) - // * Gamma(gamma_shape + r*phi/kappa) / Gamma(gamma_shape) - // where gamma_shape = 1/kappa^2 + // log E[X^r] = r*loc + (2*r*phi/kappa)*log(kappa) + // + lgamma(gamma_shape + r*phi/kappa) - lgamma(gamma_shape) + // where gamma_shape = 1/kappa^2. Always finite (no kc-style threshold). real gamma_shape = 1.0 / (kappa * kappa); - real log_ET = loc + 2.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape); - real log_ET2 = 2.0*loc + 4.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape); - expected_mean = exp(log_ET); - expected_sd = sqrt(fabs(exp(log_ET2) - expected_mean^2)); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } - // For dist_type 1-3 the likelihood is added below (after the if-else chain). - // For dist_type 4-5 it is added inside their own branches above. - if (dist_type <= 3) { - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + target += bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); } } else if (summary_type[d] == 4) { // raw frequency table - // Direct likelihood: for each distinct observed value, add count * log_pdf(value). - // This is equivalent to fitting the distribution directly to all individual observations, - // but using the compressed frequency-table representation. + // Each distinct observed value is treated as rounded to the nearest + // multiple of `resolution` days, exactly like a reported order + // statistic (see rounded_freq_loglik_fun), not as an exact continuous + // observation. int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { - target += freq_count[i] * dist_logpdf_fun(freq_value[i], dist_type, loc, phi, kappa); + target += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); } } else if (summary_type[d] == 5) { // interval-censored frequency table // Likelihood: count * log[ F(upper) - F(lower) ] for each interval. - // Uses log_diff_exp(log_F_upper, log_F_lower) for numerical stability — + // Uses log_diff_exp(log_F_upper, log_F_lower) for numerical stability: // avoids catastrophic cancellation when the two CDF values are close. - // When lower == upper (point observation), falls back to count * log_pdf - // since log_diff_exp(a, a) = -Inf. + // When lower == upper (point observation, no reported range), it is + // rounded like summary_type 4 rather than falling back to a point + // log-pdf. int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { if (freq_lower[i] == freq_upper[i]) { - target += freq_count[i] * dist_logpdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + target += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); } else { real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); @@ -521,7 +681,7 @@ model { target += freq_count[i] * dc_log_lik( freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa + dist_type, loc, phi, kappa, resolution[d] ); } } @@ -542,7 +702,7 @@ model { target += freq_count[i] * ( dc_log_lik(freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa) + dist_type, loc, phi, kappa, resolution[d]) - trunc_denom_log(freq_lower[i], freq_upper[i], T, dist_type, loc, phi, kappa) ); @@ -760,9 +920,9 @@ generated quantities { if (summary_type[d] == 1) { // median + range int k_median = (n + 1) %/% 2; - log_lik[idx] = order_stat_logpdf_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa); - log_lik[idx + 1] = order_stat_logpdf_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa); - log_lik[idx + 2] = order_stat_logpdf_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa); + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); } else if (summary_type[d] == 2) { // median + IQR int k_median = (n + 1) %/% 2; @@ -772,60 +932,80 @@ generated quantities { if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - log_lik[idx] = order_stat_logpdf_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa); - log_lik[idx + 1] = order_stat_logpdf_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa); - log_lik[idx + 2] = order_stat_logpdf_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa); + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); - } else if (summary_type[d] == 3) { // mean + sd - real expected_mean; - real expected_sd; + } else if (summary_type[d] == 3) { // mean + sd (see model block for derivation) + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; if (dist_type == 1) { - expected_mean = exp(loc + phi^2 / 2); - real var_ = (exp(phi^2) - 1) * exp(2 * loc + phi^2); - expected_sd = sqrt(var_); + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + } else if (dist_type == 2) { - real mean_d = exp(loc); real shape = phi; - real scale_param = mean_d / shape; - expected_mean = mean_d; - expected_sd = sqrt(mean_d * scale_param); + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + } else if (dist_type == 3) { - real scale = exp(loc); real shape = phi; - expected_mean = scale * tgamma(1 + 1.0 / shape); - real var_ = scale^2 * (tgamma(1 + 2.0 / shape) - pow(tgamma(1 + 1.0 / shape), 2)); - expected_sd = sqrt(var_); + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + } else if (dist_type == 4) { - // Moments require kappa*phi > 2; model block already rejects that region, - // so this fallback (negative_infinity) should never be reached in practice. - if (kappa * phi > 2.0) { - real lam = exp(loc); - expected_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); - real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); - expected_sd = sqrt(fabs(e2 - expected_mean^2)); + if (kappa * phi <= 4.0) { + moments_ok = 0; } else { - log_lik[idx] = negative_infinity(); - log_lik[idx + 1] = negative_infinity(); - log_lik[idx + 2] = 0; + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } + } else if (dist_type == 5) { real gamma_shape = 1.0 / (kappa * kappa); - real log_ET = loc + 2.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape); - real log_ET2 = 2.0*loc + 4.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape); - expected_mean = exp(log_ET); - expected_sd = sqrt(fabs(exp(log_ET2) - expected_mean^2)); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } - // For dist_type 4 when moments don't exist the log_lik slots were - // already assigned above; skip the normal_lpdf for that case. - if (dist_type != 4 || kappa * phi > 2.0) { - log_lik[idx] = normal_lpdf(obs_stat1[d] | expected_mean, expected_sd / sqrt(n)); - log_lik[idx + 1] = normal_lpdf(obs_stat2[d] | expected_sd, expected_sd / sqrt(2 * (n - 1))); - log_lik[idx + 2] = 0; // placeholder + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + log_lik[idx] = bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } else { + log_lik[idx] = negative_infinity(); } + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused } else if (summary_type[d] == 4) { // raw frequency table // Sum log-likelihoods over all individuals, using the frequency table. @@ -834,7 +1014,7 @@ generated quantities { int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { - ll_type4 += freq_count[i] * dist_logpdf_fun(freq_value[i], dist_type, loc, phi, kappa); + ll_type4 += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); } log_lik[idx] = ll_type4; log_lik[idx + 1] = 0; // unused @@ -846,7 +1026,7 @@ generated quantities { int len = freq_len[d]; for (i in s:(s + len - 1)) { if (freq_lower[i] == freq_upper[i]) { - ll_type5 += freq_count[i] * dist_logpdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + ll_type5 += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); } else { real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); @@ -865,7 +1045,7 @@ generated quantities { ll_type6 += freq_count[i] * dc_log_lik( freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa + dist_type, loc, phi, kappa, resolution[d] ); } log_lik[idx] = ll_type6; @@ -882,7 +1062,7 @@ generated quantities { ll_type7 += freq_count[i] * ( dc_log_lik(freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa) + dist_type, loc, phi, kappa, resolution[d]) - trunc_denom_log(freq_lower[i], freq_upper[i], T, dist_type, loc, phi, kappa) ); From 36425883ff452a304e4685f51e00210aafa6ea0e Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 11:18:32 +0100 Subject: [PATCH 02/30] Fix likelihood correctness: rounding, zero-values, mean/SD moments - Treat mean+SD (Eq 14/15) via a joint bivariate-normal likelihood on sample mean/variance using exact 3rd/4th central moments, replacing the independent-normal-theory approximation. - Treat reported order statistics, frequency-table counts, and double-censoring point observations as rounded values (resolution inferred per dataset) rather than exact continuous observations. - Fix a NaN-gradient/crash bug at delay=0 across all 5 families by special-casing F_D(0)=0 in the CDF functions, and revert the 0.1-day floor workaround this bug required across 16 real datasets. --- ...al_data_synthesis_summary_stats_joint.stan | 453 ++++++++++++------ 1 file changed, 294 insertions(+), 159 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan index 1b64ee5..52837ac 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan @@ -72,6 +72,16 @@ functions { // Log-scale CDF for each distribution. real dist_log_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // F_D(0) = 0 for every family here (support starts at 0), handled as an + // exact special case rather than the general per-family formula below. + // For Burr XII/generalised gamma (and empirically, Weibull's own + // weibull_lcdf), that formula involves u = exp(shape * log(x/scale)); + // differentiating w.r.t. shape gives a factor of log(x/scale), which at + // x=0 is -Inf * 0 = NaN even though the true limit is 0 (a removable + // singularity). Verified this bypass leaves log-likelihood values + // unchanged on non-zero x, while giving finite gradients at x=0 for all + // 5 families. + if (x <= 0) return negative_infinity(); if (dist_type == 1) { // lognormal return lognormal_lcdf(x | loc, phi); } else if (dist_type == 2) { // gamma @@ -94,6 +104,9 @@ functions { // Log-scale CCDF (log survivor function) for each distribution. real dist_log_ccdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // 1 - F_D(0) = 1 for every family here; see dist_log_cdf_fun for why this + // must be special-cased rather than left to the general formula. + if (x <= 0) return 0; if (dist_type == 1) { // lognormal return lognormal_lccdf(x | loc, phi); } else if (dist_type == 2) { // gamma @@ -114,57 +127,6 @@ functions { return negative_infinity(); } - // Log likelihood for order statistic: - // k-th order statistic out of n observations. - real order_stat_logpdf_fun(real x, int n, int k, int dist_type, real loc, real phi, real kappa) { - real log_f; - real log_F = 0.0; - real log_1mF = 0.0; - - if (dist_type == 1) { // lognormal - log_f = lognormal_lpdf(x | loc, phi); - log_F = lognormal_lcdf(x | loc, phi); - log_1mF = lognormal_lccdf(x | loc, phi); - - } else if (dist_type == 2) { // gamma - real mean_d = exp(loc); - real rate = phi / mean_d; - log_f = gamma_lpdf(x | phi, rate); - log_F = gamma_lcdf(x | phi, rate); - log_1mF = gamma_lccdf(x | phi, rate); - - } else if (dist_type == 3) { // weibull - real scale = exp(loc); - log_f = weibull_lpdf(x | phi, scale); - log_F = weibull_lcdf(x | phi, scale); - log_1mF = weibull_lccdf(x | phi, scale); - - } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa - real u = log(x) - loc; - real log_term = log1p_exp(phi * u); - log_f = log(phi) + log(kappa) + (phi - 1) * u - loc - (kappa + 1) * log_term; - log_1mF = -kappa * log_term; - log_F = log1m_exp(log_1mF); - - } else if (dist_type == 5) { // generalised gamma (Prentice) - real gamma_shape = 1.0 / (kappa * kappa); - real w = (log(x) - loc) / phi; - real arg = gamma_shape * exp(kappa * w); - log_f = log(kappa) - log(phi) - log(x) - + gamma_shape * log(gamma_shape) - + gamma_shape * kappa * w - - arg - - lgamma(gamma_shape); - if (k > 1) log_F = gamma_lcdf(arg | gamma_shape, 1); - if (k < n) log_1mF = gamma_lccdf(arg | gamma_shape, 1); - } - - real log_dens = lchoose(n, k) + log_f; - if (k > 1) log_dens += (k - 1) * log_F; - if (k < n) log_dens += (n - k) * log_1mF; - return log_dens; - } - // Joint log density of three order statistics x1 < x2 < x3 with ranks // i1 < i2 < i3 from a sample of size n. // @@ -212,6 +174,102 @@ functions { return lp; } + // Rounded log-likelihood for the joint density of 3 order statistics: + // integrates joint_3_order_stat_logpdf over a box of width `resolution` + // around each reported (rounded) value, via 5-point-per-dimension tensor + // Gauss-Legendre quadrature (125 nodes). Validated in R against a nested + // adaptive-quadrature reference (Burr XII, n=15, resolution=1): relative + // error ~5e-8, versus ~1e-4 at 3 points/dimension: 5 points gives a + // comfortable safety margin at a still-modest node count. Lower bounds are + // clamped just above 0 since delays are non-negative (only relevant for + // the smallest of the three statistics, e.g. the reported min). + // + // Loses accuracy (~9% error in a case checked in the code review) when two + // of the three reported statistics are within `resolution` of each other, + // since joint_3_order_stat_logpdf's ordering constraint (x1 0) || !(vy > 0) || !(det > 0) || !(det < positive_infinity())) { + return negative_infinity(); + } + real dx = x - mx; + real dy = y - my; + real quad = (dx * dx * vy - 2 * dx * dy * cxy + dy * dy * vx) / det; + return -log(2 * pi()) - 0.5 * log(det) - 0.5 * quad; + } + // Helper function to compute gamma quantile approximation real gamma_quantile_approx(real p, real shape, real scale) { real z = inv_Phi(p); @@ -222,7 +280,7 @@ functions { } } - // Log of integral_{ex_l}^{ex_r} F_D(T - e) de — truncation denominator + // Log of integral_{ex_l}^{ex_r} F_D(T - e) de: truncation denominator // for type 7 (right-truncated, doubly censored). Uses 7-point GL quadrature. // Degenerates to log F_D(T - ex_l) when ex_l == ex_r (point exposure). real trunc_denom_log(real ex_l, real ex_r, real T, @@ -249,7 +307,7 @@ functions { return log_sum_exp(log_terms); } - // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de — right-censored contribution + // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de: right-censored contribution // for type 7 (onset not yet observed by T). Uses 7-point GL quadrature. real right_censor_log_lik(real ex_l, real ex_r, real T, int dist_type, real loc, real phi, real kappa) { @@ -278,9 +336,14 @@ functions { // Double-censored log-likelihood for one observation (summary type 6). // Identical to the version in hierarchical_data_synthesis_summary_stats.stan. real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, - int dist_type, real loc, real phi, real kappa) { + int dist_type, real loc, real phi, real kappa, real resolution) { + // Both endpoints point-observed: the implied delay ev_l - ex_l is itself + // a rounded reported value, not an exact continuous observation, and is + // treated the same way via rounded_freq_loglik_fun as summary_type 4/5's + // degenerate case, rather than the raw point density dist_logpdf_fun + // (singular/undefined at a delay of exactly 0 for several families). if (ex_l == ex_r && ev_l == ev_r) { - return dist_logpdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa); + return rounded_freq_loglik_fun(ev_l - ex_l, dist_type, loc, phi, kappa, resolution); } if (ex_l == ex_r) { return log_diff_exp( @@ -326,6 +389,14 @@ data { array[n_datasets] real obs_stat2; array[n_datasets] real obs_stat3; + // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see + // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported + // order statistics), summary_type 4/5 (raw/degenerate frequency-table + // counts), and summary_type 6/7's own degenerate (both-endpoints-point- + // observed) case in dc_log_lik, all treated as rounded point values. + // Ignored for summary_type 3 (populate with 1, unused). + array[n_datasets] real resolution; + int n_freq_total; array[n_freq_total] real freq_value; array[n_freq_total] int freq_count; @@ -366,27 +437,54 @@ transformed data { real z_q90 = 1.28155; real z_q95 = 1.64485; + // Non-strict (<=), matching the factorised model: day-rounding a + // short-incubation dataset routinely produces exact ties between + // reported statistics (e.g. Q1 == median), which a strict check would + // reject and abort the entire fit on. joint_3_order_stat_rounded_loglik + // still loses accuracy near (but not at) a tie; see its docstring and + // REVISION_TODO.md. for (d in 1:n_datasets) { if (summary_type[d] == 1) { - if (obs_stat2[d] >= obs_stat1[d] || obs_stat1[d] >= obs_stat3[d]) { - reject("For summary_type=1, must have min < median < max"); + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=1, must have min <= median <= max"); + } + if (resolution[d] <= 0) { + reject("For summary_type=1, resolution must be > 0"); } } else if (summary_type[d] == 2) { - if (obs_stat2[d] >= obs_stat1[d] || obs_stat1[d] >= obs_stat3[d]) { - reject("For summary_type=2, must have q25 < median < q75"); + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=2, must have q25 <= median <= q75"); + } + if (resolution[d] <= 0) { + reject("For summary_type=2, resolution must be > 0"); + } + } else if (summary_type[d] == 3) { + // A sample SD is undefined for a single observation; the mean/SD + // likelihood also divides by (n-1), which is degenerate at n=1. + if (n_obs[d] < 2) { + reject("For summary_type=3, n_obs must be >= 2 (a sample SD requires at least 2 observations)"); } } else if (summary_type[d] == 4) { if (freq_len[d] == 0) { reject("For summary_type=4, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=4, resolution must be > 0"); + } } else if (summary_type[d] == 5) { if (freq_len[d] == 0) { reject("For summary_type=5, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=5, resolution must be > 0"); + } } else if (summary_type[d] == 6) { if (freq_len[d] == 0) { reject("For summary_type=6, freq_len must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=6, resolution must be > 0"); + } } else if (summary_type[d] == 7) { if (freq_len[d] == 0) { reject("For summary_type=7, freq_len must be > 0"); @@ -394,6 +492,9 @@ transformed data { if (truncation_time[d] <= 0) { reject("For summary_type=7, truncation_time must be > 0"); } + if (resolution[d] <= 0) { + reject("For summary_type=7, resolution must be > 0"); + } } } } @@ -425,106 +526,116 @@ model { real loc = loc_d[d]; int n = n_obs[d]; - if (summary_type[d] == 1) { // median + range: joint density of (min, median, max) + if (summary_type[d] == 1) { // median + range: joint density of (min, median, max), rounded int k_median = (n + 1) %/% 2; - target += joint_3_order_stat_logpdf( + target += joint_3_order_stat_rounded_loglik( obs_stat2[d], obs_stat1[d], obs_stat3[d], // x1=min, x2=median, x3=max 1, k_median, n, // i1=1, i2=k_median, i3=n - n, dist_type, loc, phi, kappa); + n, dist_type, loc, phi, kappa, resolution[d]); } - else if (summary_type[d] == 2) { // median + IQR: joint density of (q25, median, q75) + else if (summary_type[d] == 2) { // median + IQR: joint density of (q25, median, q75), rounded int k_median = (n + 1) %/% 2; int k_q25 = (n + 1) %/% 4; if (k_q25 < 1) k_q25 = 1; int k_q75 = (3 * (n + 1)) %/% 4; if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - target += joint_3_order_stat_logpdf( + target += joint_3_order_stat_rounded_loglik( obs_stat2[d], obs_stat1[d], obs_stat3[d], // x1=q25, x2=median, x3=q75 k_q25, k_median, k_q75, - n, dist_type, loc, phi, kappa); + n, dist_type, loc, phi, kappa, resolution[d]); } - else if (summary_type[d] == 3) { // mean + sd (unchanged from factorised model) - real expected_mean; - real expected_sd; - real se_mean; - real se_sd; + else if (summary_type[d] == 3) { // mean + sd (identical to factorised model, see there for derivation) + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; if (dist_type == 1) { // lognormal - expected_mean = exp(loc + phi^2 / 2); - real var_ = (exp(phi^2) - 1) * exp(2 * loc + phi^2); - expected_sd = sqrt(var_); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; } else if (dist_type == 2) { // gamma - real mean_d = exp(loc); real shape = phi; - real scale_param = mean_d / shape; - expected_mean = mean_d; - expected_sd = sqrt(shape * scale_param^2); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; } else if (dist_type == 3) { // weibull - real scale = exp(loc); real shape = phi; - expected_mean = scale * tgamma(1 + 1.0 / shape); - real var_ = scale^2 * (tgamma(1 + 2.0 / shape) - pow(tgamma(1 + 1.0 / shape), 2)); - expected_sd = sqrt(var_); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); - - } else if (dist_type == 4) { // burr XII - if (kappa * phi <= 2.0) { + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + // 4th moment (needed for Var(S^2)) requires k*c > 4, stricter than + // the k*c > 2 needed for the variance alone. + if (kappa * phi <= 4.0) { + moments_ok = 0; target += negative_infinity(); } else { real lam = exp(loc); - expected_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); - real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); - expected_sd = sqrt(fabs(e2 - expected_mean^2)); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } - } else if (dist_type == 5) { // generalised gamma + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa real gamma_shape = 1.0 / (kappa * kappa); - real log_ET = loc + 2.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape); - real log_ET2 = 2.0*loc + 4.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape); - expected_mean = exp(log_ET); - expected_sd = sqrt(fabs(exp(log_ET2) - expected_mean^2)); - se_mean = expected_sd / sqrt(n); - se_sd = expected_sd / sqrt(2 * (n - 1)); - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } - if (dist_type <= 3) { - obs_stat1[d] ~ normal(expected_mean, se_mean); - obs_stat2[d] ~ normal(expected_sd, se_sd); + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + target += bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); } } - else if (summary_type[d] == 4) { // raw frequency table (unchanged) + else if (summary_type[d] == 4) { // raw frequency table + // Each distinct observed value is treated as rounded to the nearest + // multiple of `resolution` days, not as an exact continuous observation. int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { - target += freq_count[i] * dist_logpdf_fun(freq_value[i], dist_type, loc, phi, kappa); + target += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); } } - else if (summary_type[d] == 5) { // interval-censored frequency table (unchanged) + else if (summary_type[d] == 5) { // interval-censored frequency table + // When lower == upper (no reported range), the value is treated as a + // rounded point observation, like summary_type 4. int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { if (freq_lower[i] == freq_upper[i]) { - target += freq_count[i] * dist_logpdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + target += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); } else { real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); @@ -540,7 +651,7 @@ model { target += freq_count[i] * dc_log_lik( freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa + dist_type, loc, phi, kappa, resolution[d] ); } } @@ -554,7 +665,7 @@ model { target += freq_count[i] * ( dc_log_lik(freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa) + dist_type, loc, phi, kappa, resolution[d]) - trunc_denom_log(freq_lower[i], freq_upper[i], T, dist_type, loc, phi, kappa) ); @@ -757,82 +868,106 @@ generated quantities { real loc = loc_d[d]; int n = n_obs[d]; - if (summary_type[d] == 1) { // joint density of (min, median, max) + if (summary_type[d] == 1) { // joint density of (min, median, max), rounded int k_median = (n + 1) %/% 2; - log_lik[idx] = joint_3_order_stat_logpdf( + log_lik[idx] = joint_3_order_stat_rounded_loglik( obs_stat2[d], obs_stat1[d], obs_stat3[d], 1, k_median, n, - n, dist_type, loc, phi, kappa); + n, dist_type, loc, phi, kappa, resolution[d]); log_lik[idx + 1] = 0; log_lik[idx + 2] = 0; - } else if (summary_type[d] == 2) { // joint density of (q25, median, q75) + } else if (summary_type[d] == 2) { // joint density of (q25, median, q75), rounded int k_median = (n + 1) %/% 2; int k_q25 = (n + 1) %/% 4; if (k_q25 < 1) k_q25 = 1; int k_q75 = (3 * (n + 1)) %/% 4; if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - log_lik[idx] = joint_3_order_stat_logpdf( + log_lik[idx] = joint_3_order_stat_rounded_loglik( obs_stat2[d], obs_stat1[d], obs_stat3[d], k_q25, k_median, k_q75, - n, dist_type, loc, phi, kappa); + n, dist_type, loc, phi, kappa, resolution[d]); log_lik[idx + 1] = 0; log_lik[idx + 2] = 0; - } else if (summary_type[d] == 3) { // mean + sd (unchanged) - real expected_mean; - real expected_sd; + } else if (summary_type[d] == 3) { // mean + sd (see model block for derivation) + real mean_d; + real var_d; + real mu3; + real mu4; + int moments_ok = 1; if (dist_type == 1) { - expected_mean = exp(loc + phi^2 / 2); - real var_ = (exp(phi^2) - 1) * exp(2 * loc + phi^2); - expected_sd = sqrt(var_); + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + } else if (dist_type == 2) { - real mean_d = exp(loc); real shape = phi; - real scale_param = mean_d / shape; - expected_mean = mean_d; - expected_sd = sqrt(mean_d * scale_param); + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + } else if (dist_type == 3) { - real scale = exp(loc); real shape = phi; - expected_mean = scale * tgamma(1 + 1.0 / shape); - real var_ = scale^2 * (tgamma(1 + 2.0 / shape) - pow(tgamma(1 + 1.0 / shape), 2)); - expected_sd = sqrt(var_); + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + } else if (dist_type == 4) { - if (kappa * phi > 2.0) { - real lam = exp(loc); - expected_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); - real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); - expected_sd = sqrt(fabs(e2 - expected_mean^2)); + if (kappa * phi <= 4.0) { + moments_ok = 0; } else { - log_lik[idx] = negative_infinity(); - log_lik[idx + 1] = negative_infinity(); - log_lik[idx + 2] = 0; + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } + } else if (dist_type == 5) { real gamma_shape = 1.0 / (kappa * kappa); - real log_ET = loc + 2.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape); - real log_ET2 = 2.0*loc + 4.0*phi/kappa * log(kappa) - + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape); - expected_mean = exp(log_ET); - expected_sd = sqrt(fabs(exp(log_ET2) - expected_mean^2)); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; } - if (dist_type != 4 || kappa * phi > 2.0) { - log_lik[idx] = normal_lpdf(obs_stat1[d] | expected_mean, expected_sd / sqrt(n)); - log_lik[idx + 1] = normal_lpdf(obs_stat2[d] | expected_sd, expected_sd / sqrt(2 * (n - 1))); - log_lik[idx + 2] = 0; + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + log_lik[idx] = bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } else { + log_lik[idx] = negative_infinity(); } + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused } else if (summary_type[d] == 4) { // raw frequency table real ll_type4 = 0; int s = freq_start[d]; int len = freq_len[d]; for (i in s:(s + len - 1)) { - ll_type4 += freq_count[i] * dist_logpdf_fun(freq_value[i], dist_type, loc, phi, kappa); + ll_type4 += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); } log_lik[idx] = ll_type4; log_lik[idx + 1] = 0; @@ -844,7 +979,7 @@ generated quantities { int len = freq_len[d]; for (i in s:(s + len - 1)) { if (freq_lower[i] == freq_upper[i]) { - ll_type5 += freq_count[i] * dist_logpdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + ll_type5 += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); } else { real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); @@ -863,7 +998,7 @@ generated quantities { ll_type6 += freq_count[i] * dc_log_lik( freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa + dist_type, loc, phi, kappa, resolution[d] ); } log_lik[idx] = ll_type6; @@ -880,7 +1015,7 @@ generated quantities { ll_type7 += freq_count[i] * ( dc_log_lik(freq_lower[i], freq_upper[i], event_lower[i], event_upper[i], - dist_type, loc, phi, kappa) + dist_type, loc, phi, kappa, resolution[d]) - trunc_denom_log(freq_lower[i], freq_upper[i], T, dist_type, loc, phi, kappa) ); From 4a538db475d875cab9712260a84d59362116a2d1 Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 11:19:11 +0100 Subject: [PATCH 03/30] Add detect_resolution --- R/utils.R | 169 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 162 insertions(+), 7 deletions(-) diff --git a/R/utils.R b/R/utils.R index 5673dbc..433d3b0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -232,6 +232,116 @@ extract_quantiles <- function(cdf_summary, probs = c(0.5, 0.95), cdf_mat = NULL) } +#' Detect the day-fraction reporting resolution of an order-statistic dataset +#' +#' Infers how finely a study's reported order statistics were rounded, so the +#' day-rounded order-statistic likelihood (Reviewer 2, point 1(iii)) can use a +#' window narrower than a full day where the data supports it, rather than +#' assuming every dataset was rounded to the nearest whole day. +#' +#' `exact_vals` (the sample min and max for a median+range dataset) are +#' always true order statistics: an actual individual observation, under any +#' convention, at any sample size. `risky_vals` (the median, and for a +#' median+IQR dataset the reported quartiles) are not: for an even sample +#' size the standard median is the *average* of the two middle order +#' statistics, and quartile conventions vary and routinely interpolate +#' between adjacent order statistics. A day-integer dataset can therefore +#' report a median or quartile with a spurious fractional part (most often an +#' exact half, from averaging two integers) that reflects the interpolation +#' arithmetic, not the study's real measurement precision. Checked against +#' the curated corpus: several real median+range datasets (e.g. n=28, n=8, +#' n=10, n=22) show exactly this pattern, a half-integer median next to +#' integer min/max, for both even and odd n. +#' +#' Because of this, `exact_vals` are checked against the full set of "nice" +#' divisors of a day (whole day, half-day, ..., hourly), coarsest first, +#' since an integer is trivially consistent with every finer grid too (e.g. +#' `5` is a multiple of `1/24` as well as of `1`) and the coarsest match is +#' the meaningful one. `risky_vals` are trusted only for signals that a +#' generic linear interpolation between two integers is unlikely to produce +#' by chance: an hour-based grid (hourly, 2-hourly, 3-hourly) or a decimal +#' precision of two or more places (a simple interpolation weight reproduces +#' at most one non-trivial decimal digit from two integers, e.g. an eighth +#' gives `x.125`, a genuine 3-decimal case, which is why the 2dp threshold is +#' conservative rather than exact). Otherwise `risky_vals` are ignored and +#' the result defaults to a whole day. This means the function will +#' sometimes underestimate a median+IQR dataset's true resolution (there is +#' no min/max to anchor it), but underestimating resolution only means +#' falling back to the wider, already-accepted day window, not repeating the +#' overconfidence problem this exists to fix. +#' +#' @param exact_vals Numeric vector of statistics that are always true order +#' statistics (min and max, for a median+range dataset). `NA`s are +#' dropped. Pass `numeric(0)` if none apply (e.g. a median+IQR dataset). +#' @param risky_vals Numeric vector of statistics that may be interpolated +#' rather than raw order statistics (the median; and, for a median+IQR +#' dataset, the quartiles too). `NA`s are dropped. Default `numeric(0)`. +#' @param tol Numerical tolerance for judging a value to be a multiple of a +#' candidate grid. Default `1e-6`. +#' @return A single number: the detected resolution in days (`1` = whole day, +#' `1/24` = hourly, etc.). Defaults to `1` if both arguments are empty +#' after dropping `NA`s. +#' @export +detect_resolution <- function(exact_vals, risky_vals = numeric(0), tol = 1e-6) { + exact_vals <- exact_vals[!is.na(exact_vals)] + risky_vals <- risky_vals[!is.na(risky_vals)] + + grid_match <- function(vals, denoms) { + for (den in denoms) { + if (all(abs(vals * den - round(vals * den)) < tol)) return(1 / den) + } + NA_real_ + } + decimals_of <- function(x) { + s <- sub("0+$", "", formatC(x, digits = 6, format = "f")) + s <- sub("\\.$", "", s) # a bare trailing "." remains when x is a whole number + if (!grepl(".", s, fixed = TRUE)) return(0L) + nchar(strsplit(s, ".", fixed = TRUE)[[1]][2]) + } + decimal_precision <- function(vals) { + if (length(vals) == 0) return(NA_real_) + max_dec <- min(max(vapply(vals, decimals_of, integer(1))), 3L) + if (max_dec == 0L) NA_real_ else 10^(-max_dec) + } + + nice_denoms <- c(1, 2, 3, 4, 6, 8, 12, 24) + + # Exact order statistics: trust the full grid search, then the general + # decimal-precision fallback (a study reporting min/max to N decimal + # places really did measure to that precision). + if (length(exact_vals) > 0) { + res <- grid_match(exact_vals, nice_denoms) + if (is.na(res)) res <- decimal_precision(exact_vals) + if (!is.na(res)) return(res) + } + + # No exact anchor, or it was all whole days: only accept risky_vals' + # evidence of finer resolution if it is not plausibly a simple + # interpolation artifact (an hour-based grid, or >=2dp decimal precision). + # + # Finding the COARSEST grid risky_vals fit (not just checking membership of + # {8,12,24} directly) matters here: a half-day value like 6.5 is *also* + # trivially a multiple of 1/8, 1/12 and 1/24 (0.5 = 4/8 = 6/12 = 12/24), so + # checking those denominators on their own would wrongly "confirm" an + # hour-based grid for a dataset that is really just half-day. Only the + # coarsest grid that fits is a genuine claim about the resolution. + if (length(risky_vals) > 0) { + coarsest_den <- NA_real_ + for (den in nice_denoms) { + if (all(abs(risky_vals * den - round(risky_vals * den)) < tol)) { coarsest_den <- den; break } + } + hour_res <- if (!is.na(coarsest_den) && coarsest_den %in% c(8, 12, 24)) 1 / coarsest_den else NA_real_ + dec_res <- decimal_precision(risky_vals) + if (!is.na(dec_res) && dec_res > 0.01) dec_res <- NA_real_ # 1dp: too easily a simple-fraction artifact + candidates <- c(hour_res, dec_res) + candidates <- candidates[!is.na(candidates)] + if (length(candidates) > 0) return(min(candidates)) + } + + 1 +} + + #' Prepare Stan data from a list of dataset summaries #' #' Converts a list of dataset descriptors (each providing summary statistics @@ -378,6 +488,9 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1 <- numeric(n_datasets) obs_stat2 <- numeric(n_datasets) obs_stat3 <- numeric(n_datasets) + # Day-fraction rounding resolution for summary_type 1/2 (see + # detect_resolution()); irrelevant for other types, left at the default 1. + resolution_vec <- rep(1, n_datasets) # Frequency table flat arrays (for summary_type == 4, 5, 6, and 7) freq_value_all <- numeric(0) freq_lower_all <- numeric(0) @@ -403,6 +516,9 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1[i] <- d$median obs_stat2[i] <- d$min obs_stat3[i] <- d$max + # min/max are always true order statistics; median may be an + # interpolated average for even n, so it is only a "risky" signal. + resolution_vec[i] <- detect_resolution(c(d$min, d$max), d$median) } else if (!is.null(d$median) && !is.null(d$Q1) && !is.null(d$Q3)) { # Type 2: median + IQR (Q1, Q3) @@ -411,6 +527,9 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1[i] <- d$median obs_stat2[i] <- d$Q1 obs_stat3[i] <- d$Q3 + # No min/max anchor here; median and quartiles can all be interpolated, + # so all three are "risky" (see detect_resolution()). + resolution_vec[i] <- detect_resolution(numeric(0), c(d$median, d$Q1, d$Q3)) } else if (!is.null(d$mean) && !is.null(d$sd)) { # Type 3: mean + sd @@ -427,6 +546,10 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1[i] <- 0 # placeholder obs_stat2[i] <- 0 # placeholder obs_stat3[i] <- 0 # placeholder + # freq_value entries are true recorded values, not interpolated + # statistics, so (unlike median/Q1/Q3) they can all be trusted with the + # full "exact" grid search, the same way min/max are for type 1. + resolution_vec[i] <- detect_resolution(d$freq_value) freq_start_vec[i] <- running_start freq_len_vec[i] <- length(d$freq_value) freq_value_all <- c(freq_value_all, as.numeric(d$freq_value)) @@ -452,6 +575,12 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1[i] <- 0 # placeholder obs_stat2[i] <- 0 # placeholder obs_stat3[i] <- 0 # placeholder + # Only entries with no reported range (freq_lower == freq_upper) are + # treated as rounded point values in Stan; resolution is inferred from + # just those (true recorded values, so the "exact" grid search + # applies). detect_resolution() defaults to 1 (unused) if a dataset has + # no such entries. + resolution_vec[i] <- detect_resolution(d$freq_lower[d$freq_lower == d$freq_upper]) freq_start_vec[i] <- running_start freq_len_vec[i] <- length(d$freq_lower) freq_value_all <- c(freq_value_all, rep(0, length(d$freq_lower))) # unused for type 5 @@ -624,6 +753,7 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat1 = as.array(obs_stat1), obs_stat2 = as.array(obs_stat2), obs_stat3 = as.array(obs_stat3), + resolution = as.array(resolution_vec), n_freq_total = length(freq_value_all), freq_value = freq_value_all, freq_lower = freq_lower_all, @@ -2912,6 +3042,15 @@ run_simulation_study_generalized_non_parallel <- function(n_sim, #' (sample from types 1-3 with those probabilities), or a length-4 probability #' vector (sample from types 1-4 with those probabilities). Type 4 produces a #' frequency table of observations rounded to the nearest whole day. +#' @param round_order_stats If `TRUE`, the median/min/max/Q1/Q3 reported for +#' summary types 1 and 2 are rounded to the nearest multiple of +#' `resolution` before being returned, matching how these statistics are +#' actually reported in the literature. +#' @param resolution Rounding grid in days, used only when +#' `round_order_stats = TRUE`. Default `1` (nearest whole day); pass e.g. +#' `1/24` to simulate hour-resolution reporting. Recorded in the returned +#' `obs_data$resolution` field so the Stan model integrates over the same +#' window that was used to round the data. #' @return List containing true parameters and observed summary statistics generate_hierarchical_data_mixed <- function(n_datasets, n_obs, @@ -2921,7 +3060,9 @@ generate_hierarchical_data_mixed <- function(n_datasets, tau, phi, kappa = 1.0, - summary_type = NULL) { + summary_type = NULL, + round_order_stats = FALSE, + resolution = 1) { dist_type <- match.arg(dist_type) @@ -2956,10 +3097,11 @@ generate_hierarchical_data_mixed <- function(n_datasets, loc_d <- rnorm(n_datasets, mean = mu0, sd = tau) # Initialize storage - obs_stat1 <- numeric(n_datasets) - obs_stat2 <- numeric(n_datasets) - obs_stat3 <- numeric(n_datasets) - freq_tables <- vector("list", n_datasets) + obs_stat1 <- numeric(n_datasets) + obs_stat2 <- numeric(n_datasets) + obs_stat3 <- numeric(n_datasets) + resolution_vec <- rep(1, n_datasets) # unused (placeholder) for non-type-1/2 datasets + freq_tables <- vector("list", n_datasets) # Generate data for each dataset for (d in 1:n_datasets) { @@ -3002,12 +3144,24 @@ generate_hierarchical_data_mixed <- function(n_datasets, obs_stat1[d] <- median(data_d) obs_stat2[d] <- min(data_d) obs_stat3[d] <- max(data_d) - + if (round_order_stats) { + obs_stat1[d] <- round(obs_stat1[d] / resolution) * resolution + obs_stat2[d] <- round(obs_stat2[d] / resolution) * resolution + obs_stat3[d] <- round(obs_stat3[d] / resolution) * resolution + resolution_vec[d] <- resolution + } + } else if (st == 2) { # median + IQR obs_stat1[d] <- median(data_d) obs_stat2[d] <- quantile(data_d, 0.25) obs_stat3[d] <- quantile(data_d, 0.75) - + if (round_order_stats) { + obs_stat1[d] <- round(obs_stat1[d] / resolution) * resolution + obs_stat2[d] <- round(obs_stat2[d] / resolution) * resolution + obs_stat3[d] <- round(obs_stat3[d] / resolution) * resolution + resolution_vec[d] <- resolution + } + } else if (st == 3) { # mean + sd obs_stat1[d] <- mean(data_d) obs_stat2[d] <- sd(data_d) @@ -3065,6 +3219,7 @@ generate_hierarchical_data_mixed <- function(n_datasets, obs_stat1 = as.array(obs_stat1), obs_stat2 = as.array(obs_stat2), obs_stat3 = as.array(obs_stat3), + resolution = as.array(resolution_vec), # Frequency table fields (populated only when summary_type == 4) n_freq_total = length(freq_value_flat), freq_value = freq_value_flat, From 327c607638dc6039fbb7ca2620f03916a0fda0f6 Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 11:20:09 +0100 Subject: [PATCH 04/30] Improved stan model, so we can have 0 rather than 0.1 to be consistent with the underlying data. --- R/ddsynth_datasets.R | 106 +++++++++++++++++++++---------------------- 1 file changed, 52 insertions(+), 54 deletions(-) diff --git a/R/ddsynth_datasets.R b/R/ddsynth_datasets.R index 342d115..0b85dab 100644 --- a/R/ddsynth_datasets.R +++ b/R/ddsynth_datasets.R @@ -175,13 +175,11 @@ datasets_SARS <- list( # Severe Acute Respiratory Syndrome (SARS-CoV- source = "Meltzer (2004), doi: 10.3201/eid1002.030426" ), d18 = list( - # Note: four cases have freq_lower = 0 (unknown exposure start). Replaced with 0.1 to - # avoid a NaN gradient in the Weibull likelihood (0^phi * log(0) = 0 * -Inf = NaN). - # Lognormal and gamma are unaffected; this has negligible impact on all posteriors. - freq_lower = c( 2.5, 4.5, 0.1, 0.5, 5.5, 2.5, 1.5, 3.5, 7.5, 1.5, 2.5, 7.5, 4.5, 4.5, 3.5, - 0.5, 0.5, 2.5, 2.5, 0.1, 2.5, 0.1, 11.5, 0.5, 0.5, 1.5, 5.5, 3.5, 2.5, 12.5, + # Note: four cases have freq_lower = 0 (unknown exposure start). + freq_lower = c( 2.5, 4.5, 0, 0.5, 5.5, 2.5, 1.5, 3.5, 7.5, 1.5, 2.5, 7.5, 4.5, 4.5, 3.5, + 0.5, 0.5, 2.5, 2.5, 0, 2.5, 0, 11.5, 0.5, 0.5, 1.5, 5.5, 3.5, 2.5, 12.5, 1.5, 8.5, 7.5, 1.5, 5.5, 4.5, 3.5, 1.5, 0.5, 0.5, 3.5, 7.5, 5.5, 2.5, 1.5, - 1.5, 0.5, 1.5, 1.5, 1.5, 0.5, 8.5, 0.5, 0.1, 2.5, 5.5, 9.5, 2.5, 7.5, 4.5, + 1.5, 0.5, 1.5, 1.5, 1.5, 0.5, 8.5, 0.5, 0, 2.5, 5.5, 9.5, 2.5, 7.5, 4.5, 3.5, 1.5, 3.5, 3.5, 3.5, 4.5, 0.5), freq_upper = c( 6.5, 7.5, 2.5, 3.5, 6.5, 5.5, 4.5, 5.5, 11.5, 4.5, 5.5, 12.5, 5.5, 5.5, 6.5, 1.5, 4.5, 4.5, 4.5, 1.5, 4.5, 4.5, 13.5, 2.5, 1.5, 2.5, 10.5, 5.5, 4.5, 14.5, @@ -248,11 +246,11 @@ datasets_MERS <- list( # Middle East Respiratory Syndrome (MERS-CoV) source = "Assiri (2013), doi: 10.1056/NEJMoa1306742" ), d11 = list( # South Korea - freq_lower = c( 0.1, 0.1, 0.1, 0.1, 1, 2, 2, 2, 3, 3, 3, 4, - 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 6, - 6, 7, 7, 7, 7, 8, 8, 8, 8, 8, 9, 9, 10, + freq_lower = c( 0, 0, 0, 0, 1, 2, 2, 2, 3, 3, 3, 4, + 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 6, + 6, 7, 7, 7, 7, 8, 8, 8, 8, 8, 9, 9, 10, 10, 10, 11, 11, 12, 12, 12, 13, 15 ), - freq_upper = c( 0.1, 6, 12, 15, 3, 3, 4, 8, 3, 5, 8, 4, + freq_upper = c( 0, 6, 12, 15, 3, 3, 4, 8, 3, 5, 8, 4, 5, 6, 8, 14, 5, 6, 7, 8, 9, 13, 6, 7, 8, 12, 7, 8, 9, 11, 8, 9, 10, 11, 12, 9, 10, 10, 12, 18, 12, 13, 14, 21, 27, 13, 17 ), @@ -348,7 +346,7 @@ datasets_Mpox <- list( # Mpox d11 = list(median = 7, Q1 = 4, Q3 = 11, n = 51, country = 'Mixed', subgroup = 'IIb',source = "Thornhill (2022), doi: 10.1016/S0140-6736(22)02187-0"), d12 = list(median = 7, min = 3, max = 20, n = 23, country = 'Mixed', subgroup = 'IIb',source = "Thornhill (2022a), doi: 10.1056/NEJMoa2207323"), d13 = list( - freq_lower = c( 4, 0.1, 1, 2, 3, 0.1, 9, 0.1, 10, 1, 6, 0.1, 7, 0.1, 8, 1, 2, 1, 0.1, 1, 3, 0.1 ), + freq_lower = c( 4, 0, 1, 2, 3, 0, 9, 0, 10, 1, 6, 0, 7, 0, 8, 1, 2, 1, 0, 1, 3, 0 ), freq_upper = c( 6, 8, 23, 5, 6, 14, 11, 24, 12, 6, 8, 18, 16, 2, 17, 29, 10, 6, 23, 3, 8, 12 ), freq_count = c( 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), subgroup = 'IIb', @@ -363,7 +361,7 @@ datasets_Mpox <- list( # Mpox source = "Cobos (2023), doi: 10.37201/req/112.2022" ), d15 = list( - freq_lower = c( 0.1, 0.1, 0.1, 0.1, 1, 2, 2, 3, 3, 4, 5, 6, 6, 6, + freq_lower = c( 0, 0, 0, 0, 1, 2, 2, 3, 3, 4, 5, 6, 6, 6, 6, 7, 7, 7, 8, 9, 9, 10, 11, 11, 12, 15, 19, 19 ), freq_upper = c( 2, 3, 7, 12, 4, 2, 9, 3, 8, 4, 5, 6, 12, 13, 15, 7, 14, 14, 13, 9, 24, 10, 11, 11, 22, 22, 19, 24 ), @@ -374,8 +372,8 @@ datasets_Mpox <- list( # Mpox source = "Guzzetta (2022), doi: 10.3201/eid2810.221126" ), d16 = list( - freq_lower = c( 0.1, 0.1, 0.1, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3, - 3, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, + freq_lower = c( 0, 0, 0, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3, + 3, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 9, 9, 9, 9, 10, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14, 15, 15, 15, 15, 16, 16, 17, 18, 18, 18, 19, 19, 20, 20, 21, 21, 22, 30 ), @@ -405,7 +403,7 @@ datasets_Cholera <- list( # Cholera d1 = list(median = 21/24, min = 19/24, max = 49/24, n = 7, country = 'USA', subgroup = "O139", source = "Morris (1995), doi: 10.1093/infdis/171.4.903"), d2 = list(median = 31/24, min = 19/24, max = 64/24, n = 11, country = 'USA', subgroup = "O139", source = "Morris (1995), doi: 10.1093/infdis/171.4.903"), d3 = list( - freq_lower = c( 0.1, 1.0, 1.5, 2.0, 2.0, 1.0, 2.0, 3.0, 6.0, 7.0 ), + freq_lower = c( 0, 1.0, 1.5, 2.0, 2.0, 1.0, 2.0, 3.0, 6.0, 7.0 ), freq_upper = c( 1.0, 2.0, 2.0, 2.0, 3.0, 3.0, 4.0, 4.0, 8.0,11.0 ), freq_count = c( 6, 9, 2, 1, 2, 1, 1, 1, 1, 1 ), subgroup = "O1 Classical", @@ -433,7 +431,7 @@ datasets_Cholera <- list( # Cholera source = "Cash (1974), doi: 10.1093/infdis/129.1.45" ), d6 = list( - freq_lower = c( 0.1, 1, 2, 3, 4, 5, 6 ), + freq_lower = c( 0, 1, 2, 3, 4, 5, 6 ), freq_upper = c( 1, 2, 3, 4, 5, 6, 7 ), freq_count = c( 6, 26, 23, 6, 3, 1, 1 ), subgroup = 'O1 El Tor', @@ -478,14 +476,14 @@ datasets_Cholera <- list( # Cholera # Achlorhydric: 12(x2), 22(x4), 48(x2), 72, 96 # Normochlorhydric: 22, 48, 72(x3), 96(x2), 144(x3) # Not examined: 22(x2), 48(x4), 72(x2), 96, 120 - freq_value = c( 0.1, 2, 5, 12, 15, 22, 24, 48, 72, 96, 120, 144 ) / 24, + freq_value = c( 0, 2, 5, 12, 15, 22, 24, 48, 72, 96, 120, 144 ) / 24, freq_count = c( 4, 2, 1, 4, 1, 11, 2, 13, 7, 4, 1, 3 ), country = 'Italy', subgroup = "O1 El Tor Ogawa", source = "Schiraldi (1974), PMCID: PMC2366304" ), d11 = list( - freq_lower = c(0.1, 24, 49, 72)/24, + freq_lower = c(0, 24, 49, 72)/24, freq_upper = c(24, 48, 72, 150)/24, freq_count = c(1, 15, 5, 2), subgroup = "O1 El Tor", @@ -693,7 +691,7 @@ datasets_COVID_19 <- list( d2 = list( median = 4.3, Q1 = 2.5, Q3 = 6.5, n = 53, source = "Bender (2021), doi: 10.3201/eid2704.204576", country = "Germany", subgroup = "Wildtype" ), d3 = list( median = 6, min = 1, max = 13, n = 27, source = "Liu (2020), doi: 10.1097/JCMA.0000000000000411", country = "China", subgroup = "Wildtype" ), d4 = list( mean = 8.23, sd = 3.58, n = 22, source = "Song (2020), doi: 10.1016/j.jinf.2020.04.018", country = "China", subgroup = "Wildtype" ), - d5 = list( median = 3, min = 0.1, max = 15, n = 10, source = "Ki (2020), doi: 10.4178/epih.e2020007", country = "South Korea", subgroup = "Wildtype" ), + d5 = list( median = 3, min = 0, max = 15, n = 10, source = "Ki (2020), doi: 10.4178/epih.e2020007", country = "South Korea", subgroup = "Wildtype" ), # min encoded as 0: integer-day same-day onset recorded as 0 d6 = list( median = 8.5, min = 1, max = 24, n = 28, source = "Mao (2020), doi: 10.1186/s12889-020-09606-4", country = "China", subgroup = "Wildtype" ), d7 = list( median = 7, min = 2, max = 12, n = 8, source = "Zhang (2020), doi: 10.1186/s12879-020-05570-x", country = "China", subgroup = "Wildtype" ), d8 = list( median = 8, min = 4, max = 13, n = 23, source = "Zhang (2020), doi: 10.1186/s12879-020-05570-x", country = "China", subgroup = "Wildtype" ), @@ -709,23 +707,23 @@ datasets_COVID_19 <- list( d17 = list( # n=256, Bavaria Germany, Wildtype. Jan 20 – Mar 19 2020. # Interval-censored: lower = onset - right_expo, upper = onset - left_expo. - # 67 cases where left_expo = right_expo (point exposure): lower set to 0.1. + # 67 cases where left_expo = right_expo (point exposure): lower set to 0. # 10 cases with upper > 20 days reflect wide exposure windows (uninformative but valid). # Replaces summary-statistic entry d17 (mean=4.6, sd=3.0, n=256). freq_lower = c( - 6, 3, 4, 6, 1, 2, 2, 2, 0.1, 3, 9, 0.1, 2, 0.1, 0.1, 2, 3, 4, 1, 1, - 1, 2, 1, 5, 0.1, 1, 7, 0.1, 0.1, 7, 0.1, 6, 1, 3, 2, 5, 0.1, 1, 2, 2, - 4, 0.1, 0.1, 12, 1, 0.1, 11, 9, 5, 3, 3, 7, 7, 7, 6, 6, 0.1, 1, 1, 1, - 3, 1, 1, 9, 2, 0.1, 0.1, 4, 2, 2, 4, 4, 1, 5, 3, 8, 15, 2, 2, 3, - 15, 3, 1, 2, 4, 4, 7, 0.1, 0.1, 3, 6, 1, 0.1, 0.1, 2, 1, 1, 1, 3, 3, - 0.1, 1, 3, 9, 2, 0.1, 2, 0.1, 7, 9, 5, 4, 0.1, 0.1, 0.1, 0.1, 3, 3, 1, 1, - 11, 2, 0.1, 2, 2, 1, 5, 6, 9, 0.1, 5, 0.1, 2, 1, 2, 7, 1, 1, 7, 0.1, - 5, 3, 1, 4, 0.1, 1, 3, 2, 1, 0.1, 0.1, 4, 1, 10, 0.1, 2, 2, 0.1, 5, 10, - 0.1, 1, 2, 2, 0.1, 0.1, 7, 1, 1, 0.1, 0.1, 0.1, 0.1, 0.1, 3, 6, 0.1, 0.1, 0.1, 0.1, - 2, 1, 2, 2, 1, 3, 0.1, 2, 1, 1, 1, 0.1, 2, 2, 2, 0.1, 1, 0.1, 3, 2, - 2, 0.1, 2, 2, 8, 1, 0.1, 1, 1, 4, 5, 1, 8, 15, 2, 0.1, 3, 2, 0.1, 4, - 2, 0.1, 0.1, 2, 0.1, 5, 1, 6, 0.1, 2, 1, 0.1, 1, 0.1, 0.1, 0.1, 2, 1, 2, 2, - 2, 2, 0.1, 1, 2, 7, 0.1, 0.1, 3, 0.1, 9, 9, 1, 6, 5, 2 + 6, 3, 4, 6, 1, 2, 2, 2, 0, 3, 9, 0, 2, 0, 0, 2, 3, 4, 1, 1, + 1, 2, 1, 5, 0, 1, 7, 0, 0, 7, 0, 6, 1, 3, 2, 5, 0, 1, 2, 2, + 4, 0, 0, 12, 1, 0, 11, 9, 5, 3, 3, 7, 7, 7, 6, 6, 0, 1, 1, 1, + 3, 1, 1, 9, 2, 0, 0, 4, 2, 2, 4, 4, 1, 5, 3, 8, 15, 2, 2, 3, + 15, 3, 1, 2, 4, 4, 7, 0, 0, 3, 6, 1, 0, 0, 2, 1, 1, 1, 3, 3, + 0, 1, 3, 9, 2, 0, 2, 0, 7, 9, 5, 4, 0, 0, 0, 0, 3, 3, 1, 1, + 11, 2, 0, 2, 2, 1, 5, 6, 9, 0, 5, 0, 2, 1, 2, 7, 1, 1, 7, 0, + 5, 3, 1, 4, 0, 1, 3, 2, 1, 0, 0, 4, 1, 10, 0, 2, 2, 0, 5, 10, + 0, 1, 2, 2, 0, 0, 7, 1, 1, 0, 0, 0, 0, 0, 3, 6, 0, 0, 0, 0, + 2, 1, 2, 2, 1, 3, 0, 2, 1, 1, 1, 0, 2, 2, 2, 0, 1, 0, 3, 2, + 2, 0, 2, 2, 8, 1, 0, 1, 1, 4, 5, 1, 8, 15, 2, 0, 3, 2, 0, 4, + 2, 0, 0, 2, 0, 5, 1, 6, 0, 2, 1, 0, 1, 0, 0, 0, 2, 1, 2, 2, + 2, 2, 0, 1, 2, 7, 0, 0, 3, 0, 9, 9, 1, 6, 5, 2 ), freq_upper = c( 13, 6, 6, 10, 3, 4, 6, 43, 7, 10, 12, 3, 6, 2, 3, 5, 5, 7, 3, 8, @@ -779,13 +777,13 @@ datasets_COVID_19 <- list( d25 = list( median = 2, min = 1, max = 4, n = 6, source = "Huang (2020), doi: 10.1016/j.jinf.2020.03.006", country = "China", subgroup = "Wildtype" ), d26 = list( mean = 6.5, sd = 4.58, n = 102, source = "Zhao (2021b), doi: 10.1097/MD.0000000000027846", country = "China", subgroup = "Wildtype" ), d27 = list( mean = 8.67, sd = 5.16, n = 957, source = "Li (2020), doi: 10.3389/fpubh.2020.577431", country = "China", subgroup = "Wildtype" ), - d28 = list( median = 4, min = 0.1, max = 11, n = 45, source = "Bernal Lopez (2022), doi: 10.2807/1560-7917.ES.2022.27.15.2001551", country = "UK", subgroup = "Wildtype" ), # min raised 0→0.5: integer-day same-day onset recorded as 0 + d28 = list( median = 4, min = 0, max = 11, n = 45, source = "Bernal Lopez (2022), doi: 10.2807/1560-7917.ES.2022.27.15.2001551", country = "UK", subgroup = "Wildtype" ), # min encoded as 0: integer-day same-day onset recorded as 0 d29 = list( median = 4, min = 2, max = 11, n = 12, source = "Bernal Lopez (2022), doi: 10.2807/1560-7917.ES.2022.27.15.2001551", country = "UK", subgroup = "Wildtype" ), # --- Omicron --- d30 = list( mean = 4.58, sd = 1.72, n = 57, source = "Mefsin (2022), doi: 10.3201/eid2809.220613", country = "China", subgroup = "Omicron" ), d31 = list( mean = 4.42, sd = 1.42, n = 23, source = "Mefsin (2022), doi: 10.3201/eid2809.220613", country = "China", subgroup = "Omicron" ), - d32 = list( median = 3, min = 0.1, max = 8, n = 81, source = "Brandal (2021), doi: 10.2807/1560-7917.ES.2021.26.50.2101147", country = "Norway", subgroup = "Omicron" ), # min raised 0→0.5: integer-day same-day onset recorded as 0 + d32 = list( median = 3, min = 0, max = 8, n = 81, source = "Brandal (2021), doi: 10.2807/1560-7917.ES.2021.26.50.2101147", country = "Norway", subgroup = "Omicron" ), # min encoded as 0: integer-day same-day onset recorded as 0 d34 = list( mean = 3.2, sd = 2.2, n = 258, source = "Backer (2022), doi: 10.2807/1560-7917.ES.2022.27.6.2200042", country = "Netherlands", subgroup = "Omicron" ), d36 = list( @@ -811,9 +809,9 @@ datasets_COVID_19 <- list( d38 = list( mean = 4.4, sd = 1.9, n = 47, source = "Zhang (2021), doi: 10.46234/ccdcw2021.148", country = "China", subgroup = "Delta" ), # Each case's incubation period window length (onset - earliest possible exposure) treated as the upper bound of an interval-censored observation. - # Lower bound set to 0.1 throughout (Weibull convention to avoid zero) -- Manually digitised from Fig S2 using daily gridlines; N=136. + # Lower bound set to 0 throughout -- Manually digitised from Fig S2 using daily gridlines; N=136. d40 = list( - freq_lower = rep(0.1, 12), + freq_lower = rep(0, 12), freq_upper = c( 2, 3, 4, 5, 6, 7, 8, 10, 11, 12, 14, 15), freq_count = c( 4, 30, 21, 10, 26, 14, 10, 5, 11, 1, 3, 1), subgroup = "Delta", @@ -1042,7 +1040,7 @@ datasets_Dengue <- list( d13 = list( # CDC (1982). Five IIP observations (DENV-4), all interval-censored, # as extracted by Chan et al. (2012), doi:10.1371/journal.pone.0050972. - freq_lower = c(0.1, 5, 5, 5, 5), + freq_lower = c(0, 5, 5, 5, 5), freq_upper = c(6, 11, 11, 11, 11), freq_count = c(1, 1, 1, 1, 1), source = "CDC (1982)" @@ -1191,26 +1189,26 @@ datasets_flu <- list( # Supplementary Table 1: n=134 doubly interval-censored incubation period # observations from 2009 H1N1 outbreak at a New York City school. # Approximation: onset midpoint S = (SL+SR)/2 used (SR-SL = 1 day for all - # observations, so maximum error = 0.5 days). Lower bound = max(0.1, S-ER), - # upper bound = S-EL. 129/134 lower bounds floored to 0.1 due to wide + # observations, so maximum error = 0.5 days). Lower bound = max(0, S-ER), + # upper bound = S-EL. 129/134 lower bounds floored to 0 due to wide # exposure windows (EL=7.25, ER >= S_mid for most school-contact cases). # Authors' log-normal fit (full doubly censored likelihood): median 6.4 days # (95% CI 5.9-6.8), dispersion 1.19 (95% CI 1.15-1.24). freq_lower = c( - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 1.5, 2.5, 1.5, 0.1, 0.1, 0.1, 0.1, - 1.5, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 1.5, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, - 0.1, 0.1, 0.1, 0.1), + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1.5, 2.5, 1.5, 0, 0, 0, 0, + 1.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1.5, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0), freq_upper = c( 9.5, 3.25, 3.25, 3.25, 1.25, 2.25, 3.25, 3.25, 2.5, 2.25, 6.5, 3.25, 4.5, 3.25, 3.25, 5.5, 2.5, 5.5, 3.25, 4.25, From ead8803072e72850324acd9e6d23801c4374101d Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 19:56:38 +0100 Subject: [PATCH 05/30] Extend rounding treatment to dc_log_lik Cases 2/3, fix Case 1's kernel shape Cases 2/3 (only one side of exposure/event is a point) now get the same resolution-based rounding Case 1 already had. Case 1 itself is corrected: two independently day-rounded dates convolve to a triangular kernel of width 2*resolution, not a flat box of width resolution. All three now match Case 4's existing quadrature convention exactly. --- ...archical_data_synthesis_summary_stats.stan | 98 +++++++++++++------ ...al_data_synthesis_summary_stats_joint.stan | 92 ++++++++++++----- 2 files changed, 140 insertions(+), 50 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index abfff3b..37bfa83 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -320,32 +320,18 @@ functions { // Both interval-censored (general) -> 7-point Gauss-Legendre quadrature real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, int dist_type, real loc, real phi, real kappa, real resolution) { - // Case 1: both endpoints point-observed. The implied delay ev_l - ex_l is - // itself a rounded reported value (like summary_type 4/5's degenerate - // case), not an exact continuous observation, and is treated the same - // way via rounded_freq_loglik_fun rather than the raw point density - // dist_logpdf_fun (which is singular/undefined at a delay of exactly 0 - // for several families). - if (ex_l == ex_r && ev_l == ev_r) { - return rounded_freq_loglik_fun(ev_l - ex_l, dist_type, loc, phi, kappa, resolution); - } - // Case 2: point exposure, interval event - if (ex_l == ex_r) { - return log_diff_exp( - dist_log_cdf_fun(ev_r - ex_l, dist_type, loc, phi, kappa), - dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa) - ); - } - // Case 3: interval exposure, point event (reduces to type 5) - if (ev_l == ev_r) { - return log_diff_exp( - dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa), - dist_log_cdf_fun(ev_l - ex_r, dist_type, loc, phi, kappa) - ); - } - // Case 4: both interval-censored (7-point Gauss-Legendre quadrature on [ex_l, ex_r]). - // Nodes and weights on [-1, 1] (Abramowitz & Stegun table 25.4). - // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. + // 7-point Gauss-Legendre nodes/weights on [-1, 1] (Abramowitz & Stegun + // table 25.4), shared by every case below. Every case quadratures over + // the exposure side (its genuinely reported window in Cases 2-4, or a + // resolution-wide window standing in for a point report in Cases 1/3), + // treating the event side as a closed-form probability at each exposure + // node: dist_log_cdf_fun's CDF-difference when event is a genuine + // window (Cases 2, 4), or rounded_freq_loglik_fun's resolution-wide + // probability when event is itself a point report (Cases 1, 3). This + // keeps every case's Jacobian-dropping convention identical to Case 4's + // pre-existing one: calling this function with a point widened to its + // own resolution window gives the exact same result, node for node, as + // calling Case 4 directly with that window as an explicit interval. array[7] real t = {-0.9491079123427585, -0.7415311855993945, -0.4058451513773832, 0.0, 0.4058451513773832, 0.7415311855993945, @@ -354,6 +340,58 @@ functions { 0.3818300505051189, 0.4179591836734694, 0.3818300505051189, 0.2797053914892767, 0.1294849661688697}; + real half_res = resolution / 2; + + // Case 1: both endpoints point-observed. Exposure and event are each + // independently day-rounded, so the delay's implied distribution is the + // convolution of two independent Uniform(-resolution/2, resolution/2) + // rounding errors: a triangular kernel of half-width `resolution`, not + // the single rounded_freq_loglik_fun evaluation used before. Integrating + // out the exposure side analytically collapses the general double + // integral to this 1D quadrature over rounded_freq_loglik_fun exactly, + // no approximation in that reduction step. + if (ex_l == ex_r && ev_l == ev_r) { + real d = ev_l - ex_l; + array[7] real log_terms; + for (k in 1:7) { + real v_k = half_res * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(d - v_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 2: point exposure, interval event. Exposure is day-rounded; event + // stays exactly as reported (a genuine censoring window, not itself + // rounded further). Quadrature averages the point-exposure formula over + // exposure's own rounding window instead of evaluating it once at the + // exact reported value. + if (ex_l == ex_r) { + array[7] real log_terms; + for (k in 1:7) { + real e_k = ex_l + half_res * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } + // Case 3: interval exposure, point event. Quadrature over the genuinely + // reported exposure window, exactly like Case 4, but with the event + // side's closed-form CDF-difference replaced by rounded_freq_loglik_fun + // (event is itself a point report, standing in for its own resolution + // window) instead of the exact reported event window Case 4 uses. + if (ev_l == ev_r) { + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(ev_l - e_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 4: both interval-censored (quadrature on [ex_l, ex_r]). + // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. real mid = 0.5 * (ex_r + ex_l); real half = 0.5 * (ex_r - ex_l); array[7] real log_terms; @@ -382,8 +420,8 @@ data { // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported // order statistics), summary_type 4/5 (raw/degenerate frequency-table - // counts), and summary_type 6/7's own degenerate (both-endpoints-point- - // observed) case in dc_log_lik, all treated as rounded point values. + // counts), and summary_type 6/7's dc_log_lik whenever exposure and/or + // event is point-observed (Cases 1-3), all treated as rounded values. // Ignored for summary_type 3 (populate with 1, unused). array[n_datasets] real resolution; @@ -412,6 +450,10 @@ data { // Type 7: right truncation / right censoring. // event_observed[i] = 1 if onset was recorded, 0 if right-censored (onset not yet seen). // truncation_time[d] = analysis date T in days from the reference date; ignored for other types. + // T is a study-design cutoff, not a rounded observation of a random event + // time, so it is never treated as day-rounded the way exposure/event + // windows are (see resolution, above). Set it using the same + // time-encoding convention as that dataset's own windows. array[n_freq_total] int event_observed; // 1=onset seen, 0=right-censored array[n_datasets] real truncation_time; // analysis date T per dataset diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan index 52837ac..7dd7de4 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan @@ -337,26 +337,18 @@ functions { // Identical to the version in hierarchical_data_synthesis_summary_stats.stan. real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, int dist_type, real loc, real phi, real kappa, real resolution) { - // Both endpoints point-observed: the implied delay ev_l - ex_l is itself - // a rounded reported value, not an exact continuous observation, and is - // treated the same way via rounded_freq_loglik_fun as summary_type 4/5's - // degenerate case, rather than the raw point density dist_logpdf_fun - // (singular/undefined at a delay of exactly 0 for several families). - if (ex_l == ex_r && ev_l == ev_r) { - return rounded_freq_loglik_fun(ev_l - ex_l, dist_type, loc, phi, kappa, resolution); - } - if (ex_l == ex_r) { - return log_diff_exp( - dist_log_cdf_fun(ev_r - ex_l, dist_type, loc, phi, kappa), - dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa) - ); - } - if (ev_l == ev_r) { - return log_diff_exp( - dist_log_cdf_fun(ev_l - ex_l, dist_type, loc, phi, kappa), - dist_log_cdf_fun(ev_l - ex_r, dist_type, loc, phi, kappa) - ); - } + // 7-point Gauss-Legendre nodes/weights on [-1, 1] (Abramowitz & Stegun + // table 25.4), shared by every case below. Every case quadratures over + // the exposure side (its genuinely reported window in Cases 2-4, or a + // resolution-wide window standing in for a point report in Cases 1/3), + // treating the event side as a closed-form probability at each exposure + // node: dist_log_cdf_fun's CDF-difference when event is a genuine + // window (Cases 2, 4), or rounded_freq_loglik_fun's resolution-wide + // probability when event is itself a point report (Cases 1, 3). This + // keeps every case's Jacobian-dropping convention identical to Case 4's + // pre-existing one: calling this function with a point widened to its + // own resolution window gives the exact same result, node for node, as + // calling Case 4 directly with that window as an explicit interval. array[7] real t = {-0.9491079123427585, -0.7415311855993945, -0.4058451513773832, 0.0, 0.4058451513773832, 0.7415311855993945, @@ -365,6 +357,58 @@ functions { 0.3818300505051189, 0.4179591836734694, 0.3818300505051189, 0.2797053914892767, 0.1294849661688697}; + real half_res = resolution / 2; + + // Case 1: both endpoints point-observed. Exposure and event are each + // independently day-rounded, so the delay's implied distribution is the + // convolution of two independent Uniform(-resolution/2, resolution/2) + // rounding errors: a triangular kernel of half-width `resolution`, not + // the single rounded_freq_loglik_fun evaluation used before. Integrating + // out the exposure side analytically collapses the general double + // integral to this 1D quadrature over rounded_freq_loglik_fun exactly, + // no approximation in that reduction step. + if (ex_l == ex_r && ev_l == ev_r) { + real d = ev_l - ex_l; + array[7] real log_terms; + for (k in 1:7) { + real v_k = half_res * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(d - v_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 2: point exposure, interval event. Exposure is day-rounded; event + // stays exactly as reported (a genuine censoring window, not itself + // rounded further). Quadrature averages the point-exposure formula over + // exposure's own rounding window instead of evaluating it once at the + // exact reported value. + if (ex_l == ex_r) { + array[7] real log_terms; + for (k in 1:7) { + real e_k = ex_l + half_res * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } + // Case 3: interval exposure, point event. Quadrature over the genuinely + // reported exposure window, exactly like Case 4, but with the event + // side's closed-form CDF-difference replaced by rounded_freq_loglik_fun + // (event is itself a point report, standing in for its own resolution + // window) instead of the exact reported event window Case 4 uses. + if (ev_l == ev_r) { + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(ev_l - e_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 4: both interval-censored (quadrature on [ex_l, ex_r]). + // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. real mid = 0.5 * (ex_r + ex_l); real half = 0.5 * (ex_r - ex_l); array[7] real log_terms; @@ -392,8 +436,8 @@ data { // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported // order statistics), summary_type 4/5 (raw/degenerate frequency-table - // counts), and summary_type 6/7's own degenerate (both-endpoints-point- - // observed) case in dc_log_lik, all treated as rounded point values. + // counts), and summary_type 6/7's dc_log_lik whenever exposure and/or + // event is point-observed (Cases 1-3), all treated as rounded values. // Ignored for summary_type 3 (populate with 1, unused). array[n_datasets] real resolution; @@ -415,6 +459,10 @@ data { // Type 7: right truncation / right censoring. // event_observed[i] = 1 if onset was recorded, 0 if right-censored (onset not yet seen). // truncation_time[d] = analysis date T in days from the reference date; ignored for other types. + // T is a study-design cutoff, not a rounded observation of a random event + // time, so it is never treated as day-rounded the way exposure/event + // windows are (see resolution, above). Set it using the same + // time-encoding convention as that dataset's own windows. array[n_freq_total] int event_observed; // 1=onset seen, 0=right-censored array[n_datasets] real truncation_time; // analysis date T per dataset From 1ccda0f25ac145355816f859676e653c6b9a909a Mon Sep 17 00:00:00 2001 From: cm401 Date: Sat, 1 Aug 2026 19:57:02 +0100 Subject: [PATCH 06/30] add documentation --- R/utils.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/utils.R b/R/utils.R index 433d3b0..4033aa2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -373,6 +373,20 @@ detect_resolution <- function(exact_vals, risky_vals = numeric(0), tol = 1e-6) { #' All five vectors must have the same length. Requires #' `expo_upper[i] <= event_lower[i]` for all i (positive delays). `n` #' is optional and defaults to `sum(freq_count)`.} +#' \item{`expo_lower`, `expo_upper`, `event_lower`, `event_upper`, +#' `event_observed`, `freq_count`, `truncation_time`}{Double +#' interval-censored with right truncation/censoring (summary type 7). +#' As type 6, plus `event_observed` (1 = onset seen, 0 = right-censored: +#' not yet observed by the analysis cutoff) and a single +#' `truncation_time` per dataset (the analysis cutoff `T`, in the same +#' time origin as the exposure/event windows). `truncation_time` is a +#' study-design choice, not a rounded observation of a random event +#' time, so it is never treated as day-rounded the way exposure/event +#' windows are. Set it using the same time-encoding convention as that +#' dataset's own windows: e.g. if event days are encoded as `[day, +#' day+1)` intervals, set `truncation_time` to `(last observed day + +#' 1)` to mean "complete through the end of that day", not to the bare +#' day number.} #' } #' Each element may also contain an optional `source` field — a free-text #' character string recording the bibliographic reference for that dataset From 76f1675c051eb4798b951ca4bff86558d9ca4eb5 Mon Sep 17 00:00:00 2001 From: cm401 Date: Mon, 3 Aug 2026 14:22:06 +0100 Subject: [PATCH 07/30] Add family-gated per-study dispersion hierarchy and computational-efficiency levers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the shared scalar phi per pathogen with a non-centered hierarchical phi_d/omega reparameterization (both the primary and joint Stan models), so real between-study dispersion heterogeneity is no longer forced entirely into tau. The hierarchy is applied selectively based on a per-family identifiability analysis: lognormal, Weibull and Burr XII default to the hierarchical model; gamma reverts to a restored shared-scalar-phi variant, since its shape parameter's information about its own dispersion structurally vanishes at the large-shape end, unlike the other families; generalised gamma is eligible but gated behind the pre-existing should_attempt_gg() joint identifiability check.  analysis/main_analysis.R now compiles and dispatches between the two model variants per family. Also fixes pre_inference_checks(), which still referenced the pre-point-4 parameter names and would hard-error against the new model. Three computational-efficiency changes: - n-adaptive quadrature panel count for the order-statistic rounding likelihood: the fixed 24-panel scheme was calibrated for the corpus’s largest dataset and is overkill for most of it. Panel count is now computed per dataset from a method-of-moments dispersion guess (fully static, no change to Stan's autodiff model), with family-specific safety margins and gamma excluded (its own worst-case margin would require an intractable node count). Validated to agree with the fixed-panel scheme to 3e-11 in log-probability at a fixed parameter point, with a measured 6.92x speedup on a real fit. - fit_with_escalation(): tries increasingly conservative MCMC settings, stopping once Rhat<1.05 and divergence rate <1%, falling back to the original production settings (adapt_delta=0.999) verbatim as the final tier rather than relaxing them, since those were originally needed for some chains to converge at all. - fit_corpus_parallel(): parallelizes fitting across pathogen/family combinations, reserving cores (default 4 of 12) so the machine stays usable during a run analysis/checkpoint_run_point4.R is a reduced-settings script for validating all of the above across a representative pathogen subset before a full run. --- ...archical_data_synthesis_summary_stats.stan | 119 +- ...al_data_synthesis_summary_stats_joint.stan | 57 +- ...thesis_summary_stats_joint_shared_phi.stan | 1091 ++++++++++++++++ ...ta_synthesis_summary_stats_shared_phi.stan | 1140 +++++++++++++++++ 4 files changed, 2357 insertions(+), 50 deletions(-) create mode 100644 inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan create mode 100644 inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index 37bfa83..486431f 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -166,8 +166,14 @@ functions { // that magnitude (around -450 in the case tested). A narrower box (finer // resolution) is strictly easier to resolve, since the accuracy problem is // driven by the box being wide relative to the order statistic's SE. - real order_stat_rounded_loglik_fun(real v, int n, int k, int dist_type, real loc, real phi, real kappa, real resolution) { - int n_panels = 24; + // n_panels: number of composite Gauss-Legendre panels (7-point rule each) + // used to integrate over the rounding box. Passed in per-dataset (see + // R/utils.R's .order_stat_n_panels() and POINT1_LIKELIHOOD_MATHS.md Part + // G) rather than hardcoded, so small/typical studies do not pay for the + // resolution only needed to resolve the sharp, large-n order-statistic + // peaks (COVID-19-scale line lists) that motivated the original 24-panel + // choice. + real order_stat_rounded_loglik_fun(real v, int n, int k, int dist_type, real loc, real phi, real kappa, real resolution, int n_panels) { array[7] real t = {-0.9491079123427585, -0.7415311855993945, -0.4058451513773832, 0.0, 0.4058451513773832, 0.7415311855993945, @@ -425,6 +431,15 @@ data { // Ignored for summary_type 3 (populate with 1, unused). array[n_datasets] real resolution; + // Per-order-statistic composite-quadrature panel count for + // order_stat_rounded_loglik_fun (summary_type 1/2 only elsewhere; ignored, + // but must still be present, for other summary types). Computed in + // R/utils.R's .order_stat_n_panels(); see POINT1_LIKELIHOOD_MATHS.md Part + // G. Family 2 (gamma) always gets 24 here (no adaptive reduction). + array[n_datasets] int n_panels_stat1; + array[n_datasets] int n_panels_stat2; + array[n_datasets] int n_panels_stat3; + // --- Frequency table data for summary_type == 4 --- // All datasets' frequency tables are stored in flat arrays. // For dataset d, its entries occupy indices freq_start[d] .. freq_start[d] + freq_len[d] - 1. @@ -465,10 +480,22 @@ data { real log_tau_mean; real log_tau_sd; - // Prior hyperparameters for log_phi ~ normal(log_phi_mean, log_phi_sd) + // Prior hyperparameters for log_phi0 ~ normal(log_phi_mean, log_phi_sd). + // log_phi0 is the population-mean log dispersion; per-study dispersion + // phi_d is now hierarchical (see log_omega below), not a shared scalar. real log_phi_mean; real log_phi_sd; + // Prior hyperparameters for log_omega ~ normal(log_omega_mean, log_omega_sd). + // omega is the between-study SD of log dispersion (log_phi_d), analogous to + // tau for location. Default log_omega_mean=-0.9, log_omega_sd=0.5, chosen + // from a no-pooling per-dataset real-likelihood fit across 4 well-populated + // pathogens (COVID-19, SARS, Cholera, Dengue): pooled within-pathogen + // sd(log phi) = 0.415, matching this codebase's existing log_tau_sd=0.5 + // convention. See REVISION_TODO.md / point 4 writeup for the full record. + real log_omega_mean; + real log_omega_sd; + // Prior hyperparameters for log_kappa ~ normal(log_kappa_mean, log_kappa_sd) // kappa = exp(log_kappa) > 0; used by dist_type 4 (Burr XII k) and 5 (GG Q). // For dist_type 1-3 supply wide uninformative priors (e.g. mean=0, sd=1); @@ -542,50 +569,62 @@ transformed data { parameters { real mu0; // Population mean (location) - real log_tau; // Log of between-study SD - real log_phi; // Log of distribution-specific shape/scale parameter - real log_kappa; // Log of 3rd distribution parameter (Burr XII k; GG Q) - vector[n_datasets] loc_d_raw; // Non-centered parameterization + real log_tau; // Log of between-study SD (location) + real log_phi0; // Log of population-mean dispersion + real log_omega; // Log of between-study SD (log dispersion) + real log_kappa; // Log of 3rd distribution parameter (Burr XII k; GG Q), shared + vector[n_datasets] loc_d_raw; // Non-centered parameterization, location + vector[n_datasets] log_phi_d_raw; // Non-centered parameterization, dispersion } transformed parameters { - real tau = exp(log_tau); - real phi = exp(log_phi); - real kappa = exp(log_kappa); + real tau = exp(log_tau); + real phi0 = exp(log_phi0); + real omega = exp(log_omega); + real kappa = exp(log_kappa); vector[n_datasets] loc_d = mu0 + tau * loc_d_raw; + // Per-study dispersion. kappa stays shared: the type-3 (mean+SD) profile + // Fisher information for the shape pair is rank 1 (see + // vignettes/gg_identifiability.Rmd Appendix B), so a single mean+SD study + // cannot separate a per-study kappa from a per-study phi; only the shared + // component (kappa here) can be estimated per study without collapsing. + vector[n_datasets] phi_d = exp(log_phi0 + omega * log_phi_d_raw); } model { - mu0 ~ normal(mu0_mean, mu0_sd); - log_tau ~ normal(log_tau_mean, log_tau_sd); - log_phi ~ normal(log_phi_mean, log_phi_sd); - log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + mu0 ~ normal(mu0_mean, mu0_sd); + log_tau ~ normal(log_tau_mean, log_tau_sd); + log_phi0 ~ normal(log_phi_mean, log_phi_sd); + log_omega ~ normal(log_omega_mean, log_omega_sd); + log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + log_phi_d_raw ~ std_normal(); loc_d_raw ~ std_normal(); for (d in 1:n_datasets) { real loc = loc_d[d]; + real phi = phi_d[d]; int n = n_obs[d]; if (summary_type[d] == 1) { // median + range (min, max), rounded to `resolution[d]` int k_median = (n + 1) %/% 2; - target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); - target += order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); - target += order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d], n_panels_stat1[d]); + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d], n_panels_stat2[d]); + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d], n_panels_stat3[d]); } else if (summary_type[d] == 2) { // median + IQR (q25, q75), rounded to `resolution[d]` int k_median = (n + 1) %/% 2; - target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d], n_panels_stat1[d]); int k_q25 = (n + 1) %/% 4; if (k_q25 < 1) k_q25 = 1; - target += order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d], n_panels_stat2[d]); int k_q75 = (3 * (n + 1)) %/% 4; if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - target += order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d], n_panels_stat3[d]); } else if (summary_type[d] == 3) { // mean + sd @@ -611,11 +650,12 @@ model { int moments_ok = 1; if (dist_type == 1) { // lognormal - real omega = exp(phi^2); + real w_ln = exp(phi^2); // named w_ln, not omega, to avoid shadowing the + // model-level between-study dispersion SD mean_d = exp(loc + phi^2 / 2); - var_d = mean_d^2 * (omega - 1); - mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; - mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + var_d = mean_d^2 * (w_ln - 1); + mu3 = (w_ln + 2) * (w_ln - 1)^2 * mean_d^3; + mu4 = (w_ln^4 + 2*w_ln^3 + 3*w_ln^2 - 3) * (w_ln - 1)^2 * mean_d^4; } else if (dist_type == 2) { // gamma real shape = phi; @@ -777,7 +817,17 @@ generated quantities { // Rover et al. (2021) doi:10.1002/jrsm.1475 // - When n_datasets >= 5, tau is identifiable; sample from Normal(mu0, tau) // to include between-study heterogeneity. L=2000 for MC stability. + // + // TODO(point 4, task 17): phi is currently evaluated at the population + // mean phi0 only, i.e. these predictive quantities do NOT yet marginalize + // over between-study dispersion heterogeneity (omega), unlike location + // (which already does via loc_sample below). This is a placeholder to + // keep the model compiling after the phi -> phi_d reparameterization; + // fixing it properly (sampling phi alongside loc per Monte Carlo draw, + // mirroring locs <- rnorm(...)) is tracked as its own task since it + // changes Table 1's reported P95/median, not just machinery. { + real phi = phi0; if (n_datasets < 5) { real loc_pred = mean(loc_d); @@ -958,13 +1008,14 @@ generated quantities { for (d in 1:n_datasets) { real loc = loc_d[d]; + real phi = phi_d[d]; int n = n_obs[d]; if (summary_type[d] == 1) { // median + range int k_median = (n + 1) %/% 2; - log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); - log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); - log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d], n_panels_stat1[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d], n_panels_stat2[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d], n_panels_stat3[d]); } else if (summary_type[d] == 2) { // median + IQR int k_median = (n + 1) %/% 2; @@ -974,9 +1025,9 @@ generated quantities { if (k_q75 <= k_q25) k_q75 = k_q25 + 1; if (k_q75 > n) k_q75 = n; - log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); - log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); - log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d], n_panels_stat1[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d], n_panels_stat2[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d], n_panels_stat3[d]); } else if (summary_type[d] == 3) { // mean + sd (see model block for derivation) real mean_d; @@ -986,11 +1037,11 @@ generated quantities { int moments_ok = 1; if (dist_type == 1) { - real omega = exp(phi^2); + real w_ln = exp(phi^2); // named w_ln, not omega; see model block mean_d = exp(loc + phi^2 / 2); - var_d = mean_d^2 * (omega - 1); - mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; - mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + var_d = mean_d^2 * (w_ln - 1); + mu3 = (w_ln + 2) * (w_ln - 1)^2 * mean_d^3; + mu4 = (w_ln^4 + 2*w_ln^3 + 3*w_ln^2 - 3) * (w_ln - 1)^2 * mean_d^4; } else if (dist_type == 2) { real shape = phi; diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan index 7dd7de4..8c85843 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan @@ -472,9 +472,17 @@ data { real log_tau_mean; real log_tau_sd; + // log_phi0 is the population-mean log dispersion; per-study dispersion + // phi_d is hierarchical (see log_omega below), not a shared scalar. real log_phi_mean; real log_phi_sd; + // omega is the between-study SD of log dispersion (log_phi_d), analogous + // to tau for location. See hierarchical_data_synthesis_summary_stats.stan + // for the default value and how it was chosen. + real log_omega_mean; + real log_omega_sd; + real log_kappa_mean; real log_kappa_sd; } @@ -550,28 +558,38 @@ transformed data { parameters { real mu0; real log_tau; - real log_phi; + real log_phi0; + real log_omega; real log_kappa; vector[n_datasets] loc_d_raw; + vector[n_datasets] log_phi_d_raw; } transformed parameters { - real tau = exp(log_tau); - real phi = exp(log_phi); - real kappa = exp(log_kappa); + real tau = exp(log_tau); + real phi0 = exp(log_phi0); + real omega = exp(log_omega); + real kappa = exp(log_kappa); vector[n_datasets] loc_d = mu0 + tau * loc_d_raw; + // Per-study dispersion. kappa stays shared: see Appendix B of + // vignettes/gg_identifiability.Rmd (rank-1 type-3 profile Fisher + // information for the shape pair). + vector[n_datasets] phi_d = exp(log_phi0 + omega * log_phi_d_raw); } model { - mu0 ~ normal(mu0_mean, mu0_sd); - log_tau ~ normal(log_tau_mean, log_tau_sd); - log_phi ~ normal(log_phi_mean, log_phi_sd); - log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + mu0 ~ normal(mu0_mean, mu0_sd); + log_tau ~ normal(log_tau_mean, log_tau_sd); + log_phi0 ~ normal(log_phi_mean, log_phi_sd); + log_omega ~ normal(log_omega_mean, log_omega_sd); + log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + log_phi_d_raw ~ std_normal(); loc_d_raw ~ std_normal(); for (d in 1:n_datasets) { real loc = loc_d[d]; + real phi = phi_d[d]; int n = n_obs[d]; if (summary_type[d] == 1) { // median + range: joint density of (min, median, max), rounded @@ -603,11 +621,12 @@ model { int moments_ok = 1; if (dist_type == 1) { // lognormal - real omega = exp(phi^2); + real w_ln = exp(phi^2); // named w_ln, not omega, to avoid shadowing the + // model-level between-study dispersion SD mean_d = exp(loc + phi^2 / 2); - var_d = mean_d^2 * (omega - 1); - mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; - mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + var_d = mean_d^2 * (w_ln - 1); + mu3 = (w_ln + 2) * (w_ln - 1)^2 * mean_d^3; + mu4 = (w_ln^4 + 2*w_ln^3 + 3*w_ln^2 - 3) * (w_ln - 1)^2 * mean_d^4; } else if (dist_type == 2) { // gamma real shape = phi; @@ -741,7 +760,12 @@ generated quantities { // idx+2 are set to 0, since the joint density cannot be decomposed per statistic). vector[n_datasets * 3] log_lik; + // TODO(point 4, task 17): phi is currently evaluated at the population + // mean phi0 only; these predictive quantities do not yet marginalize over + // between-study dispersion heterogeneity (omega). See the matching TODO + // in hierarchical_data_synthesis_summary_stats.stan. { + real phi = phi0; if (n_datasets < 5) { real loc_pred = mean(loc_d); @@ -914,6 +938,7 @@ generated quantities { for (d in 1:n_datasets) { real loc = loc_d[d]; + real phi = phi_d[d]; int n = n_obs[d]; if (summary_type[d] == 1) { // joint density of (min, median, max), rounded @@ -947,11 +972,11 @@ generated quantities { int moments_ok = 1; if (dist_type == 1) { - real omega = exp(phi^2); + real w_ln = exp(phi^2); // named w_ln, not omega; see model block mean_d = exp(loc + phi^2 / 2); - var_d = mean_d^2 * (omega - 1); - mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; - mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + var_d = mean_d^2 * (w_ln - 1); + mu3 = (w_ln + 2) * (w_ln - 1)^2 * mean_d^3; + mu4 = (w_ln^4 + 2*w_ln^3 + 3*w_ln^2 - 3) * (w_ln - 1)^2 * mean_d^4; } else if (dist_type == 2) { real shape = phi; diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan new file mode 100644 index 0000000..a2fdd48 --- /dev/null +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan @@ -0,0 +1,1091 @@ +// hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan +// +// Pre-point-4 variant of the joint model, kept alongside the hierarchical +// version for the same reason as hierarchical_data_synthesis_summary_stats_ +// shared_phi.stan: a single shared scalar `phi` per pathogen, used for gamma +// (POINT4_LIKELIHOOD_MATHS.md Part E.5). See that file's header for the full +// rationale. +// +// Identical to hierarchical_data_synthesis_summary_stats.stan except that +// summary types 1 (median+range) and 2 (median+IQR) use the joint density of +// three order statistics rather than the product of their marginals. +// +// The joint density of order statistics X_(i1) < X_(i2) < X_(i3) from n IID +// observations with CDF F and density f is: +// +// f(x1,x2,x3) = n! / [(i1-1)! (i2-i1-1)! (i3-i2-1)! (n-i3)!] +// * F(x1)^{i1-1} * f(x1) +// * [F(x2)-F(x1)]^{i2-i1-1} * f(x2) +// * [F(x3)-F(x2)]^{i3-i2-1} * f(x3) +// * [1-F(x3)]^{n-i3} +// +// Gap terms with zero exponent are omitted to avoid 0*(-Inf) = NaN. +// Gaps are computed via log_diff_exp for numerical stability. + +functions { + // CDF for each distribution + real dist_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + if (dist_type == 1) { // lognormal + return lognormal_cdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real shape = phi; + real rate = shape / mean_d; + return gamma_cdf(x | shape, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + real shape = phi; + return weibull_cdf(x | shape, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + return -expm1(-kappa * log1p_exp(phi * u)); + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_cdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return 0; + } + + // "log pdf" for each distribution + real dist_logpdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + if (dist_type == 1) { // lognormal + return lognormal_lpdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real shape = phi; + real rate = shape / mean_d; + return gamma_lpdf(x | shape, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + real shape = phi; + return weibull_lpdf(x | shape, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + real log_term = log1p_exp(phi * u); // log(1 + (x/lambda)^c) + return log(phi) + log(kappa) + (phi - 1) * u - loc - (kappa + 1) * log_term; + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return log(kappa) - log(phi) - log(x) + + gamma_shape * log(gamma_shape) + + gamma_shape * kappa * w + - gamma_shape * exp(kappa * w) + - lgamma(gamma_shape); + } + return 0; + } + + // Log-scale CDF for each distribution. + real dist_log_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // F_D(0) = 0 for every family here (support starts at 0), handled as an + // exact special case rather than the general per-family formula below. + // For Burr XII/generalised gamma (and empirically, Weibull's own + // weibull_lcdf), that formula involves u = exp(shape * log(x/scale)); + // differentiating w.r.t. shape gives a factor of log(x/scale), which at + // x=0 is -Inf * 0 = NaN even though the true limit is 0 (a removable + // singularity). Verified this bypass leaves log-likelihood values + // unchanged on non-zero x, while giving finite gradients at x=0 for all + // 5 families. + if (x <= 0) return negative_infinity(); + if (dist_type == 1) { // lognormal + return lognormal_lcdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real rate = phi / mean_d; + return gamma_lcdf(x | phi, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + return weibull_lcdf(x | phi, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + return log1m_exp(-kappa * log1p_exp(phi * u)); + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_lcdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return negative_infinity(); + } + + // Log-scale CCDF (log survivor function) for each distribution. + real dist_log_ccdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // 1 - F_D(0) = 1 for every family here; see dist_log_cdf_fun for why this + // must be special-cased rather than left to the general formula. + if (x <= 0) return 0; + if (dist_type == 1) { // lognormal + return lognormal_lccdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real rate = phi / mean_d; + return gamma_lccdf(x | phi, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + return weibull_lccdf(x | phi, scale); + } else if (dist_type == 4) { // burr XII: log CCDF = -k * log(1 + (x/lambda)^c) + real u = log(x) - loc; + return -kappa * log1p_exp(phi * u); + } else if (dist_type == 5) { // generalised gamma (Prentice) + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_lccdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return negative_infinity(); + } + + // Joint log density of three order statistics x1 < x2 < x3 with ranks + // i1 < i2 < i3 from a sample of size n. + // + // log f(x1,x2,x3) = log_nc + // + (i1-1)*log_F(x1) [omitted when i1==1] + // + log_f(x1) + // + (i2-i1-1)*log[F(x2)-F(x1)] [omitted when i2-i1==1] + // + log_f(x2) + // + (i3-i2-1)*log[F(x3)-F(x2)] [omitted when i3-i2==1] + // + log_f(x3) + // + (n-i3)*log[1-F(x3)] [omitted when i3==n] + // + // where log_nc = lgamma(n+1) - lgamma(i1) - lgamma(i2-i1) - lgamma(i3-i2) + // - lgamma(n-i3+1) + real joint_3_order_stat_logpdf( + real x1, real x2, real x3, + int i1, int i2, int i3, + int n, + int dist_type, real loc, real phi, real kappa + ) { + if (x1 >= x2 || x2 >= x3) return negative_infinity(); + + real log_nc = lgamma(n + 1) + - lgamma(i1) + - lgamma(i2 - i1) + - lgamma(i3 - i2) + - lgamma(n - i3 + 1); + + real log_f1 = dist_logpdf_fun(x1, dist_type, loc, phi, kappa); + real log_f2 = dist_logpdf_fun(x2, dist_type, loc, phi, kappa); + real log_f3 = dist_logpdf_fun(x3, dist_type, loc, phi, kappa); + + real log_F1 = dist_log_cdf_fun(x1, dist_type, loc, phi, kappa); + real log_F2 = dist_log_cdf_fun(x2, dist_type, loc, phi, kappa); + real log_F3 = dist_log_cdf_fun(x3, dist_type, loc, phi, kappa); + real log_1mF3 = dist_log_ccdf_fun(x3, dist_type, loc, phi, kappa); + + real lp = log_nc + log_f1 + log_f2 + log_f3; + + if (i1 > 1) lp += (i1 - 1) * log_F1; + if (i2 - i1 > 1) lp += (i2 - i1 - 1) * log_diff_exp(log_F2, log_F1); + if (i3 - i2 > 1) lp += (i3 - i2 - 1) * log_diff_exp(log_F3, log_F2); + if (i3 < n) lp += (n - i3) * log_1mF3; + + return lp; + } + + // Rounded log-likelihood for the joint density of 3 order statistics: + // integrates joint_3_order_stat_logpdf over a box of width `resolution` + // around each reported (rounded) value, via 5-point-per-dimension tensor + // Gauss-Legendre quadrature (125 nodes). Validated in R against a nested + // adaptive-quadrature reference (Burr XII, n=15, resolution=1): relative + // error ~5e-8, versus ~1e-4 at 3 points/dimension: 5 points gives a + // comfortable safety margin at a still-modest node count. Lower bounds are + // clamped just above 0 since delays are non-negative (only relevant for + // the smallest of the three statistics, e.g. the reported min). + // + // Loses accuracy (~9% error in a case checked in the code review) when two + // of the three reported statistics are within `resolution` of each other, + // since joint_3_order_stat_logpdf's ordering constraint (x1 0) || !(vy > 0) || !(det > 0) || !(det < positive_infinity())) { + return negative_infinity(); + } + real dx = x - mx; + real dy = y - my; + real quad = (dx * dx * vy - 2 * dx * dy * cxy + dy * dy * vx) / det; + return -log(2 * pi()) - 0.5 * log(det) - 0.5 * quad; + } + + // Helper function to compute gamma quantile approximation + real gamma_quantile_approx(real p, real shape, real scale) { + real z = inv_Phi(p); + if (shape > 1) { + return shape * scale * pow(1 - 1.0/(9*shape) + z/(3*sqrt(shape)), 3); + } else { + return shape * scale * (1 + z / sqrt(shape)); + } + } + + // Log of integral_{ex_l}^{ex_r} F_D(T - e) de: truncation denominator + // for type 7 (right-truncated, doubly censored). Uses 7-point GL quadrature. + // Degenerates to log F_D(T - ex_l) when ex_l == ex_r (point exposure). + real trunc_denom_log(real ex_l, real ex_r, real T, + int dist_type, real loc, real phi, real kappa) { + if (ex_l == ex_r) { + return dist_log_cdf_fun(T - ex_l, dist_type, loc, phi, kappa); + } + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + real max_del = T - e_k; + log_terms[k] = log(w[k]) + dist_log_cdf_fun(max_del, dist_type, loc, phi, kappa); + } + return log_sum_exp(log_terms); + } + + // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de: right-censored contribution + // for type 7 (onset not yet observed by T). Uses 7-point GL quadrature. + real right_censor_log_lik(real ex_l, real ex_r, real T, + int dist_type, real loc, real phi, real kappa) { + if (ex_l == ex_r) { + return log1m_exp(dist_log_cdf_fun(T - ex_l, dist_type, loc, phi, kappa)); + } + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + real max_del = T - e_k; + log_terms[k] = log(w[k]) + log1m_exp(dist_log_cdf_fun(max_del, dist_type, loc, phi, kappa)); + } + return log_sum_exp(log_terms); + } + + // Double-censored log-likelihood for one observation (summary type 6). + // Identical to the version in hierarchical_data_synthesis_summary_stats.stan. + real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, + int dist_type, real loc, real phi, real kappa, real resolution) { + // 7-point Gauss-Legendre nodes/weights on [-1, 1] (Abramowitz & Stegun + // table 25.4), shared by every case below. Every case quadratures over + // the exposure side (its genuinely reported window in Cases 2-4, or a + // resolution-wide window standing in for a point report in Cases 1/3), + // treating the event side as a closed-form probability at each exposure + // node: dist_log_cdf_fun's CDF-difference when event is a genuine + // window (Cases 2, 4), or rounded_freq_loglik_fun's resolution-wide + // probability when event is itself a point report (Cases 1, 3). This + // keeps every case's Jacobian-dropping convention identical to Case 4's + // pre-existing one: calling this function with a point widened to its + // own resolution window gives the exact same result, node for node, as + // calling Case 4 directly with that window as an explicit interval. + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real half_res = resolution / 2; + + // Case 1: both endpoints point-observed. Exposure and event are each + // independently day-rounded, so the delay's implied distribution is the + // convolution of two independent Uniform(-resolution/2, resolution/2) + // rounding errors: a triangular kernel of half-width `resolution`, not + // the single rounded_freq_loglik_fun evaluation used before. Integrating + // out the exposure side analytically collapses the general double + // integral to this 1D quadrature over rounded_freq_loglik_fun exactly, + // no approximation in that reduction step. + if (ex_l == ex_r && ev_l == ev_r) { + real d = ev_l - ex_l; + array[7] real log_terms; + for (k in 1:7) { + real v_k = half_res * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(d - v_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 2: point exposure, interval event. Exposure is day-rounded; event + // stays exactly as reported (a genuine censoring window, not itself + // rounded further). Quadrature averages the point-exposure formula over + // exposure's own rounding window instead of evaluating it once at the + // exact reported value. + if (ex_l == ex_r) { + array[7] real log_terms; + for (k in 1:7) { + real e_k = ex_l + half_res * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } + // Case 3: interval exposure, point event. Quadrature over the genuinely + // reported exposure window, exactly like Case 4, but with the event + // side's closed-form CDF-difference replaced by rounded_freq_loglik_fun + // (event is itself a point report, standing in for its own resolution + // window) instead of the exact reported event window Case 4 uses. + if (ev_l == ev_r) { + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(ev_l - e_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 4: both interval-censored (quadrature on [ex_l, ex_r]). + // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } +} + +data { + int n_datasets; + array[n_datasets] int n_obs; + array[n_datasets] int summary_type; // 1=median+range, 2=median+IQR, 3=mean+sd, 4=raw freq table, 5=interval-censored freq table, 6=double interval-censored freq table, 7=double interval-censored with right truncation/censoring + int dist_type; + + array[n_datasets] real obs_stat1; + array[n_datasets] real obs_stat2; + array[n_datasets] real obs_stat3; + + // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see + // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported + // order statistics), summary_type 4/5 (raw/degenerate frequency-table + // counts), and summary_type 6/7's dc_log_lik whenever exposure and/or + // event is point-observed (Cases 1-3), all treated as rounded values. + // Ignored for summary_type 3 (populate with 1, unused). + array[n_datasets] real resolution; + + int n_freq_total; + array[n_freq_total] real freq_value; + array[n_freq_total] int freq_count; + array[n_datasets] int freq_start; + array[n_datasets] int freq_len; + + array[n_freq_total] real freq_lower; + array[n_freq_total] real freq_upper; + + // Event window bounds for summary_type == 6 and 7 (double interval-censored). + // For all other summary types these arrays are populated with zeros. + // For types 6 and 7, freq_lower / freq_upper carry the exposure window (expo_lower, expo_upper). + array[n_freq_total] real event_lower; // lower bound of event window; 0 for right-censored (type 7) + array[n_freq_total] real event_upper; // upper bound of event window; 0 for right-censored (type 7) + + // Type 7: right truncation / right censoring. + // event_observed[i] = 1 if onset was recorded, 0 if right-censored (onset not yet seen). + // truncation_time[d] = analysis date T in days from the reference date; ignored for other types. + // T is a study-design cutoff, not a rounded observation of a random event + // time, so it is never treated as day-rounded the way exposure/event + // windows are (see resolution, above). Set it using the same + // time-encoding convention as that dataset's own windows. + array[n_freq_total] int event_observed; // 1=onset seen, 0=right-censored + array[n_datasets] real truncation_time; // analysis date T per dataset + + real mu0_mean; + real mu0_sd; + + real log_tau_mean; + real log_tau_sd; + + real log_phi_mean; + real log_phi_sd; + + real log_kappa_mean; + real log_kappa_sd; +} + +transformed data { + real z_q25 = -0.6745; + real z_q75 = 0.6745; + real z_q90 = 1.28155; + real z_q95 = 1.64485; + + // Non-strict (<=), matching the factorised model: day-rounding a + // short-incubation dataset routinely produces exact ties between + // reported statistics (e.g. Q1 == median), which a strict check would + // reject and abort the entire fit on. joint_3_order_stat_rounded_loglik + // still loses accuracy near (but not at) a tie; see its docstring and + // REVISION_TODO.md. + for (d in 1:n_datasets) { + if (summary_type[d] == 1) { + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=1, must have min <= median <= max"); + } + if (resolution[d] <= 0) { + reject("For summary_type=1, resolution must be > 0"); + } + } else if (summary_type[d] == 2) { + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=2, must have q25 <= median <= q75"); + } + if (resolution[d] <= 0) { + reject("For summary_type=2, resolution must be > 0"); + } + } else if (summary_type[d] == 3) { + // A sample SD is undefined for a single observation; the mean/SD + // likelihood also divides by (n-1), which is degenerate at n=1. + if (n_obs[d] < 2) { + reject("For summary_type=3, n_obs must be >= 2 (a sample SD requires at least 2 observations)"); + } + } else if (summary_type[d] == 4) { + if (freq_len[d] == 0) { + reject("For summary_type=4, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=4, resolution must be > 0"); + } + } else if (summary_type[d] == 5) { + if (freq_len[d] == 0) { + reject("For summary_type=5, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=5, resolution must be > 0"); + } + } else if (summary_type[d] == 6) { + if (freq_len[d] == 0) { + reject("For summary_type=6, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=6, resolution must be > 0"); + } + } else if (summary_type[d] == 7) { + if (freq_len[d] == 0) { + reject("For summary_type=7, freq_len must be > 0"); + } + if (truncation_time[d] <= 0) { + reject("For summary_type=7, truncation_time must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=7, resolution must be > 0"); + } + } + } +} + +parameters { + real mu0; + real log_tau; + real log_phi; + real log_kappa; + vector[n_datasets] loc_d_raw; +} + +transformed parameters { + real tau = exp(log_tau); + real phi = exp(log_phi); + real kappa = exp(log_kappa); + vector[n_datasets] loc_d = mu0 + tau * loc_d_raw; +} + +model { + mu0 ~ normal(mu0_mean, mu0_sd); + log_tau ~ normal(log_tau_mean, log_tau_sd); + log_phi ~ normal(log_phi_mean, log_phi_sd); + log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + + loc_d_raw ~ std_normal(); + + for (d in 1:n_datasets) { + real loc = loc_d[d]; + int n = n_obs[d]; + + if (summary_type[d] == 1) { // median + range: joint density of (min, median, max), rounded + int k_median = (n + 1) %/% 2; + target += joint_3_order_stat_rounded_loglik( + obs_stat2[d], obs_stat1[d], obs_stat3[d], // x1=min, x2=median, x3=max + 1, k_median, n, // i1=1, i2=k_median, i3=n + n, dist_type, loc, phi, kappa, resolution[d]); + } + + else if (summary_type[d] == 2) { // median + IQR: joint density of (q25, median, q75), rounded + int k_median = (n + 1) %/% 2; + int k_q25 = (n + 1) %/% 4; + if (k_q25 < 1) k_q25 = 1; + int k_q75 = (3 * (n + 1)) %/% 4; + if (k_q75 <= k_q25) k_q75 = k_q25 + 1; + if (k_q75 > n) k_q75 = n; + target += joint_3_order_stat_rounded_loglik( + obs_stat2[d], obs_stat1[d], obs_stat3[d], // x1=q25, x2=median, x3=q75 + k_q25, k_median, k_q75, + n, dist_type, loc, phi, kappa, resolution[d]); + } + + else if (summary_type[d] == 3) { // mean + sd (identical to factorised model, see there for derivation) + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; + + if (dist_type == 1) { // lognormal + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + + } else if (dist_type == 2) { // gamma + real shape = phi; + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + + } else if (dist_type == 3) { // weibull + real shape = phi; + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + // 4th moment (needed for Var(S^2)) requires k*c > 4, stricter than + // the k*c > 2 needed for the variance alone. + if (kappa * phi <= 4.0) { + moments_ok = 0; + target += negative_infinity(); + } else { + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + target += bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } + } + + else if (summary_type[d] == 4) { // raw frequency table + // Each distinct observed value is treated as rounded to the nearest + // multiple of `resolution` days, not as an exact continuous observation. + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + target += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); + } + } + + else if (summary_type[d] == 5) { // interval-censored frequency table + // When lower == upper (no reported range), the value is treated as a + // rounded point observation, like summary_type 4. + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + if (freq_lower[i] == freq_upper[i]) { + target += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); + } else { + real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); + real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + target += freq_count[i] * log_diff_exp(log_cdf_u, log_cdf_l); + } + } + } + + else if (summary_type[d] == 6) { // double interval-censored frequency table + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + target += freq_count[i] * dc_log_lik( + freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d] + ); + } + } + + else if (summary_type[d] == 7) { // double interval-censored + right truncation/censoring + int s = freq_start[d]; + int len = freq_len[d]; + real T = truncation_time[d]; + for (i in s:(s + len - 1)) { + if (event_observed[i] == 1) { + target += freq_count[i] * ( + dc_log_lik(freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d]) + - trunc_denom_log(freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa) + ); + } else { + target += freq_count[i] * right_censor_log_lik( + freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa + ); + } + } + } + } +} + +generated quantities { + real pred_mean; + real pred_median; + real pred_q25; + real pred_q75; + real pred_q90; + real pred_q95; + real pred_sd; + // Joint log-likelihood per dataset (3 slots each for interface compatibility; + // for types 1 and 2 the joint value is stored in slot idx and slots idx+1, + // idx+2 are set to 0, since the joint density cannot be decomposed per statistic). + vector[n_datasets * 3] log_lik; + + { + if (n_datasets < 5) { + real loc_pred = mean(loc_d); + + if (dist_type == 1) { // lognormal + pred_mean = exp(loc_pred + phi^2 / 2); + pred_median = exp(loc_pred); + pred_q25 = exp(loc_pred - 0.6745 * phi); + pred_q75 = exp(loc_pred + 0.6745 * phi); + pred_q90 = exp(loc_pred + 1.28155 * phi); + pred_q95 = exp(loc_pred + 1.64485 * phi); + pred_sd = sqrt((exp(phi^2) - 1) * exp(2 * loc_pred + phi^2)); + + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc_pred); + real scale_param = mean_d / phi; + pred_mean = mean_d; + pred_sd = sqrt(mean_d * scale_param); + pred_median = gamma_quantile_approx(0.5, phi, scale_param); + pred_q25 = gamma_quantile_approx(0.25, phi, scale_param); + pred_q75 = gamma_quantile_approx(0.75, phi, scale_param); + pred_q90 = gamma_quantile_approx(0.90, phi, scale_param); + pred_q95 = gamma_quantile_approx(0.95, phi, scale_param); + + } else if (dist_type == 3) { // weibull + real scale = exp(loc_pred); + pred_mean = scale * tgamma(1 + 1.0 / phi); + pred_median = scale * pow(log(2), 1.0 / phi); + pred_q25 = scale * pow(log(4.0 / 3.0), 1.0 / phi); + pred_q75 = scale * pow(log(4.0), 1.0 / phi); + pred_q90 = scale * pow(log(10.0), 1.0 / phi); + pred_q95 = scale * pow(log(20.0), 1.0 / phi); + pred_sd = sqrt(scale^2 * (tgamma(1 + 2.0/phi) - pow(tgamma(1 + 1.0/phi), 2))); + + } else if (dist_type == 4) { // burr XII + real lam = exp(loc_pred); + pred_median = lam * pow(pow(0.5, -1.0/kappa) - 1.0, 1.0/phi); + pred_q25 = lam * pow(pow(0.75, -1.0/kappa) - 1.0, 1.0/phi); + pred_q75 = lam * pow(pow(0.25, -1.0/kappa) - 1.0, 1.0/phi); + pred_q90 = lam * pow(pow(0.10, -1.0/kappa) - 1.0, 1.0/phi); + pred_q95 = lam * pow(pow(0.05, -1.0/kappa) - 1.0, 1.0/phi); + if (kappa * phi > 1.0) { + pred_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); + } else { + pred_mean = positive_infinity(); + } + if (kappa * phi > 2.0) { + real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); + pred_sd = sqrt(fabs(e2 - pred_mean^2)); + } else { + pred_sd = positive_infinity(); + } + + } else if (dist_type == 5) { // generalised gamma: Monte Carlo via gamma_rng + int L_gg = 200; + vector[L_gg] gg_samples; + real gs = 1.0 / (kappa * kappa); + for (l in 1:L_gg) { + real y = gamma_rng(gs, 1); + gg_samples[l] = exp(loc_pred + phi / kappa * log(kappa * kappa * y)); + } + gg_samples = sort_asc(gg_samples); + pred_mean = mean(gg_samples); + pred_sd = sd(gg_samples); + pred_median = gg_samples[100]; + pred_q25 = gg_samples[50]; + pred_q75 = gg_samples[150]; + pred_q90 = gg_samples[180]; + pred_q95 = gg_samples[190]; + } + + } else { + int L = 2000; + + if (dist_type == 5) { + int L_gg = 200; + vector[L_gg] gg_t_samples; + real gs = 1.0 / (kappa * kappa); + for (l in 1:L_gg) { + real loc_sample = normal_rng(mu0, tau); + real y = gamma_rng(gs, 1); + gg_t_samples[l] = exp(loc_sample + phi / kappa * log(kappa * kappa * y)); + } + gg_t_samples = sort_asc(gg_t_samples); + pred_mean = mean(gg_t_samples); + pred_sd = sd(gg_t_samples); + pred_median = gg_t_samples[100]; + pred_q25 = gg_t_samples[50]; + pred_q75 = gg_t_samples[150]; + pred_q90 = gg_t_samples[180]; + pred_q95 = gg_t_samples[190]; + + } else { + vector[L] means; + vector[L] medians; + vector[L] q25s; + vector[L] q75s; + vector[L] q90s; + vector[L] q95s; + vector[L] sds; + + for (l in 1:L) { + real loc_sample = normal_rng(mu0, tau); + + if (dist_type == 1) { // lognormal + means[l] = exp(loc_sample + phi^2 / 2); + medians[l] = exp(loc_sample); + q25s[l] = exp(loc_sample - 0.6745 * phi); + q75s[l] = exp(loc_sample + 0.6745 * phi); + q90s[l] = exp(loc_sample + 1.28155 * phi); + q95s[l] = exp(loc_sample + 1.64485 * phi); + sds[l] = sqrt((exp(phi^2) - 1) * exp(2 * loc_sample + phi^2)); + + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc_sample); + real scale_param = mean_d / phi; + means[l] = mean_d; + sds[l] = sqrt(mean_d * scale_param); + medians[l] = gamma_quantile_approx(0.5, phi, scale_param); + q25s[l] = gamma_quantile_approx(0.25, phi, scale_param); + q75s[l] = gamma_quantile_approx(0.75, phi, scale_param); + q90s[l] = gamma_quantile_approx(0.90, phi, scale_param); + q95s[l] = gamma_quantile_approx(0.95, phi, scale_param); + + } else if (dist_type == 3) { // weibull + real scale = exp(loc_sample); + means[l] = scale * tgamma(1 + 1.0 / phi); + medians[l] = scale * pow(log(2), 1.0 / phi); + q25s[l] = scale * pow(log(4.0 / 3.0), 1.0 / phi); + q75s[l] = scale * pow(log(4.0), 1.0 / phi); + q90s[l] = scale * pow(log(10.0), 1.0 / phi); + q95s[l] = scale * pow(log(20.0), 1.0 / phi); + real var_weib = scale^2 * (tgamma(1 + 2.0/phi) - pow(tgamma(1 + 1.0/phi), 2)); + sds[l] = sqrt(var_weib); + + } else if (dist_type == 4) { // burr XII + real lam_l = exp(loc_sample); + medians[l] = lam_l * pow(pow(0.5, -1.0/kappa) - 1.0, 1.0/phi); + q25s[l] = lam_l * pow(pow(0.75, -1.0/kappa) - 1.0, 1.0/phi); + q75s[l] = lam_l * pow(pow(0.25, -1.0/kappa) - 1.0, 1.0/phi); + q90s[l] = lam_l * pow(pow(0.10, -1.0/kappa) - 1.0, 1.0/phi); + q95s[l] = lam_l * pow(pow(0.05, -1.0/kappa) - 1.0, 1.0/phi); + if (kappa * phi > 1.0) { + means[l] = lam_l * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); + } else { + means[l] = positive_infinity(); + } + if (kappa * phi > 2.0) { + real e2_l = lam_l^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); + sds[l] = (kappa * phi > 1.0) ? sqrt(fabs(e2_l - means[l]^2)) : positive_infinity(); + } else { + sds[l] = positive_infinity(); + } + } + } + + pred_mean = mean(means); + pred_median = mean(medians); + pred_q25 = mean(q25s); + pred_q75 = mean(q75s); + pred_q90 = mean(q90s); + pred_q95 = mean(q95s); + pred_sd = mean(sds); + } + } + } + + // Log likelihood + { + int idx = 1; + + for (d in 1:n_datasets) { + real loc = loc_d[d]; + int n = n_obs[d]; + + if (summary_type[d] == 1) { // joint density of (min, median, max), rounded + int k_median = (n + 1) %/% 2; + log_lik[idx] = joint_3_order_stat_rounded_loglik( + obs_stat2[d], obs_stat1[d], obs_stat3[d], + 1, k_median, n, + n, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = 0; + log_lik[idx + 2] = 0; + + } else if (summary_type[d] == 2) { // joint density of (q25, median, q75), rounded + int k_median = (n + 1) %/% 2; + int k_q25 = (n + 1) %/% 4; + if (k_q25 < 1) k_q25 = 1; + int k_q75 = (3 * (n + 1)) %/% 4; + if (k_q75 <= k_q25) k_q75 = k_q25 + 1; + if (k_q75 > n) k_q75 = n; + log_lik[idx] = joint_3_order_stat_rounded_loglik( + obs_stat2[d], obs_stat1[d], obs_stat3[d], + k_q25, k_median, k_q75, + n, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = 0; + log_lik[idx + 2] = 0; + + } else if (summary_type[d] == 3) { // mean + sd (see model block for derivation) + real mean_d; + real var_d; + real mu3; + real mu4; + int moments_ok = 1; + + if (dist_type == 1) { + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + + } else if (dist_type == 2) { + real shape = phi; + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + + } else if (dist_type == 3) { + real shape = phi; + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + + } else if (dist_type == 4) { + if (kappa * phi <= 4.0) { + moments_ok = 0; + } else { + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + } else if (dist_type == 5) { + real gamma_shape = 1.0 / (kappa * kappa); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + log_lik[idx] = bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } else { + log_lik[idx] = negative_infinity(); + } + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + + } else if (summary_type[d] == 4) { // raw frequency table + real ll_type4 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + ll_type4 += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); + } + log_lik[idx] = ll_type4; + log_lik[idx + 1] = 0; + log_lik[idx + 2] = 0; + + } else if (summary_type[d] == 5) { // interval-censored frequency table + real ll_type5 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + if (freq_lower[i] == freq_upper[i]) { + ll_type5 += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); + } else { + real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); + real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + ll_type5 += freq_count[i] * log_diff_exp(log_cdf_u, log_cdf_l); + } + } + log_lik[idx] = ll_type5; + log_lik[idx + 1] = 0; + log_lik[idx + 2] = 0; + + } else if (summary_type[d] == 6) { // double interval-censored frequency table + real ll_type6 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + ll_type6 += freq_count[i] * dc_log_lik( + freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d] + ); + } + log_lik[idx] = ll_type6; + log_lik[idx + 1] = 0; + log_lik[idx + 2] = 0; + + } else if (summary_type[d] == 7) { // double interval-censored + right truncation/censoring + real ll_type7 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + real T = truncation_time[d]; + for (i in s:(s + len - 1)) { + if (event_observed[i] == 1) { + ll_type7 += freq_count[i] * ( + dc_log_lik(freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d]) + - trunc_denom_log(freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa) + ); + } else { + ll_type7 += freq_count[i] * right_censor_log_lik( + freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa + ); + } + } + log_lik[idx] = ll_type7; + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + } + + idx += 3; + } + } +} diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan new file mode 100644 index 0000000..f5fff47 --- /dev/null +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan @@ -0,0 +1,1140 @@ +// hierarchical_data_synthesis_summary_stats_shared_phi.stan +// +// Pre-point-4 variant, deliberately kept alongside the hierarchical model: +// a single shared scalar `phi` per pathogen rather than per-study `phi_d`. +// Identical to hierarchical_data_synthesis_summary_stats.stan as of commit +// ead8803 (before the point-4 phi_d/omega reparameterization). +// +// Used for gamma (POINT4_LIKELIHOOD_MATHS.md Part E.5): gamma's shape +// parameter is a concentration-type parameter whose per-study Fisher +// information about phi vanishes as phi grows (exactly -1/(2*phi), the +// fastest decay of any family in this corpus, compounded by gamma +// currently sitting at the largest fitted phi of any family here), so the +// non-centered phi_d/omega hierarchy creates a genuine funnel for gamma +// rather than just needing a better prior. See Part E.4.1 for the general +// "spread-type vs. concentration-type shape parameter" intuition. +functions { + // CDF for each distribution + real dist_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + if (dist_type == 1) { // lognormal + return lognormal_cdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real shape = phi; + real rate = shape / mean_d; + return gamma_cdf(x | shape, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + real shape = phi; + return weibull_cdf(x | shape, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + return -expm1(-kappa * log1p_exp(phi * u)); + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_cdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return 0; + } + + // "log pdf" for each distribution + real dist_logpdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + if (dist_type == 1) { // lognormal + return lognormal_lpdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real shape = phi; + real rate = shape / mean_d; + return gamma_lpdf(x | shape, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + real shape = phi; + return weibull_lpdf(x | shape, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + real log_term = log1p_exp(phi * u); // log(1 + (x/lambda)^c) + return log(phi) + log(kappa) + (phi - 1) * u - loc - (kappa + 1) * log_term; + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return log(kappa) - log(phi) - log(x) + + gamma_shape * log(gamma_shape) + + gamma_shape * kappa * w + - gamma_shape * exp(kappa * w) + - lgamma(gamma_shape); + } + return 0; + } + + // Log-scale CDF for each distribution. + // Used in order statistic and interval-censored likelihoods to avoid + // probability-scale clipping and catastrophic cancellation. + real dist_log_cdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // F_D(0) = 0 for every family here (support starts at 0), handled as an + // exact special case rather than the general per-family formula below. + // For Burr XII/generalised gamma (and empirically, Weibull's own + // weibull_lcdf), that formula involves u = exp(shape * log(x/scale)); + // differentiating w.r.t. shape gives a factor of log(x/scale), which at + // x=0 is -Inf * 0 = NaN even though the true limit is 0 (a removable + // singularity). Verified this bypass leaves log-likelihood values + // unchanged on non-zero x, while giving finite gradients at x=0 for all + // 5 families. + if (x <= 0) return negative_infinity(); + if (dist_type == 1) { // lognormal + return lognormal_lcdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real rate = phi / mean_d; + return gamma_lcdf(x | phi, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + return weibull_lcdf(x | phi, scale); + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + real u = log(x) - loc; + return log1m_exp(-kappa * log1p_exp(phi * u)); + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_lcdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return negative_infinity(); + } + + // Log-scale CCDF (log survivor function) for each distribution. + real dist_log_ccdf_fun(real x, int dist_type, real loc, real phi, real kappa) { + // 1 - F_D(0) = 1 for every family here; see dist_log_cdf_fun for why this + // must be special-cased rather than left to the general formula. + if (x <= 0) return 0; + if (dist_type == 1) { // lognormal + return lognormal_lccdf(x | loc, phi); + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc); + real rate = phi / mean_d; + return gamma_lccdf(x | phi, rate); + } else if (dist_type == 3) { // weibull + real scale = exp(loc); + return weibull_lccdf(x | phi, scale); + } else if (dist_type == 4) { // burr XII: log CCDF = -k * log(1 + (x/lambda)^c) + real u = log(x) - loc; + return -kappa * log1p_exp(phi * u); + } else if (dist_type == 5) { // generalised gamma (Prentice) + real gamma_shape = 1.0 / (kappa * kappa); + real w = (log(x) - loc) / phi; + return gamma_lccdf(gamma_shape * exp(kappa * w) | gamma_shape, 1); + } + return negative_infinity(); + } + + // Log-density of the k-th order statistic (k out of n observations). + // Fully log-scale: uses _lcdf/_lccdf directly and never exponentiates a + // CDF/CCDF value, so it stays well-conditioned arbitrarily deep in either + // tail. Terms with a zero coefficient are omitted explicitly to avoid + // 0 * (-Inf) = NaN in Stan's autodiff (k==1: coefficient of log_F is 0; + // k==n: coefficient of log_1mF is 0). + real order_stat_logpdf_fun(real x, int n, int k, int dist_type, real loc, real phi, real kappa) { + real log_f = dist_logpdf_fun(x, dist_type, loc, phi, kappa); + real log_F = 0.0; + real log_1mF = 0.0; + if (k > 1) log_F = dist_log_cdf_fun(x, dist_type, loc, phi, kappa); + if (k < n) log_1mF = dist_log_ccdf_fun(x, dist_type, loc, phi, kappa); + + real log_dens = lchoose(n, k) + log_f; + if (k > 1) log_dens += (k - 1) * log_F; + if (k < n) log_dens += (n - k) * log_1mF; + return log_dens; + } + + // Log-likelihood contribution for a reported order statistic that has been + // rounded to the nearest multiple of `resolution` days (1 = whole day, + // 1/24 = hourly, etc.): log P(v - resolution/2 <= X_(k) < v + resolution/2), + // rather than treating v as an exact continuous observation (which discards + // a material part of the uncertainty for short-incubation pathogens). + // Lower bound is clamped just above 0 since delays are non-negative. + // + // Computed by composite Gauss-Legendre quadrature (24 panels x 7-point + // rule = 168 nodes) directly on order_stat_logpdf_fun, entirely in log + // space via log_sum_exp. + // + // This deliberately avoids computing the order-statistic CDF via Stan's + // beta_lcdf(F_D(x) | k, n-k+1): that looks like the natural closed form + // (F_{X(k)}(x) = I_{F_D(x)}(k, n-k+1), the regularized incomplete beta), + // but Stan's beta_lcdf evaluates the incomplete beta on the linear + // probability scale first and only takes its log afterwards, so it + // silently returns -Inf whenever the true value is below ~1e-308, which + // happens routinely for large n even when F_D(x) itself is an entirely + // ordinary, well-represented number (e.g. n=1000, k=500, F_D=0.01 has an + // exact log-CDF of -1618, but beta_lcdf(0.01 | 500, 501) returns -Inf). + // A single-panel Gauss-Legendre rule over the full box has the opposite + // failure mode at large n: the order statistic's own sampling distribution + // can be far narrower than the box (SE ~ 1/sqrt(n)), so a low-order + // polynomial rule cannot resolve it and does not reliably converge with + // more points at a single panel. Composite (multi-panel) quadrature + // resolves both problems: validated in R against a high-precision adaptive + // reference for n = 15 to 50,000 at resolution = 1 (the widest, hence + // hardest to resolve, box this function is used with), both near the mode + // and deep in the tail (the exact regime that broke beta_lcdf); error is + // below 1e-9 near the mode (where posterior mass concentrates) even at + // n=50,000, and the residual error deep in an implausible-parameter tail + // region is at most ~0.02 log-units, immaterial next to a log-density of + // that magnitude (around -450 in the case tested). A narrower box (finer + // resolution) is strictly easier to resolve, since the accuracy problem is + // driven by the box being wide relative to the order statistic's SE. + real order_stat_rounded_loglik_fun(real v, int n, int k, int dist_type, real loc, real phi, real kappa, real resolution) { + int n_panels = 24; + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real half_res = resolution / 2; + real v_lo = fmax(v - half_res, 1e-6); + real v_hi = v + half_res; + real panel_width = (v_hi - v_lo) / n_panels; + array[n_panels * 7] real log_terms; + int idx = 1; + for (p in 1:n_panels) { + real a = v_lo + (p - 1) * panel_width; + real mid = a + 0.5 * panel_width; + real half = 0.5 * panel_width; + for (j in 1:7) { + real x = mid + half * t[j]; + log_terms[idx] = log(w[j]) + log(half) + + order_stat_logpdf_fun(x, n, k, dist_type, loc, phi, kappa); + idx += 1; + } + } + return log_sum_exp(log_terms); + } + + // Log-likelihood contribution for a raw frequency-table count that has + // been rounded to the nearest multiple of `resolution` days: log P(v - + // resolution/2 <= X < v + resolution/2), rather than treating v as an + // exact continuous observation (summary_type 4's freq_value, and + // summary_type 5's degenerate freq_lower==freq_upper point entries). + // This is the same rounding treatment already applied to reported order + // statistics (see order_stat_rounded_loglik_fun), for consistency across + // every summary type where a single reported value stands in for an + // underlying continuous, day-rounded observation. + // + // No explicit clamp is needed on the lower bound, even when it goes + // negative (v < resolution/2): unlike the order statistic case, this uses + // a CDF *difference*, never the point density, so dist_log_cdf_fun's own + // x<=0 special case (identical for any x<=0, negative or not) already + // gives the correct result directly. + real rounded_freq_loglik_fun(real v, int dist_type, real loc, real phi, real kappa, real resolution) { + real half_res = resolution / 2; + return log_diff_exp( + dist_log_cdf_fun(v + half_res, dist_type, loc, phi, kappa), + dist_log_cdf_fun(v - half_res, dist_type, loc, phi, kappa) + ); + } + + // Log-density of a bivariate normal with mean (mx, my), variances (vx, vy) + // and covariance cxy. Used for the joint mean/SD likelihood (summary_type + // 3), which needs a nonzero covariance term for every right-skewed family + // used here. + // + // Guards against a non-positive-definite or non-finite covariance (which + // can arise from floating-point cancellation, or from the 3rd/4th central + // moments overflowing at extreme parameter draws explored during warmup) + // by treating it as a rejected region of parameter space (-Inf) rather + // than propagating a NaN into target. + real bvn_log_dens(real x, real y, real mx, real my, real vx, real vy, real cxy) { + real det = vx * vy - cxy * cxy; + if (!(vx > 0) || !(vy > 0) || !(det > 0) || !(det < positive_infinity())) { + return negative_infinity(); + } + real dx = x - mx; + real dy = y - my; + real quad = (dx * dx * vy - 2 * dx * dy * cxy + dy * dy * vx) / det; + return -log(2 * pi()) - 0.5 * log(det) - 0.5 * quad; + } + + // Helper function to compute gamma quantile approximation + real gamma_quantile_approx(real p, real shape, real scale) { + // Wilson-Hilferty approximation for gamma quantiles + real z = inv_Phi(p); + if (shape > 1) { + return shape * scale * pow(1 - 1.0/(9*shape) + z/(3*sqrt(shape)), 3); + } else { + return shape * scale * (1 + z / sqrt(shape)); // Fallback for small shape + } + } + + // Log of integral_{ex_l}^{ex_r} F_D(T - e) de: the truncation denominator + // for type 7 (right-truncated, doubly censored). Uses 7-point GL quadrature. + // Degenerates to log F_D(T - ex_l) when ex_l == ex_r (point exposure). + real trunc_denom_log(real ex_l, real ex_r, real T, + int dist_type, real loc, real phi, real kappa) { + if (ex_l == ex_r) { + return dist_log_cdf_fun(T - ex_l, dist_type, loc, phi, kappa); + } + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + real max_del = T - e_k; + log_terms[k] = log(w[k]) + dist_log_cdf_fun(max_del, dist_type, loc, phi, kappa); + } + return log_sum_exp(log_terms); + } + + // Log of integral_{ex_l}^{ex_r} [1 - F_D(T - e)] de: right-censored contribution + // for type 7 (onset not yet observed by T). Uses 7-point GL quadrature. + real right_censor_log_lik(real ex_l, real ex_r, real T, + int dist_type, real loc, real phi, real kappa) { + if (ex_l == ex_r) { + return log1m_exp(dist_log_cdf_fun(T - ex_l, dist_type, loc, phi, kappa)); + } + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + real max_del = T - e_k; + log_terms[k] = log(w[k]) + log1m_exp(dist_log_cdf_fun(max_del, dist_type, loc, phi, kappa)); + } + return log_sum_exp(log_terms); + } + + // Double-censored log-likelihood for one observation (summary type 6). + // + // Computes log P(E in [ex_l, ex_r], O in [ev_l, ev_r]) proportional to theta, + // where D = O - E ~ f_D(d; theta), assuming E uniform on [ex_l, ex_r] and + // O uniform on [ev_l, ev_r]. + // + // The normalising constant (ex_r - ex_l)(ev_r - ev_l) is constant in theta + // and is dropped, consistent with how type 5 drops 1/(ex_r - ex_l). + // + // Four cases: + // Both endpoints point-observed -> rounded to `resolution`, like summary_type 4/5 + // Point exposure, interval event -> log[F(ev_r - ex_l) - F(ev_l - ex_l)] + // Interval exposure, point event (= type 5) -> log[F(ev_l - ex_l) - F(ev_l - ex_r)] + // Both interval-censored (general) -> 7-point Gauss-Legendre quadrature + real dc_log_lik(real ex_l, real ex_r, real ev_l, real ev_r, + int dist_type, real loc, real phi, real kappa, real resolution) { + // 7-point Gauss-Legendre nodes/weights on [-1, 1] (Abramowitz & Stegun + // table 25.4), shared by every case below. Every case quadratures over + // the exposure side (its genuinely reported window in Cases 2-4, or a + // resolution-wide window standing in for a point report in Cases 1/3), + // treating the event side as a closed-form probability at each exposure + // node: dist_log_cdf_fun's CDF-difference when event is a genuine + // window (Cases 2, 4), or rounded_freq_loglik_fun's resolution-wide + // probability when event is itself a point report (Cases 1, 3). This + // keeps every case's Jacobian-dropping convention identical to Case 4's + // pre-existing one: calling this function with a point widened to its + // own resolution window gives the exact same result, node for node, as + // calling Case 4 directly with that window as an explicit interval. + array[7] real t = {-0.9491079123427585, -0.7415311855993945, + -0.4058451513773832, 0.0, + 0.4058451513773832, 0.7415311855993945, + 0.9491079123427585}; + array[7] real w = { 0.1294849661688697, 0.2797053914892767, + 0.3818300505051189, 0.4179591836734694, + 0.3818300505051189, 0.2797053914892767, + 0.1294849661688697}; + real half_res = resolution / 2; + + // Case 1: both endpoints point-observed. Exposure and event are each + // independently day-rounded, so the delay's implied distribution is the + // convolution of two independent Uniform(-resolution/2, resolution/2) + // rounding errors: a triangular kernel of half-width `resolution`, not + // the single rounded_freq_loglik_fun evaluation used before. Integrating + // out the exposure side analytically collapses the general double + // integral to this 1D quadrature over rounded_freq_loglik_fun exactly, + // no approximation in that reduction step. + if (ex_l == ex_r && ev_l == ev_r) { + real d = ev_l - ex_l; + array[7] real log_terms; + for (k in 1:7) { + real v_k = half_res * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(d - v_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 2: point exposure, interval event. Exposure is day-rounded; event + // stays exactly as reported (a genuine censoring window, not itself + // rounded further). Quadrature averages the point-exposure formula over + // exposure's own rounding window instead of evaluating it once at the + // exact reported value. + if (ex_l == ex_r) { + array[7] real log_terms; + for (k in 1:7) { + real e_k = ex_l + half_res * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } + // Case 3: interval exposure, point event. Quadrature over the genuinely + // reported exposure window, exactly like Case 4, but with the event + // side's closed-form CDF-difference replaced by rounded_freq_loglik_fun + // (event is itself a point report, standing in for its own resolution + // window) instead of the exact reported event window Case 4 uses. + if (ev_l == ev_r) { + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + rounded_freq_loglik_fun(ev_l - e_k, dist_type, loc, phi, kappa, resolution); + } + return log_sum_exp(log_terms); + } + // Case 4: both interval-censored (quadrature on [ex_l, ex_r]). + // The Jacobian factor (ex_r - ex_l)/2 is constant in theta and is dropped. + real mid = 0.5 * (ex_r + ex_l); + real half = 0.5 * (ex_r - ex_l); + array[7] real log_terms; + for (k in 1:7) { + real e_k = mid + half * t[k]; + log_terms[k] = log(w[k]) + log_diff_exp( + dist_log_cdf_fun(ev_r - e_k, dist_type, loc, phi, kappa), + dist_log_cdf_fun(ev_l - e_k, dist_type, loc, phi, kappa) + ); + } + return log_sum_exp(log_terms); + } +} + +data { + int n_datasets; // Number of datasets + array[n_datasets] int n_obs; // Sample sizes for each dataset + array[n_datasets] int summary_type; // 1=median+range, 2=median+IQR, 3=mean+sd, 4=raw freq table, 5=interval-censored freq table, 6=double interval-censored freq table, 7=double interval-censored with right truncation/censoring + int dist_type; // 1=lognormal, 2=gamma, 3=weibull, 4=burr XII, 5=gen. gamma + + // Observed summaries - organized by dataset (used for summary_type 1, 2, 3) + array[n_datasets] real obs_stat1; // median or mean + array[n_datasets] real obs_stat2; // min, q25, or sd + array[n_datasets] real obs_stat3; // max, q75, or placeholder + + // Day-fraction rounding resolution (e.g. 1 = whole day, 1/24 = hourly); see + // detect_resolution() in R/utils.R. Used by summary_type 1/2 (reported + // order statistics), summary_type 4/5 (raw/degenerate frequency-table + // counts), and summary_type 6/7's dc_log_lik whenever exposure and/or + // event is point-observed (Cases 1-3), all treated as rounded values. + // Ignored for summary_type 3 (populate with 1, unused). + array[n_datasets] real resolution; + + // --- Frequency table data for summary_type == 4 --- + // All datasets' frequency tables are stored in flat arrays. + // For dataset d, its entries occupy indices freq_start[d] .. freq_start[d] + freq_len[d] - 1. + int n_freq_total; // Total number of (value, count) pairs across all type-4 datasets + array[n_freq_total] real freq_value; // Observed day values for type 4, rounded to `resolution`; 0 allowed + array[n_freq_total] int freq_count; // Number of individuals with that day value (types 4 and 5) + array[n_datasets] int freq_start; // 1-based start index into freq arrays for dataset d + array[n_datasets] int freq_len; // Number of distinct values for dataset d (0 if not type 4 or 5) + + // Interval bounds for summary_type == 5 (interval-censored frequency table). + // For type 4 datasets these arrays are ignored (populate with zeros). + // When freq_lower[i] == freq_upper[i] (no reported range), the value is + // treated as a rounded point observation, like summary_type 4. + array[n_freq_total] real freq_lower; // lower bound of censoring interval + array[n_freq_total] real freq_upper; // upper bound of censoring interval + + // Event window bounds for summary_type == 6 and 7 (double interval-censored). + // For all other summary types these arrays are populated with zeros. + // For types 6 and 7, freq_lower / freq_upper carry the exposure window (expo_lower, expo_upper). + array[n_freq_total] real event_lower; // lower bound of event window; 0 for right-censored (type 7) + array[n_freq_total] real event_upper; // upper bound of event window; 0 for right-censored (type 7) + + // Type 7: right truncation / right censoring. + // event_observed[i] = 1 if onset was recorded, 0 if right-censored (onset not yet seen). + // truncation_time[d] = analysis date T in days from the reference date; ignored for other types. + // T is a study-design cutoff, not a rounded observation of a random event + // time, so it is never treated as day-rounded the way exposure/event + // windows are (see resolution, above). Set it using the same + // time-encoding convention as that dataset's own windows. + array[n_freq_total] int event_observed; // 1=onset seen, 0=right-censored + array[n_datasets] real truncation_time; // analysis date T per dataset + + // Prior hyperparameters for mu0 ~ normal(mu0_mean, mu0_sd) + real mu0_mean; + real mu0_sd; + + // Prior hyperparameters for log_tau ~ normal(log_tau_mean, log_tau_sd) + real log_tau_mean; + real log_tau_sd; + + // Prior hyperparameters for log_phi ~ normal(log_phi_mean, log_phi_sd) + real log_phi_mean; + real log_phi_sd; + + // Prior hyperparameters for log_kappa ~ normal(log_kappa_mean, log_kappa_sd) + // kappa = exp(log_kappa) > 0; used by dist_type 4 (Burr XII k) and 5 (GG Q). + // For dist_type 1-3 supply wide uninformative priors (e.g. mean=0, sd=1); + // kappa will be sampled from its prior but does not enter the likelihood. + real log_kappa_mean; + real log_kappa_sd; +} + +transformed data { + real z_q25 = -0.6745; + real z_q75 = 0.6745; + real z_q90 = 1.28155; + real z_q95 = 1.64485; + + // Validate data + for (d in 1:n_datasets) { + if (summary_type[d] == 1) { + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=1, must have min <= median <= max"); + } + if (resolution[d] <= 0) { + reject("For summary_type=1, resolution must be > 0"); + } + } else if (summary_type[d] == 2) { + if (obs_stat2[d] > obs_stat1[d] || obs_stat1[d] > obs_stat3[d]) { + reject("For summary_type=2, must have q25 <= median <= q75"); + } + if (resolution[d] <= 0) { + reject("For summary_type=2, resolution must be > 0"); + } + } else if (summary_type[d] == 3) { + // A sample SD is undefined for a single observation; the mean/SD + // likelihood also divides by (n-1), which is degenerate at n=1. + if (n_obs[d] < 2) { + reject("For summary_type=3, n_obs must be >= 2 (a sample SD requires at least 2 observations)"); + } + } else if (summary_type[d] == 4) { + if (freq_len[d] == 0) { + reject("For summary_type=4, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=4, resolution must be > 0"); + } + } else if (summary_type[d] == 5) { + if (freq_len[d] == 0) { + reject("For summary_type=5, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=5, resolution must be > 0"); + } + } else if (summary_type[d] == 6) { + if (freq_len[d] == 0) { + reject("For summary_type=6, freq_len must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=6, resolution must be > 0"); + } + } else if (summary_type[d] == 7) { + if (freq_len[d] == 0) { + reject("For summary_type=7, freq_len must be > 0"); + } + if (truncation_time[d] <= 0) { + reject("For summary_type=7, truncation_time must be > 0"); + } + if (resolution[d] <= 0) { + reject("For summary_type=7, resolution must be > 0"); + } + } + } +} + +parameters { + real mu0; // Population mean (location) + real log_tau; // Log of between-study SD + real log_phi; // Log of distribution-specific shape/scale parameter + real log_kappa; // Log of 3rd distribution parameter (Burr XII k; GG Q) + vector[n_datasets] loc_d_raw; // Non-centered parameterization +} + +transformed parameters { + real tau = exp(log_tau); + real phi = exp(log_phi); + real kappa = exp(log_kappa); + vector[n_datasets] loc_d = mu0 + tau * loc_d_raw; +} + +model { + mu0 ~ normal(mu0_mean, mu0_sd); + log_tau ~ normal(log_tau_mean, log_tau_sd); + log_phi ~ normal(log_phi_mean, log_phi_sd); + log_kappa ~ normal(log_kappa_mean, log_kappa_sd); + + loc_d_raw ~ std_normal(); + + for (d in 1:n_datasets) { + real loc = loc_d[d]; + int n = n_obs[d]; + + if (summary_type[d] == 1) { // median + range (min, max), rounded to `resolution[d]` + int k_median = (n + 1) %/% 2; + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); + } + + else if (summary_type[d] == 2) { // median + IQR (q25, q75), rounded to `resolution[d]` + int k_median = (n + 1) %/% 2; + target += order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + + int k_q25 = (n + 1) %/% 4; + if (k_q25 < 1) k_q25 = 1; + target += order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); + + int k_q75 = (3 * (n + 1)) %/% 4; + if (k_q75 <= k_q25) k_q75 = k_q25 + 1; + if (k_q75 > n) k_q75 = n; + target += order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); + } + + else if (summary_type[d] == 3) { // mean + sd + // Joint likelihood for (sample mean, sample variance), using the + // exact finite-sample moments of these two statistics rather than + // the univariate normal-theory Var(SD) and independence assumption + // (correct only for Gaussian data). For the unbiased sample variance + // S^2 (divisor n-1): + // Var(mean) = sigma^2 / n [exact] + // Cov(mean,S^2) = mu3 / n [exact] + // Var(S^2) = (mu4 - ((n-3)/(n-1)) * sigma^4) / n [exact] + // The likelihood is built for (mean, S^2) rather than (mean, SD) + // because these two identities hold exactly for any n, whereas + // transforming to SD via the delta method (S = sqrt(S^2)) adds an + // extra approximation that a Monte Carlo check showed is inaccurate + // at realistic sample sizes for skewed families. The S^2 -> SD + // Jacobian depends only on the observed data, not on the model + // parameters, so it is dropped without affecting inference. + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; + + if (dist_type == 1) { // lognormal + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + + } else if (dist_type == 2) { // gamma + real shape = phi; + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + + } else if (dist_type == 3) { // weibull + real shape = phi; + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + + } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa + // E[X^r] = lambda^r * k * B(k - r/c, 1 + r/c), requires k*c > r. + // The 4th moment (needed for Var(S^2)) requires k*c > 4, stricter + // than the k*c > 2 needed for the variance alone. Hard barrier: + // reject this region of parameter space for datasets that report + // a mean and SD. + if (kappa * phi <= 4.0) { + moments_ok = 0; + target += negative_infinity(); + } else { + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + } else if (dist_type == 5) { // generalised gamma (Prentice): mu=loc, sigma=phi, Q=kappa + // log E[X^r] = r*loc + (2*r*phi/kappa)*log(kappa) + // + lgamma(gamma_shape + r*phi/kappa) - lgamma(gamma_shape) + // where gamma_shape = 1/kappa^2. Always finite (no kc-style threshold). + real gamma_shape = 1.0 / (kappa * kappa); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + target += bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } + } + + else if (summary_type[d] == 4) { // raw frequency table + // Each distinct observed value is treated as rounded to the nearest + // multiple of `resolution` days, exactly like a reported order + // statistic (see rounded_freq_loglik_fun), not as an exact continuous + // observation. + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + target += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); + } + } + + else if (summary_type[d] == 5) { // interval-censored frequency table + // Likelihood: count * log[ F(upper) - F(lower) ] for each interval. + // Uses log_diff_exp(log_F_upper, log_F_lower) for numerical stability: + // avoids catastrophic cancellation when the two CDF values are close. + // When lower == upper (point observation, no reported range), it is + // rounded like summary_type 4 rather than falling back to a point + // log-pdf. + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + if (freq_lower[i] == freq_upper[i]) { + target += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); + } else { + real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); + real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + target += freq_count[i] * log_diff_exp(log_cdf_u, log_cdf_l); + } + } + } + + else if (summary_type[d] == 6) { // double interval-censored frequency table + // Likelihood: count * dc_log_lik(expo_lower, expo_upper, event_lower, event_upper). + // freq_lower / freq_upper carry the exposure window bounds for type 6. + // Uses 7-point GL quadrature; degenerates correctly to type 5 when + // event_lower[i] == event_upper[i] (point event observation). + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + target += freq_count[i] * dc_log_lik( + freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d] + ); + } + } + + else if (summary_type[d] == 7) { // double interval-censored + right truncation/censoring + // For observed individuals (event_observed[i] == 1): + // log L = dc_log_lik(...) - trunc_denom_log(...) + // i.e. numerator = integral F(O_R-e) - F(O_L-e) de over exposure window + // denominator = integral F(T-e) de over exposure window + // For right-censored individuals (event_observed[i] == 0): + // log L = right_censor_log_lik(...) + // i.e. integral [1 - F(T-e)] de over exposure window + int s = freq_start[d]; + int len = freq_len[d]; + real T = truncation_time[d]; + for (i in s:(s + len - 1)) { + if (event_observed[i] == 1) { + target += freq_count[i] * ( + dc_log_lik(freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d]) + - trunc_denom_log(freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa) + ); + } else { + target += freq_count[i] * right_censor_log_lik( + freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa + ); + } + } + } + } +} + +generated quantities { + real pred_mean; + real pred_median; + real pred_q25; + real pred_q75; + real pred_q90; + real pred_q95; + real pred_sd; + vector[n_datasets * 3] log_lik; + + // Predicted quantities: + // - When n_datasets < 5, tau is not identifiable from data (prior-dominated). + // pred_* are computed at mean(loc_d) directly to avoid tau^2/2 inflation. + // See: Higgins & Thompson (2002) doi:10.1002/sim.1186 + // Gelman (2006) doi:10.1214/06-BA117A + // Rover et al. (2021) doi:10.1002/jrsm.1475 + // - When n_datasets >= 5, tau is identifiable; sample from Normal(mu0, tau) + // to include between-study heterogeneity. L=2000 for MC stability. + { + if (n_datasets < 5) { + real loc_pred = mean(loc_d); + + if (dist_type == 1) { // lognormal + pred_mean = exp(loc_pred + phi^2 / 2); + pred_median = exp(loc_pred); + pred_q25 = exp(loc_pred - 0.6745 * phi); + pred_q75 = exp(loc_pred + 0.6745 * phi); + pred_q90 = exp(loc_pred + 1.28155 * phi); + pred_q95 = exp(loc_pred + 1.64485 * phi); + pred_sd = sqrt((exp(phi^2) - 1) * exp(2 * loc_pred + phi^2)); + + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc_pred); + real scale_param = mean_d / phi; + pred_mean = mean_d; + pred_sd = sqrt(mean_d * scale_param); + pred_median = gamma_quantile_approx(0.5, phi, scale_param); + pred_q25 = gamma_quantile_approx(0.25, phi, scale_param); + pred_q75 = gamma_quantile_approx(0.75, phi, scale_param); + pred_q90 = gamma_quantile_approx(0.90, phi, scale_param); + pred_q95 = gamma_quantile_approx(0.95, phi, scale_param); + + } else if (dist_type == 3) { // weibull + real scale = exp(loc_pred); + pred_mean = scale * tgamma(1 + 1.0 / phi); + pred_median = scale * pow(log(2), 1.0 / phi); + pred_q25 = scale * pow(log(4.0 / 3.0), 1.0 / phi); + pred_q75 = scale * pow(log(4.0), 1.0 / phi); + pred_q90 = scale * pow(log(10.0), 1.0 / phi); + pred_q95 = scale * pow(log(20.0), 1.0 / phi); + pred_sd = sqrt(scale^2 * (tgamma(1 + 2.0/phi) - pow(tgamma(1 + 1.0/phi), 2))); + + } else if (dist_type == 4) { // burr XII: closed-form quantiles + // Q(p) = lambda * ((1-p)^(-1/k) - 1)^(1/c) + real lam = exp(loc_pred); + pred_median = lam * pow(pow(0.5, -1.0/kappa) - 1.0, 1.0/phi); + pred_q25 = lam * pow(pow(0.75, -1.0/kappa) - 1.0, 1.0/phi); + pred_q75 = lam * pow(pow(0.25, -1.0/kappa) - 1.0, 1.0/phi); + pred_q90 = lam * pow(pow(0.10, -1.0/kappa) - 1.0, 1.0/phi); + pred_q95 = lam * pow(pow(0.05, -1.0/kappa) - 1.0, 1.0/phi); + // E[X^r] = lambda^r * k * B(k-r/c, 1+r/c), requires k*c > r + if (kappa * phi > 1.0) { + pred_mean = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); + } else { + pred_mean = positive_infinity(); + } + if (kappa * phi > 2.0) { + real e2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); + pred_sd = sqrt(fabs(e2 - pred_mean^2)); + } else { + pred_sd = positive_infinity(); + } + + } else if (dist_type == 5) { // generalised gamma: Monte Carlo via gamma_rng + // Sample T = exp(mu + sigma/Q * log(Q^2 * Y)), Y ~ Gamma(1/Q^2, 1) + int L_gg = 200; + vector[L_gg] gg_samples; + real gs = 1.0 / (kappa * kappa); + for (l in 1:L_gg) { + real y = gamma_rng(gs, 1); + gg_samples[l] = exp(loc_pred + phi / kappa * log(kappa * kappa * y)); + } + gg_samples = sort_asc(gg_samples); + pred_mean = mean(gg_samples); + pred_sd = sd(gg_samples); + pred_median = gg_samples[100]; + pred_q25 = gg_samples[50]; + pred_q75 = gg_samples[150]; + pred_q90 = gg_samples[180]; + pred_q95 = gg_samples[190]; + } + + } else { + // n_datasets >= 5: tau identifiable; include between-study heterogeneity + // via Monte Carlo integration over Normal(mu0, tau). L=2000 for stability. + int L = 2000; + + if (dist_type == 5) { + // GG: sample one T per study draw to get the full predictive distribution + // T = exp(mu + sigma/Q * log(Q^2 * Y)), Y ~ Gamma(1/Q^2, 1) + int L_gg = 200; + vector[L_gg] gg_t_samples; + real gs = 1.0 / (kappa * kappa); + for (l in 1:L_gg) { + real loc_sample = normal_rng(mu0, tau); + real y = gamma_rng(gs, 1); + gg_t_samples[l] = exp(loc_sample + phi / kappa * log(kappa * kappa * y)); + } + gg_t_samples = sort_asc(gg_t_samples); + pred_mean = mean(gg_t_samples); + pred_sd = sd(gg_t_samples); + pred_median = gg_t_samples[100]; + pred_q25 = gg_t_samples[50]; + pred_q75 = gg_t_samples[150]; + pred_q90 = gg_t_samples[180]; + pred_q95 = gg_t_samples[190]; + + } else { + // dist_type 1-4: compute per-study analytic moments/quantiles, then average + vector[L] means; + vector[L] medians; + vector[L] q25s; + vector[L] q75s; + vector[L] q90s; + vector[L] q95s; + vector[L] sds; + + for (l in 1:L) { + real loc_sample = normal_rng(mu0, tau); + + if (dist_type == 1) { // lognormal + means[l] = exp(loc_sample + phi^2 / 2); + medians[l] = exp(loc_sample); + q25s[l] = exp(loc_sample - 0.6745 * phi); + q75s[l] = exp(loc_sample + 0.6745 * phi); + q90s[l] = exp(loc_sample + 1.28155 * phi); + q95s[l] = exp(loc_sample + 1.64485 * phi); + sds[l] = sqrt((exp(phi^2) - 1) * exp(2 * loc_sample + phi^2)); + + } else if (dist_type == 2) { // gamma + real mean_d = exp(loc_sample); + real scale_param = mean_d / phi; + means[l] = mean_d; + sds[l] = sqrt(mean_d * scale_param); + medians[l] = gamma_quantile_approx(0.5, phi, scale_param); + q25s[l] = gamma_quantile_approx(0.25, phi, scale_param); + q75s[l] = gamma_quantile_approx(0.75, phi, scale_param); + q90s[l] = gamma_quantile_approx(0.90, phi, scale_param); + q95s[l] = gamma_quantile_approx(0.95, phi, scale_param); + + } else if (dist_type == 3) { // weibull + real scale = exp(loc_sample); + means[l] = scale * tgamma(1 + 1.0 / phi); + medians[l] = scale * pow(log(2), 1.0 / phi); + q25s[l] = scale * pow(log(4.0 / 3.0), 1.0 / phi); + q75s[l] = scale * pow(log(4.0), 1.0 / phi); + q90s[l] = scale * pow(log(10.0), 1.0 / phi); + q95s[l] = scale * pow(log(20.0), 1.0 / phi); + real var_weib = scale^2 * (tgamma(1 + 2.0/phi) - pow(tgamma(1 + 1.0/phi), 2)); + sds[l] = sqrt(var_weib); + + } else if (dist_type == 4) { // burr XII: closed-form quantiles + real lam_l = exp(loc_sample); + medians[l] = lam_l * pow(pow(0.5, -1.0/kappa) - 1.0, 1.0/phi); + q25s[l] = lam_l * pow(pow(0.75, -1.0/kappa) - 1.0, 1.0/phi); + q75s[l] = lam_l * pow(pow(0.25, -1.0/kappa) - 1.0, 1.0/phi); + q90s[l] = lam_l * pow(pow(0.10, -1.0/kappa) - 1.0, 1.0/phi); + q95s[l] = lam_l * pow(pow(0.05, -1.0/kappa) - 1.0, 1.0/phi); + if (kappa * phi > 1.0) { + means[l] = lam_l * kappa * exp(lbeta(kappa - 1.0/phi, 1.0 + 1.0/phi)); + } else { + means[l] = positive_infinity(); + } + if (kappa * phi > 2.0) { + real e2_l = lam_l^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1.0 + 2.0/phi)); + sds[l] = (kappa * phi > 1.0) ? sqrt(fabs(e2_l - means[l]^2)) : positive_infinity(); + } else { + sds[l] = positive_infinity(); + } + } + } + + pred_mean = mean(means); + pred_median = mean(medians); + pred_q25 = mean(q25s); + pred_q75 = mean(q75s); + pred_q90 = mean(q90s); + pred_q95 = mean(q95s); + pred_sd = mean(sds); + } + } + } + + // Log likelihood + { + int idx = 1; + + for (d in 1:n_datasets) { + real loc = loc_d[d]; + int n = n_obs[d]; + + if (summary_type[d] == 1) { // median + range + int k_median = (n + 1) %/% 2; + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, 1, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, n, dist_type, loc, phi, kappa, resolution[d]); + + } else if (summary_type[d] == 2) { // median + IQR + int k_median = (n + 1) %/% 2; + int k_q25 = (n + 1) %/% 4; + if (k_q25 < 1) k_q25 = 1; + int k_q75 = (3 * (n + 1)) %/% 4; + if (k_q75 <= k_q25) k_q75 = k_q25 + 1; + if (k_q75 > n) k_q75 = n; + + log_lik[idx] = order_stat_rounded_loglik_fun(obs_stat1[d], n, k_median, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 1] = order_stat_rounded_loglik_fun(obs_stat2[d], n, k_q25, dist_type, loc, phi, kappa, resolution[d]); + log_lik[idx + 2] = order_stat_rounded_loglik_fun(obs_stat3[d], n, k_q75, dist_type, loc, phi, kappa, resolution[d]); + + } else if (summary_type[d] == 3) { // mean + sd (see model block for derivation) + real mean_d; + real var_d; // sigma_d^2 + real mu3; + real mu4; + int moments_ok = 1; + + if (dist_type == 1) { + real omega = exp(phi^2); + mean_d = exp(loc + phi^2 / 2); + var_d = mean_d^2 * (omega - 1); + mu3 = (omega + 2) * (omega - 1)^2 * mean_d^3; + mu4 = (omega^4 + 2*omega^3 + 3*omega^2 - 3) * (omega - 1)^2 * mean_d^4; + + } else if (dist_type == 2) { + real shape = phi; + mean_d = exp(loc); + var_d = mean_d^2 / shape; + mu3 = 2 * mean_d^3 / shape^2; + mu4 = (3 + 6 / shape) * var_d^2; + + } else if (dist_type == 3) { + real shape = phi; + real scale = exp(loc); + real g1 = tgamma(1 + 1.0/shape); + real g2 = tgamma(1 + 2.0/shape); + real g3 = tgamma(1 + 3.0/shape); + real g4 = tgamma(1 + 4.0/shape); + mean_d = scale * g1; + var_d = scale^2 * (g2 - g1^2); + mu3 = scale^3 * (g3 - 3*g1*g2 + 2*g1^3); + mu4 = scale^4 * (g4 - 4*g1*g3 + 6*g1^2*g2 - 3*g1^4); + + } else if (dist_type == 4) { + if (kappa * phi <= 4.0) { + moments_ok = 0; + } else { + real lam = exp(loc); + real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); + real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); + real m3 = lam^3 * kappa * exp(lbeta(kappa - 3.0/phi, 1 + 3.0/phi)); + real m4 = lam^4 * kappa * exp(lbeta(kappa - 4.0/phi, 1 + 4.0/phi)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + } else if (dist_type == 5) { + real gamma_shape = 1.0 / (kappa * kappa); + real m1 = exp(loc + 2.0*phi/kappa * log(kappa) + lgamma(gamma_shape + phi/kappa) - lgamma(gamma_shape)); + real m2 = exp(2.0*loc + 4.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 2.0*phi/kappa) - lgamma(gamma_shape)); + real m3 = exp(3.0*loc + 6.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 3.0*phi/kappa) - lgamma(gamma_shape)); + real m4 = exp(4.0*loc + 8.0*phi/kappa * log(kappa) + lgamma(gamma_shape + 4.0*phi/kappa) - lgamma(gamma_shape)); + mean_d = m1; + var_d = fabs(m2 - m1^2); + mu3 = m3 - 3*m1*m2 + 2*m1^3; + mu4 = m4 - 4*m1*m3 + 6*m1^2*m2 - 3*m1^4; + } + + if (moments_ok == 1) { + real var_mean = var_d / n; + real var_var2 = (mu4 - ((n - 3.0) / (n - 1.0)) * var_d^2) / n; + real cov_mv2 = mu3 / n; + log_lik[idx] = bvn_log_dens(obs_stat1[d], obs_stat2[d]^2, mean_d, var_d, var_mean, var_var2, cov_mv2); + } else { + log_lik[idx] = negative_infinity(); + } + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + + } else if (summary_type[d] == 4) { // raw frequency table + // Sum log-likelihoods over all individuals, using the frequency table. + // Stored as a single scalar in log_lik[idx]; slots idx+1 and idx+2 are 0 (unused). + real ll_type4 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + ll_type4 += freq_count[i] * rounded_freq_loglik_fun(freq_value[i], dist_type, loc, phi, kappa, resolution[d]); + } + log_lik[idx] = ll_type4; + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + + } else if (summary_type[d] == 5) { // interval-censored frequency table + real ll_type5 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + if (freq_lower[i] == freq_upper[i]) { + ll_type5 += freq_count[i] * rounded_freq_loglik_fun(freq_lower[i], dist_type, loc, phi, kappa, resolution[d]); + } else { + real log_cdf_u = dist_log_cdf_fun(freq_upper[i], dist_type, loc, phi, kappa); + real log_cdf_l = dist_log_cdf_fun(freq_lower[i], dist_type, loc, phi, kappa); + ll_type5 += freq_count[i] * log_diff_exp(log_cdf_u, log_cdf_l); + } + } + log_lik[idx] = ll_type5; + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + + } else if (summary_type[d] == 6) { // double interval-censored frequency table + real ll_type6 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + for (i in s:(s + len - 1)) { + ll_type6 += freq_count[i] * dc_log_lik( + freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d] + ); + } + log_lik[idx] = ll_type6; + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + + } else if (summary_type[d] == 7) { // double interval-censored + right truncation/censoring + real ll_type7 = 0; + int s = freq_start[d]; + int len = freq_len[d]; + real T = truncation_time[d]; + for (i in s:(s + len - 1)) { + if (event_observed[i] == 1) { + ll_type7 += freq_count[i] * ( + dc_log_lik(freq_lower[i], freq_upper[i], + event_lower[i], event_upper[i], + dist_type, loc, phi, kappa, resolution[d]) + - trunc_denom_log(freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa) + ); + } else { + ll_type7 += freq_count[i] * right_censor_log_lik( + freq_lower[i], freq_upper[i], T, + dist_type, loc, phi, kappa + ); + } + } + log_lik[idx] = ll_type7; + log_lik[idx + 1] = 0; // unused + log_lik[idx + 2] = 0; // unused + } + + idx += 3; + } + } +} From 987cb62e19527a46e1757d0bfd8a81adffac6a9c Mon Sep 17 00:00:00 2001 From: cm401 Date: Mon, 3 Aug 2026 14:23:20 +0100 Subject: [PATCH 08/30] Add utility functions for adaptive quadrature panel count --- R/utils.R | 431 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 410 insertions(+), 21 deletions(-) diff --git a/R/utils.R b/R/utils.R index 4033aa2..3fc5441 100644 --- a/R/utils.R +++ b/R/utils.R @@ -399,7 +399,11 @@ detect_resolution <- function(exact_vals, risky_vals = numeric(0), tol = 1e-6) { #' @param custom_priors Named list of prior overrides. Any values not supplied #' fall back to distribution-appropriate defaults (see Details). Recognised #' names: `mu0_sd`, `log_tau_mean`, `log_tau_sd`, `log_phi_mean`, -#' `log_phi_sd`. +#' `log_phi_sd`, `log_omega_mean`, `log_omega_sd`. `log_phi_mean`/`log_phi_sd` +#' are the prior for `log_phi0` (population-mean dispersion); +#' `log_omega_mean`/`log_omega_sd` are the prior for `log_omega`, the +#' between-study SD of log dispersion (per-study `phi_d` is hierarchical, +#' not a shared scalar). #' #' @details #' **Distribution-specific defaults for `log_phi`:** @@ -440,7 +444,8 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, use_custom_priors = 0, custom_priors = list()) { - # Apply distribution-specific defaults for log_phi_mean/log_phi_sd and + # Apply distribution-specific defaults for log_phi_mean/log_phi_sd, + # log_omega_mean (log_omega_sd stays flat, see below), and # log_kappa_mean/log_kappa_sd. # # phi meaning per distribution: @@ -450,16 +455,31 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, # burr XII (4): phi = c (shape1), typical range 1-5 -> log_phi_mean = 0.7 # gen. gamma (5): phi = sigma (log-disp),typical range 0.2-1.0 -> log_phi_mean = -0.5 # + # log_omega_mean: between-study SD of log dispersion, family-specific + # because how tightly phi is pinned down per study (and hence how much + # of its apparent between-study spread is real heterogeneity vs + # estimation noise) differs by family - notably gamma's shape parameter + # is intrinsically harder to identify per-study than lognormal's sigma + # (confirmed by a per-family, per-dataset no-pooling MAP scoping across + # COVID-19/SARS/Cholera/Dengue, 103 datasets/family; pooled within-pathogen + # sd(log phi): lognormal 0.410, burr12 0.415, gengamma 0.483, weibull 0.457, + # gamma 0.677). log_omega_mean below is log() of that pooled sd, rounded. + # A single shared uninformative prior on top of a single scalar phi could + # not previously produce this failure mode; with phi now hierarchical + # per-dataset, a too-tight shared omega prior caused a severe funnel/mixing + # pathology for gamma specifically (Rhat > 100) that resolved once + # family-specific scale was used. See REVISION_TODO.md, point 4. + # # kappa meaning per distribution: # dist 1-3: kappa is unused; wide uninformative prior centred at 1. # burr XII (4): kappa = k (shape2), typical range 1-10 -> log_kappa_mean = 1.0 # gen. gamma (5): kappa = Q (shape), typical range 0.3-3 -> log_kappa_mean = 0.0 dist_defaults <- list( - `1` = list(log_phi_mean = -0.7, log_phi_sd = 0.5, log_kappa_mean = 0.0, log_kappa_sd = 1.0), - `2` = list(log_phi_mean = 2.5, log_phi_sd = 0.5, log_kappa_mean = 0.0, log_kappa_sd = 1.0), - `3` = list(log_phi_mean = 1.0, log_phi_sd = 0.5, log_kappa_mean = 0.0, log_kappa_sd = 1.0), - `4` = list(log_phi_mean = 0.7, log_phi_sd = 0.5, log_kappa_mean = 1.0, log_kappa_sd = 0.5), - `5` = list(log_phi_mean = -0.5, log_phi_sd = 0.5, log_kappa_mean = 0.0, log_kappa_sd = 0.5) + `1` = list(log_phi_mean = -0.7, log_phi_sd = 0.5, log_omega_mean = -0.9, log_kappa_mean = 0.0, log_kappa_sd = 1.0), + `2` = list(log_phi_mean = 2.5, log_phi_sd = 0.5, log_omega_mean = -0.4, log_kappa_mean = 0.0, log_kappa_sd = 1.0), + `3` = list(log_phi_mean = 1.0, log_phi_sd = 0.5, log_omega_mean = -0.8, log_kappa_mean = 0.0, log_kappa_sd = 1.0), + `4` = list(log_phi_mean = 0.7, log_phi_sd = 0.5, log_omega_mean = -0.9, log_kappa_mean = 1.0, log_kappa_sd = 0.5), + `5` = list(log_phi_mean = -0.5, log_phi_sd = 0.5, log_omega_mean = -0.7, log_kappa_mean = 0.0, log_kappa_sd = 0.5) )[[as.character(dist_type)]] if (is.null(dist_defaults)) { @@ -472,6 +492,14 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, log_tau_sd = 0.5, log_phi_mean = dist_defaults$log_phi_mean, log_phi_sd = dist_defaults$log_phi_sd, + # Between-study SD of log dispersion (log_phi_d), analogous to log_tau + # for location. log_omega_mean is family-specific (see dist_defaults + # above); log_omega_sd is left flat at 0.5 across families, matching + # the log_tau_sd=0.5 convention already used here - it is a generic + # uncertainty width on top of the point estimate, not itself + # data-derived per family. See REVISION_TODO.md, point 4. + log_omega_mean = dist_defaults$log_omega_mean, + log_omega_sd = 0.5, log_kappa_mean = dist_defaults$log_kappa_mean, log_kappa_sd = dist_defaults$log_kappa_sd ) @@ -787,12 +815,159 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, stan_data$log_tau_sd <- custom_priors$log_tau_sd stan_data$log_phi_mean <- custom_priors$log_phi_mean stan_data$log_phi_sd <- custom_priors$log_phi_sd + stan_data$log_omega_mean <- custom_priors$log_omega_mean + stan_data$log_omega_sd <- custom_priors$log_omega_sd stan_data$log_kappa_mean <- custom_priors$log_kappa_mean stan_data$log_kappa_sd <- custom_priors$log_kappa_sd + # Per-order-statistic adaptive quadrature panel count (performance lever, + # not a correctness change): see POINT1_LIKELIHOOD_MATHS.md Part G for the + # derivation. A wrong choice here only costs efficiency (or triggers + # pre_inference_checks()-style convergence issues, handled by the settings + # escalation in fit_with_escalation()), since the underlying quadrature + # maths is unchanged - it just decides how many panels to spend. + n_panels_stat1 <- integer(n_datasets) + n_panels_stat2 <- integer(n_datasets) + n_panels_stat3 <- integer(n_datasets) + for (i in seq_len(n_datasets)) { + if (summary_type[i] == 1L) { + k_median <- (n_obs_vec[i] + 1L) %/% 2L + phi_guess <- .mom_phi_guess(datasets[[i]], dist_type, custom_priors$log_kappa_mean) + n_panels_stat1[i] <- .order_stat_n_panels(obs_stat1[i], n_obs_vec[i], k_median, resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + n_panels_stat2[i] <- .order_stat_n_panels(obs_stat2[i], n_obs_vec[i], 1L, resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + n_panels_stat3[i] <- .order_stat_n_panels(obs_stat3[i], n_obs_vec[i], n_obs_vec[i], resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + } else if (summary_type[i] == 2L) { + n <- n_obs_vec[i] + k_median <- (n + 1L) %/% 2L + k_q25 <- max((n + 1L) %/% 4L, 1L) + k_q75 <- min(max((3L * (n + 1L)) %/% 4L, k_q25 + 1L), n) + phi_guess <- .mom_phi_guess(datasets[[i]], dist_type, custom_priors$log_kappa_mean) + n_panels_stat1[i] <- .order_stat_n_panels(obs_stat1[i], n, k_median, resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + n_panels_stat2[i] <- .order_stat_n_panels(obs_stat2[i], n, k_q25, resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + n_panels_stat3[i] <- .order_stat_n_panels(obs_stat3[i], n, k_q75, resolution_vec[i], dist_type, phi_guess, exp(custom_priors$log_kappa_mean)) + } else { + n_panels_stat1[i] <- 24L; n_panels_stat2[i] <- 24L; n_panels_stat3[i] <- 24L + } + } + stan_data$n_panels_stat1 <- as.array(n_panels_stat1) + stan_data$n_panels_stat2 <- as.array(n_panels_stat2) + stan_data$n_panels_stat3 <- as.array(n_panels_stat3) + return(stan_data) } +# Adaptive quadrature panel count for order-statistic rounding likelihoods -- +# +# See POINT1_LIKELIHOOD_MATHS.md Part G for the full derivation. Summary: the +# panel count needed for the composite Gauss-Legendre quadrature +# (order_stat_rounded_loglik_fun in the .stan files) to hit the same accuracy +# as the original fixed 24-panel scheme is, empirically, a clean function of +# rho = resolution / SE_asymptotic(order statistic) - not of n or family +# alone. Since rho depends on the (unknown-until-fitted) dispersion +# parameter, this uses a per-dataset method-of-moments guess evaluated at a +# family-specific safety margin (the direction that INCREASES rho, chosen +# per family from the empirical MAP-vs-MoM comparison this session): for +# spread-type families (lognormal, gen. gamma - CV increases with phi) the +# dangerous direction is phi too LOW; for concentration-type families +# (Weibull, Burr XII - CV decreases with phi) it's phi too HIGH. Gamma is +# excluded entirely (kept at the fixed 24 panels): its own MAP-vs-MoM +# comparison showed a 99th-percentile ratio of 4.4x (vs ~1.7-2x for the +# other concentration-type families), and covering that via margin alone +# was found to require booking >96 panels even at moderate n - intractable, +# and unnecessary, since that regime is exactly where the true log-density +# is also vanishingly small (verified directly: both the reference and the +# 24-panel scheme agree the region contributes ~0 to the posterior, they +# just disagree on exactly how close to -Inf). Any residual risk for the +# eligible families is caught by fit_with_escalation()'s Rhat/divergence +# check, not by this heuristic alone. +.panels_from_rho <- function(rho) { + if (!is.finite(rho)) return(24L) + if (rho <= 4) return(2L) + if (rho <= 10) return(4L) + if (rho <= 20) return(6L) + if (rho <= 30) return(8L) + if (rho <= 46) return(12L) + if (rho <= 57) return(16L) + return(24L) +} + +# Solve for `loc` such that the p-th quantile of the family equals v, given +# phi/kappa - lets us evaluate the density AT the reported (fixed, known) +# value v without needing an independent loc estimate. +.solve_loc_for_quantile <- function(v, p, dist_type, phi, kappa) { + switch(as.character(dist_type), + "1" = log(v) - phi * stats::qnorm(p), + "3" = log(v) - (1 / phi) * log(-log1p(-p)), + "4" = log(v) - (1 / phi) * log((1 - p)^(-1 / kappa) - 1), + "5" = { a <- 1 / kappa^2; w <- log(stats::qgamma(p, a, 1) / a) / kappa; log(v) - phi * w }, + NA_real_ + ) +} + +# Log-density, matching dist_logpdf_fun in the .stan files exactly (families +# 1/3/4/5 only - gamma, family 2, never calls this since it keeps the fixed +# panel count). +.dist_logpdf_r <- function(x, dist_type, loc, phi, kappa) { + switch(as.character(dist_type), + "1" = stats::dlnorm(x, meanlog = loc, sdlog = phi, log = TRUE), + "3" = stats::dweibull(x, shape = phi, scale = exp(loc), log = TRUE), + "4" = { u <- log(x) - loc; log_term <- log1p(exp(phi * u)) + log(phi) + log(kappa) + (phi - 1) * u - loc - (kappa + 1) * log_term }, + "5" = { a <- 1 / kappa^2; w <- (log(x) - loc) / phi + log(kappa) - log(phi) - log(x) + a * log(a) + a * kappa * w - a * exp(kappa * w) - lgamma(a) }, + NA_real_ + ) +} + +# Quick per-dataset method-of-moments phi guess, mirroring update_phi_prior() +# (kept as a separate, self-contained copy rather than refactoring that +# already-validated function, to avoid any risk of disturbing it). +.mom_phi_guess <- function(d, dist_type, log_kappa_mean) { + dist_name <- c("1" = "lognormal", "2" = "gamma", "3" = "weibull", + "4" = "burr12", "5" = "gengamma")[[as.character(dist_type)]] + kappa_val <- exp(log_kappa_mean) + mean_est <- sd_est <- NA_real_ + if (!is.null(d$mean) && !is.null(d$sd)) { mean_est <- d$mean; sd_est <- d$sd + } else if (!is.null(d$median) && !is.null(d$Q1) && !is.null(d$Q3)) { mean_est <- d$median; sd_est <- (d$Q3 - d$Q1) / 1.35 + } else if (!is.null(d$median) && !is.null(d$min) && !is.null(d$max)) { mean_est <- d$median; sd_est <- (d$max - d$min) / 4 + } + if (is.na(mean_est) || is.na(sd_est) || sd_est <= 0) return(NA_real_) + tryCatch(switch(dist_name, + lognormal = sqrt(log(1 + (sd_est / mean_est)^2)), + weibull = { cv <- sd_est / mean_est + stats::uniroot(function(k) sqrt(gamma(1 + 2/k) / gamma(1 + 1/k)^2 - 1) - cv, c(0.1, 200))$root }, + gengamma = { cv <- sd_est / mean_est; gs <- 1 / kappa_val^2 + stats::uniroot(function(s) { a1 <- gs + s/kappa_val; a2 <- gs + 2*s/kappa_val + sqrt(max(exp(lgamma(a2) + lgamma(gs) - 2*lgamma(a1)) - 1, 0)) - cv }, c(1e-6, 20))$root }, + burr12 = { cv <- sd_est / mean_est; lower_c <- 2/kappa_val + 1e-6 + stats::uniroot(function(c_val) { lb1 <- lbeta(kappa_val - 1/c_val, 1 + 1/c_val); lb2 <- lbeta(kappa_val - 2/c_val, 1 + 2/c_val) + sqrt(exp(lb2 - log(kappa_val) - 2*lb1) - 1) - cv }, c(lower_c, 50))$root } + ), error = function(e) NA_real_) +} + +# Per-order-statistic panel count. Falls back to the original fixed 24 (i.e. +# never worse than before) whenever the MoM guess or density evaluation is +# unavailable or non-finite. +.order_stat_n_panels <- function(v, n, k, resolution, dist_type, phi_guess, kappa_guess) { + if (dist_type == 2L) return(24L) + if (is.na(phi_guess) || phi_guess <= 0 || is.na(v) || v <= 0) return(24L) + + margin_phi <- switch(as.character(dist_type), + "1" = phi_guess * 0.6, "5" = phi_guess * 0.6, # spread-type: danger = phi too LOW + "3" = phi_guess * 2.0, "4" = phi_guess * 2.0, # concentration-type: danger = phi too HIGH + phi_guess + ) + p <- k / (n + 1) + loc <- tryCatch(.solve_loc_for_quantile(v, p, dist_type, margin_phi, kappa_guess), error = function(e) NA_real_) + if (is.na(loc) || !is.finite(loc)) return(24L) + logf <- tryCatch(.dist_logpdf_r(v, dist_type, loc, margin_phi, kappa_guess), error = function(e) NA_real_) + if (is.na(logf) || !is.finite(logf)) return(24L) + + se_asymp <- sqrt(p * (1 - p) / n) / exp(logf) + rho <- resolution / se_asymp + .panels_from_rho(rho) +} + # Data-driven phi prior ---------------------------------------------------- @@ -1449,10 +1624,12 @@ pre_inference_checks <- function(datasets, results$prior_predictive <- prior_df # ── Check 3: MAP optimisation probe ─────────────────────────────────────── + # phi_map reads log_phi0 (population-mean dispersion), the point-4 + # hierarchical model's analogue of the old shared scalar log_phi. map_result <- tryCatch({ opt <- rstan::optimizing(stan_model, data = stan_data, hessian = FALSE, refresh = 0) - phi_map <- exp(opt$par[["log_phi"]]) + phi_map <- exp(opt$par[["log_phi0"]]) list(phi_map = phi_map, map_converged = opt$return_code == 0, return_code = opt$return_code) }, error = function(e) { @@ -1462,15 +1639,26 @@ pre_inference_checks <- function(datasets, results$map_probe <- map_result # ── Check 4: Log-likelihood surface scan ────────────────────────────────── - mu0_init <- stan_data$mu0_mean - log_tau_init <- stan_data$log_tau_mean - loc_d_raw_init <- rep(0, stan_data$n_datasets) + # unconstrain_pars() needs a value for every declared parameter, so this + # must list all of the point-4 hierarchical model's parameters (mu0, + # log_tau, log_phi0, log_omega, log_kappa, loc_d_raw, log_phi_d_raw), not + # just the ones this check varies. log_phi_d_raw is fixed at zero so each + # phi_val is evaluated at phi_d[d] == phi0 for every dataset (no + # between-study deviation), i.e. the population-mean surface. + mu0_init <- stan_data$mu0_mean + log_tau_init <- stan_data$log_tau_mean + log_kappa_init <- stan_data$log_kappa_mean + loc_d_raw_init <- rep(0, stan_data$n_datasets) + log_phi_d_raw_init <- rep(0, stan_data$n_datasets) ll_surface <- purrr::map_dfr(phi_grid, function(phi_val) { - pars <- list(mu0 = mu0_init, - log_tau = log_tau_init, - log_phi = log(phi_val), - loc_d_raw = loc_d_raw_init) + pars <- list(mu0 = mu0_init, + log_tau = log_tau_init, + log_phi0 = log(phi_val), + log_omega = stan_data$log_omega_mean, + log_kappa = log_kappa_init, + loc_d_raw = loc_d_raw_init, + log_phi_d_raw = log_phi_d_raw_init) lp <- tryCatch({ rstan::log_prob(stan_model, rstan::unconstrain_pars(stan_model, data = stan_data, pars = pars), @@ -1514,7 +1702,10 @@ pre_inference_checks <- function(datasets, rhat = NA_real_, n_eff = NA_real_)) } - s <- rstan::summary(fit, pars = "phi")$summary + # phi_d (not phi): the point-4 hierarchical model has no shared scalar + # phi. With n_datasets == 1 here, phi_d is a length-1 vector, giving the + # same single-dataset posterior the old shared phi used to. + s <- rstan::summary(fit, pars = "phi_d")$summary tibble::tibble(dataset = name, phi_mean = s[, "mean"], phi_lo = s[, "2.5%"], @@ -2086,11 +2277,13 @@ generate_scenario_library <- function(include_homogeneous = TRUE, make_stan_init_fn <- function(stan_data) { function() { list( - mu0 = stan_data$mu0_mean, - log_tau = stan_data$log_tau_mean, - log_phi = stan_data$log_phi_mean, - log_kappa = stan_data$log_kappa_mean, - loc_d_raw = rep(0.0, stan_data$n_datasets) + mu0 = stan_data$mu0_mean, + log_tau = stan_data$log_tau_mean, + log_phi0 = stan_data$log_phi_mean, + log_omega = stan_data$log_omega_mean, + log_kappa = stan_data$log_kappa_mean, + loc_d_raw = rep(0.0, stan_data$n_datasets), + log_phi_d_raw = rep(0.0, stan_data$n_datasets) ) } } @@ -2128,6 +2321,202 @@ fit_model <- function(sim_data, stan_model, ) } +#' Fit a Stan model with escalating settings, stopping once Rhat is acceptable +#' +#' @description +#' Tries a sequence of increasingly conservative sampling settings, stopping +#' at the first tier that achieves `max(Rhat) < rhat_target` with no +#' divergent transitions. Falls all the way back to the original +#' pre-lever-1 production settings (`iter=12000`, `adapt_delta=0.999`, +#' `max_treedepth=12`) as the last tier if cheaper settings do not converge - +#' those settings were originally chosen because some chains did not +#' converge without them (see `REVISION_TODO.md`), so this is a floor, not +#' just a starting point to relax. +#' +#' Most fits are expected to converge at the cheap first tier, especially +#' now that lever 3 (`R/utils.R`'s `.order_stat_n_panels()`) has reduced +#' per-iteration cost and point 4's family gating +#' (`POINT4_LIKELIHOOD_MATHS.md` Part E) means gamma no longer needs a +#' hierarchical `phi_d` funnel resolved. The escalation ladder exists for the +#' cases that still need it, not as the expected path. +#' +#' @param stan_data Data list for `rstan::sampling()`. +#' @param stan_model Compiled Stan model. +#' @param rhat_target Escalate if `max(Rhat)` exceeds this. Default 1.05, +#' matching the target agreed for the point 1/4 checkpoint run. +#' @param seed Passed to every tier for reproducibility. +#' @param init Optional init argument passed to every tier (e.g. +#' `make_stan_init_fn(stan_data)`); default `NULL` uses Stan's own default. +#' @param verbose If `TRUE` (default), reports which tier was used and why. +#' @return A list: `fit` (the `stanfit` object from whichever tier +#' succeeded, or the last tier tried if none converged), `tier` (integer, +#' which tier succeeded or was last attempted), `max_rhat`, `divergences`, +#' `converged` (logical), and `runtime_secs` (total across all tiers +#' attempted). +#' @export +fit_with_escalation <- function(stan_data, stan_model, rhat_target = 1.05, + seed = 123, init = NULL, verbose = TRUE) { + tiers <- list( + list(label = "cheap", chains = 4, iter = 4000, warmup = 2000, control = list(adapt_delta = 0.9, max_treedepth = 10)), + list(label = "moderate", chains = 4, iter = 6000, warmup = 2000, control = list(adapt_delta = 0.95, max_treedepth = 11)), + # Original production settings (main_analysis.R, pre-lever-1): kept + # verbatim as the final fallback, not relaxed, because they were + # originally added after some chains failed to converge without them. + list(label = "production", chains = 4, iter = 12000, warmup = 2000, control = list(adapt_delta = 0.999, max_treedepth = 12)) + ) + + t_total0 <- Sys.time() + result <- NULL + best <- NULL # best-so-far by (max_rhat, div_rate), in case no tier fully converges + for (i in seq_along(tiers)) { + tier <- tiers[[i]] + if (verbose) message(sprintf(" [fit_with_escalation] trying tier %d/%d ('%s': iter=%d, adapt_delta=%.3f)...", + i, length(tiers), tier$label, tier$iter, tier$control$adapt_delta)) + fit <- tryCatch( + rstan::sampling(stan_model, data = stan_data, chains = tier$chains, iter = tier$iter, + warmup = tier$warmup, control = tier$control, seed = seed, + init = if (is.null(init)) "random" else init, refresh = 0, + show_messages = FALSE), + error = function(e) { if (verbose) message(" tier failed to run: ", conditionMessage(e)); NULL } + ) + if (is.null(fit)) next + + s <- rstan::summary(fit)$summary + max_rhat <- max(s[, "Rhat"], na.rm = TRUE) + sp <- rstan::get_sampler_params(fit, inc_warmup = FALSE) + div <- sum(sapply(sp, function(x) sum(x[, "divergent__"]))) + n_draws <- sum(sapply(sp, nrow)) + div_rate <- div / n_draws + # A handful of divergences out of thousands of draws is ordinary HMC + # noise, not a sign of a bad fit; requiring exactly zero caused endless, + # pointless escalation for datasets with a small structural divergence + # rate (e.g. Burr XII, already known from this session's diagnostics to + # run somewhat divergence-prone even at good settings). 1% mirrors + # common Stan-community practice for "acceptably rare, not ignorable" + # divergence rates. + converged <- is.finite(max_rhat) && max_rhat < rhat_target && div_rate < 0.01 + + if (verbose) message(sprintf(" max_Rhat=%.4f, divergences=%d/%d (%.2f%%) -> %s", + max_rhat, div, n_draws, 100 * div_rate, if (converged) "OK" else "escalating")) + + result <- list(fit = fit, tier = i, tier_label = tier$label, max_rhat = max_rhat, + divergences = div, div_rate = div_rate, converged = converged) + if (converged) break + # Track the best-so-far result (lower max_rhat wins; div_rate breaks ties) + # so that if no tier converges, we return the least-bad attempt rather + # than just whichever tier happened to run last. + if (is.null(best) || max_rhat < best$max_rhat || + (max_rhat == best$max_rhat && div_rate < best$div_rate)) { + best <- result + } + } + + if (is.null(result)) { + stop("fit_with_escalation: every tier failed to sample (see messages above).", call. = FALSE) + } + if (!result$converged && !is.null(best) && best$max_rhat <= result$max_rhat && best$tier != result$tier) { + result <- best + } + result$runtime_secs <- as.numeric(Sys.time() - t_total0, units = "secs") + if (verbose && !result$converged) { + message(" [fit_with_escalation] WARNING: did not reach Rhat<", rhat_target, + " even at the production tier (max_Rhat=", round(result$max_rhat, 4), ").") + } + result +} + +#' Fit a list of (dataset, family) tasks concurrently, leaving cores free +#' +#' @description +#' Runs [fit_with_escalation()] over a list of independent fitting tasks in +#' parallel (fork-based, via `parallel::mclapply()` - Unix/macOS only), each +#' task's chains still parallelised internally as usual. Deliberately caps +#' total core usage well below the machine's full core count so the machine +#' remains usable for other work while a corpus run is in progress - this is +#' a hard requirement, not a tuning default: leave `reserve_cores` alone +#' unless the person running this has explicitly said otherwise. +#' +#' Each task's result is written to its own file immediately on completion +#' (`task$output_file`), rather than accumulating in a single shared +#' in-memory list written once at the end - this avoids concurrent workers +#' racing on one output file, and means a crash partway through loses only +#' the tasks that hadn't finished, not everything. Call +#' [merge_parallel_fit_results()] afterwards to assemble the per-task files +#' into a single results list. +#' +#' @param tasks A list of task specifications, each a list with: +#' `label` (character, for logging), `datasets` (named list, as passed to +#' [prepare_stan_data_from_datasets()]), `dist_name` (one of "lognormal", +#' "gamma", "weibull", "burr", "gengamma"), `stan_model` (compiled model to +#' use for this task - the caller decides hierarchical vs. shared-phi per +#' family, see `analysis/main_analysis.R`'s `SHARED_PHI_FAMILIES`), and +#' `output_file` (path to save this task's result to). +#' @param chains_per_fit Chains used within each individual fit (passed to +#' [fit_with_escalation()] tiers implicitly - currently fixed at 4 within +#' that function; this argument only affects the core-budget arithmetic +#' below, so keep it in sync if that changes). +#' @param reserve_cores Cores to leave free for other use on the machine. +#' Default 4 (out of this machine's 12), leaving meaningful headroom for +#' interactive use, not just background slack - do not reduce this without +#' explicit instruction. +#' @param rhat_target Passed through to [fit_with_escalation()]. +#' @return Invisibly, a character vector of the `output_file` paths written +#' (some may be missing if a task errored - check before merging). +#' @export +fit_corpus_parallel <- function(tasks, chains_per_fit = 4, reserve_cores = 4, + rhat_target = 1.05) { + total_cores <- parallel::detectCores() + usable_cores <- max(total_cores - reserve_cores, chains_per_fit) + n_concurrent <- max(floor(usable_cores / chains_per_fit), 1) + message(sprintf( + "fit_corpus_parallel: %d cores detected, reserving %d, running up to %d fits concurrently (%d tasks total).", + total_cores, reserve_cores, n_concurrent, length(tasks) + )) + + parallel::mclapply(tasks, function(task) { + dist_type <- c(lognormal = 1L, gamma = 2L, weibull = 3L, burr = 4L, gengamma = 5L)[[task$dist_name]] + stan_data <- tryCatch( + prepare_stan_data_from_datasets(task$datasets, dist_type = dist_type), + error = function(e) { message(" [", task$label, "] prepare_stan_data failed: ", conditionMessage(e)); NULL } + ) + if (is.null(stan_data)) { saveRDS(list(error = "prepare_stan_data failed"), task$output_file); return(invisible(NULL)) } + stan_data <- update_phi_prior(stan_data, task$datasets) + + res <- tryCatch( + fit_with_escalation(stan_data, task$stan_model, rhat_target = rhat_target, verbose = TRUE), + error = function(e) { message(" [", task$label, "] fit_with_escalation failed: ", conditionMessage(e)); NULL } + ) + out <- if (is.null(res)) list(error = "fit_with_escalation failed") else + list(fit = res$fit, stan_data = stan_data, datasets = task$datasets, tier = res$tier_label, + max_rhat = res$max_rhat, divergences = res$divergences, converged = res$converged, + runtime_secs = res$runtime_secs) + saveRDS(out, task$output_file) + invisible(NULL) + }, mc.cores = n_concurrent) + + invisible(vapply(tasks, function(t) t$output_file, character(1))) +} + +#' Assemble per-task .rds files from [fit_corpus_parallel()] into one list +#' +#' @param output_files Character vector of file paths (as returned by +#' [fit_corpus_parallel()]). +#' @param labels Character vector, same length, used as names in the +#' returned list (typically `"."`). +#' @return A named list of the per-task results; entries for missing files +#' are `NULL` with a message, not a hard error, so a partially-complete +#' run can still be assembled and inspected. +#' @export +merge_parallel_fit_results <- function(output_files, labels) { + stats::setNames(lapply(seq_along(output_files), function(i) { + if (!file.exists(output_files[i])) { + message("merge_parallel_fit_results: missing (not yet run or failed): ", labels[i]) + return(NULL) + } + readRDS(output_files[i]) + }), labels) +} + #' Compute coverage for a parameter #' #' @param fit Stan fit object From ab008efce5d9f5028d2a70b5b5963aa32ef4222a Mon Sep 17 00:00:00 2001 From: cm401 Date: Mon, 3 Aug 2026 14:23:48 +0100 Subject: [PATCH 09/30] allow for shared phi models --- analysis/main_analysis.R | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/analysis/main_analysis.R b/analysis/main_analysis.R index 9c5d2ab..bb958eb 100644 --- a/analysis/main_analysis.R +++ b/analysis/main_analysis.R @@ -194,8 +194,17 @@ subgroup_config <- list( ) -# ── 5. Compile Stan model (once) ────────────────────────────────────────────── +# ── 5. Compile Stan models (once) ───────────────────────────────────────────── # Set to "factorised" (default) or "joint" to switch between Stan models. +# +# Two models are compiled per STAN_MODEL choice: the hierarchical per-study +# `phi_d` model (used for lognormal, Weibull, Burr XII, and gengamma when +# should_attempt_gg() passes), and the pre-point-4 shared-scalar-`phi` model +# (used for gamma). See POINT4_LIKELIHOOD_MATHS.md Part E.5: gamma's shape +# parameter is a concentration-type parameter whose per-study information +# vanishes as phi grows, creating a genuine hierarchical funnel (not just a +# prior-calibration problem) rather than a family that can safely take the +# phi_d/omega reparameterization. STAN_MODEL <- "factorised" if (!STAN_MODEL %in% c("factorised", "joint")) stop('STAN_MODEL must be "factorised" or "joint", got: "', STAN_MODEL, '"') @@ -204,11 +213,28 @@ stan_model_file <- switch(STAN_MODEL, factorised = "hierarchical_data_synthesis_summary_stats.stan", joint = "hierarchical_data_synthesis_summary_stats_joint.stan" ) +stan_model_shared_phi_file <- switch(STAN_MODEL, + factorised = "hierarchical_data_synthesis_summary_stats_shared_phi.stan", + joint = "hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan" +) + stan_file <- system.file("stan", stan_model_file, package = "ddsynth") if (!nzchar(stan_file)) stop("Stan file '", stan_model_file, "' not found in ddsynth installation.") stan_model <- rstan::stan_model(stan_file) +stan_file_shared_phi <- system.file("stan", stan_model_shared_phi_file, package = "ddsynth") +if (!nzchar(stan_file_shared_phi)) + stop("Stan file '", stan_model_shared_phi_file, "' not found in ddsynth installation.") +stan_model_shared_phi <- rstan::stan_model(stan_file_shared_phi) + +# Families using the hierarchical phi_d model vs. the shared-scalar-phi model +# (POINT4_LIKELIHOOD_MATHS.md Part E.5). Gen. gamma is hierarchical whenever +# it is attempted at all (the should_attempt_gg() gate below already decides +# whether to attempt it, per Part E.5's "two sequential gates" requirement). +HIERARCHICAL_FAMILIES <- c("lognormal", "weibull", "burr", "gengamma") +SHARED_PHI_FAMILIES <- c("gamma") + # ── 6. Helper: fit one (dataset list, distribution) combination ────────────── @@ -227,9 +253,11 @@ stan_model <- rstan::stan_model(stan_file) stan_data <- update_phi_prior(stan_data, datasets) + model_to_use <- if (dist_name %in% SHARED_PHI_FAMILIES) stan_model_shared_phi else stan_model + fit <- tryCatch( rstan::sampling( - stan_model, + model_to_use, data = stan_data, chains = CHAINS, iter = ITER, From 46e77018321cd1b2af9ae2b8847eb28eb7b62328 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:29:51 +0100 Subject: [PATCH 10/30] Add functions to check datasets + heuristics Extend more fully across distributions --- R/utils.R | 371 ++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 335 insertions(+), 36 deletions(-) diff --git a/R/utils.R b/R/utils.R index 3fc5441..1d6c846 100644 --- a/R/utils.R +++ b/R/utils.R @@ -468,7 +468,7 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, # not previously produce this failure mode; with phi now hierarchical # per-dataset, a too-tight shared omega prior caused a severe funnel/mixing # pathology for gamma specifically (Rhat > 100) that resolved once - # family-specific scale was used. See REVISION_TODO.md, point 4. + # family-specific scale was used. # # kappa meaning per distribution: # dist 1-3: kappa is unused; wide uninformative prior centred at 1. @@ -497,7 +497,7 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, # above); log_omega_sd is left flat at 0.5 across families, matching # the log_tau_sd=0.5 convention already used here - it is a generic # uncertainty width on top of the point estimate, not itself - # data-derived per family. See REVISION_TODO.md, point 4. + # data-derived per family. log_omega_mean = dist_defaults$log_omega_mean, log_omega_sd = 0.5, log_kappa_mean = dist_defaults$log_kappa_mean, @@ -821,8 +821,7 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, stan_data$log_kappa_sd <- custom_priors$log_kappa_sd # Per-order-statistic adaptive quadrature panel count (performance lever, - # not a correctness change): see POINT1_LIKELIHOOD_MATHS.md Part G for the - # derivation. A wrong choice here only costs efficiency (or triggers + # not a correctness change). A wrong choice here only costs efficiency (or triggers # pre_inference_checks()-style convergence issues, handled by the settings # escalation in fit_with_escalation()), since the underlying quadrature # maths is unchanged - it just decides how many panels to spend. @@ -858,8 +857,7 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, # Adaptive quadrature panel count for order-statistic rounding likelihoods -- # -# See POINT1_LIKELIHOOD_MATHS.md Part G for the full derivation. Summary: the -# panel count needed for the composite Gauss-Legendre quadrature +# Summary: the panel count needed for the composite Gauss-Legendre quadrature # (order_stat_rounded_loglik_fun in the .stan files) to hit the same accuracy # as the original fixed 24-panel scheme is, empirically, a clean function of # rho = resolution / SE_asymptotic(order statistic) - not of n or family @@ -1301,6 +1299,88 @@ should_attempt_gg <- function(datasets, } +# Burr XII per-study phi_d reliability heuristic ------------------------------- + +#' Check whether Burr XII's per-study dispersion hierarchy is safe to attempt +#' +#' Burr XII's mean+SD likelihood needs kappa*phi_d[d] > 4 per dataset (see +#' the Stan model's summary_type==3 branch); under the per-study phi_d +#' hierarchy this becomes n simultaneous constraints instead of one, which +#' can fragment the feasible region into separate modes. Detected here via a +#' cheap empirical stress test (several random-init `optimizing()` calls) +#' rather than a closed-form margin, which turned out unreliable in +#' practice. +#' +#' @param datasets A named list of datasets as accepted by +#' [prepare_stan_data_from_datasets()]. +#' @param stan_model The compiled hierarchical Burr XII model +#' (`dist_type = 4`), not the shared-phi variant. +#' @param n_starts Number of random-init `rstan::optimizing()` calls. +#' @param min_success_frac Minimum fraction of starts that must converge. +#' @param lp_agreement_tol Max log-posterior spread across successful starts +#' before they're judged to be different modes. +#' @param verbose Print a one-line verdict. +#' +#' @return `TRUE` if safe to attempt the per-study hierarchy, `FALSE` if it +#' should fall back to shared-phi. Always `TRUE` when there are no +#' mean+SD datasets (the constraint can't fire). +#' @export +burr_phid_reliable <- function(datasets, stan_model, n_starts = 10, + min_success_frac = 0.3, lp_agreement_tol = 1.0, + verbose = TRUE) { + + n_type3 <- sum(vapply(datasets, function(d) !is.null(d$mean) && !is.null(d$sd), logical(1))) + if (n_type3 == 0) { + if (verbose) message("burr_phid_reliable: OK — no mean+SD datasets, the 4th-moment constraint never fires.") + return(TRUE) + } + + stan_data <- tryCatch({ + sd_ <- prepare_stan_data_from_datasets(datasets, dist_type = 4L) + update_phi_prior(sd_, datasets) + }, error = function(e) NULL) + if (is.null(stan_data)) { + if (verbose) message("burr_phid_reliable: SKIP — data prep failed; defaulting to shared phi to be safe.") + return(FALSE) + } + + codes <- numeric(0); vals <- numeric(0) + for (i in seq_len(n_starts)) { + opt <- tryCatch( + rstan::optimizing(stan_model, data = stan_data, seed = 10000 + i, hessian = FALSE, + as_vector = FALSE, init = "random"), + error = function(e) NULL + ) + if (!is.null(opt)) { codes <- c(codes, opt$return_code); vals <- c(vals, opt$value) } + } + + n_success <- sum(codes == 0) + success_frac <- n_success / n_starts + if (success_frac < min_success_frac) { + if (verbose) message(sprintf( + "burr_phid_reliable: SKIP — too many optimiser failures (%d/%d succeeded, need >= %.0f%%); ", + n_success, n_starts, 100 * min_success_frac), + sprintf("the kappa*phi_d>4 reject likely fragments the feasible region across %d mean+SD dataset(s).", + n_type3)) + return(FALSE) + } + + lp_success <- vals[codes == 0] + lp_range <- if (length(lp_success) > 1) diff(range(lp_success)) else 0 + if (lp_range > lp_agreement_tol) { + if (verbose) message(sprintf( + "burr_phid_reliable: SKIP — successful starts disagree (log-posterior range = %.2f > %.2f), multiple modes found.", + lp_range, lp_agreement_tol)) + return(FALSE) + } + + if (verbose) message(sprintf( + "burr_phid_reliable: OK — %d/%d optimiser starts succeeded and agree (log-posterior range = %.2e).", + n_success, n_starts, lp_range)) + TRUE +} + + # Gamma + type-2 reliability heuristic ---------------------------------------- #' Check whether Gamma can be reliably fitted from median + IQR summary statistics @@ -1428,6 +1508,72 @@ gamma_type2_reliable <- function(datasets, } +# Gamma numerical-fragility heuristic (grad_reg_lower_inc_gamma) -------------- + +#' Check whether a corpus is safe from gamma's slow-incomplete-gamma-series risk +#' +#' An extreme method-of-moments-implied gamma shape (often a small-n +#' `(max-min)/4` artifact) can drive NUTS into Stan's slow +#' `grad_reg_lower_inc_gamma` series during warmup, hanging for hours +#' without erroring. Not caught by `pre_inference_checks()`'s lognormal-proxy +#' filter. +#' +#' @param datasets A named list of datasets as accepted by +#' [prepare_stan_data_from_datasets()]. +#' @param max_implied_phi Skip if any dataset's implied gamma shape exceeds +#' this. +#' @param verbose Print a one-line verdict naming the offending dataset. +#' +#' @return `TRUE` if safe, `FALSE` if gamma should be skipped for this +#' pathogen/analysis (no fallback model exists, unlike Burr XII's +#' [burr_phid_reliable()]). +#' @export +gamma_phi_extreme_safe <- function(datasets, max_implied_phi = 60, verbose = TRUE) { + + implied_phi <- vapply(datasets, function(d) { + mean_est <- sd_est <- NA_real_ + if (!is.null(d$mean) && !is.null(d$sd)) { + mean_est <- d$mean; sd_est <- d$sd + } else if (!is.null(d$median) && !is.null(d$Q1) && !is.null(d$Q3)) { + mean_est <- d$median; sd_est <- (d$Q3 - d$Q1) / 1.35 + } else if (!is.null(d$median) && !is.null(d$min) && !is.null(d$max)) { + mean_est <- d$median; sd_est <- (d$max - d$min) / 4 + } else if (!is.null(d$freq_value) && !is.null(d$freq_count)) { + w <- d$freq_count / sum(d$freq_count) + mean_est <- sum(d$freq_value * w) + sd_est <- sqrt(sum(w * (d$freq_value - mean_est)^2)) + } else if (!is.null(d$freq_lower) && !is.null(d$freq_upper) && !is.null(d$freq_count)) { + mid <- (d$freq_lower + d$freq_upper) / 2 + w <- d$freq_count / sum(d$freq_count) + mean_est <- sum(mid * w) + sd_est <- sqrt(sum(w * (mid - mean_est)^2)) + } + if (is.na(mean_est) || is.na(sd_est) || mean_est <= 0 || sd_est <= 0) return(NA_real_) + (mean_est / sd_est)^2 + }, numeric(1)) + + implied_phi_valid <- implied_phi[!is.na(implied_phi)] + if (length(implied_phi_valid) == 0) { + if (verbose) message("gamma_phi_extreme_safe: OK \u2014 no datasets with a computable implied shape.") + return(TRUE) + } + + worst_val <- max(implied_phi_valid) + worst_name <- names(implied_phi_valid)[which.max(implied_phi_valid)] + if (worst_val > max_implied_phi) { + if (verbose) message(sprintf( + "gamma_phi_extreme_safe: SKIP \u2014 dataset '%s' implies an extreme gamma shape (%.1f > %.0f); ", + worst_name, worst_val, max_implied_phi), + "extreme shape proposals during warmup risk grad_reg_lower_inc_gamma's slow-series regime.") + return(FALSE) + } + + if (verbose) message(sprintf( + "gamma_phi_extreme_safe: OK \u2014 max implied shape = %.1f (threshold %.0f).", worst_val, max_implied_phi)) + TRUE +} + + # Compile Stan model ------------------------------------------------------- #' Compile a ddsynth Stan model @@ -1468,9 +1614,9 @@ compile_stan_model <- function(model = c("factorised", "joint")) { #' The five checks performed are: #' \describe{ #' \item{1. Method-of-moments consistency}{Estimates `phi` from each dataset -#' individually using moment-based approximations and flags any dataset -#' whose implied `phi` is more than `phi_outlier_threshold` times the -#' median of all implied values.} +#' individually (using `dist_type`'s own formula, all five families) and +#' flags a dataset if it's far from the median (`phi_outlier_threshold`) +#' or is the min/max of a set whose spread exceeds `phi_spread_threshold`.} #' \item{2. Prior predictive compatibility}{Simulates summary statistics from #' the prior and checks whether each observed value falls within the 95% #' prior predictive interval. Datasets outside this range suggest a @@ -1489,13 +1635,24 @@ compile_stan_model <- function(model = c("factorised", "joint")) { #' @param datasets A named list of datasets in the format accepted by #' [prepare_stan_data_from_datasets()]. #' @param stan_model A compiled Stan model object from [rstan::stan_model()]. +#' Must be the hierarchical per-study `phi_d` model - Checks 3-5 assume +#' that parameterisation and will error on a shared-`phi` model like +#' gamma's. Use [gamma_phi_extreme_safe()] for gamma instead. #' @param dist_type Integer distribution code: `1` = log-normal, `2` = gamma, -#' `3` = Weibull. Defaults to `1`. +#' `3` = Weibull, `4` = Burr XII, `5` = generalised gamma. Defaults to `1`. +#' Checks 1-2 use `dist_type`'s own moment formulas; Checks 3-5 assume the +#' hierarchical model regardless. #' @param custom_priors Optional named list of prior overrides passed to #' [prepare_stan_data_from_datasets()]. #' @param phi_outlier_threshold Multiplier used in the method-of-moments check. #' A dataset is flagged if its implied `phi` exceeds #' `phi_outlier_threshold * median(implied_phi)`. Defaults to `5`. +#' @param phi_spread_threshold Complementary criterion to +#' `phi_outlier_threshold`: flags the min/max datasets when +#' `max(implied_phi)/min(implied_phi)` exceeds this, catching two datasets +#' pulling toward opposite extremes (neither individually far enough from +#' the median to trip the other check). Calibrated on Weibull; +#' #' @param phi_grid Numeric vector of `phi` values for the log-likelihood #' surface scan. Defaults to `seq(0.5, 50, by = 0.5)`. #' @param n_sim Number of draws for the prior predictive check. Defaults to @@ -1532,6 +1689,7 @@ pre_inference_checks <- function(datasets, dist_type = 1, custom_priors = list(), phi_outlier_threshold = 5, + phi_spread_threshold = 7, phi_grid = seq(0.5, 50, by = 0.5), n_sim = 2000, loo_iter = 4000, @@ -1539,7 +1697,8 @@ pre_inference_checks <- function(datasets, verbose = TRUE, filter = FALSE) { - dist_name <- c("1" = "lognormal", "2" = "gamma", "3" = "weibull")[[as.character(dist_type)]] + dist_name <- c("1" = "lognormal", "2" = "gamma", "3" = "weibull", + "4" = "burr12", "5" = "gengamma")[[as.character(dist_type)]] stan_data <- prepare_stan_data_from_datasets(datasets, dist_type = dist_type, custom_priors = custom_priors) @@ -1583,7 +1742,10 @@ pre_inference_checks <- function(datasets, # CV^2 = Gamma(1+2/k)/Gamma(1+1/k)^2 - 1; solve for k obj <- function(k) sqrt(gamma(1 + 2/k) / gamma(1 + 1/k)^2 - 1) - cv tryCatch(stats::uniroot(obj, c(0.1, 200))$root, error = function(e) NA_real_) - } + }, + # Reuse .mom_phi_guess() rather than duplicate its uniroot logic. + burr12 = .mom_phi_guess(d, dist_type, stan_data$log_kappa_mean), + gengamma = .mom_phi_guess(d, dist_type, stan_data$log_kappa_mean) ) } @@ -1594,10 +1756,22 @@ pre_inference_checks <- function(datasets, med_phi <- stats::median(mom_df$implied_phi, na.rm = TRUE) mom_df <- dplyr::mutate( mom_df, - is_outlier = !is.na(implied_phi) & + is_outlier_median = !is.na(implied_phi) & (implied_phi > phi_outlier_threshold * med_phi | implied_phi < med_phi / phi_outlier_threshold) ) + + # Distance-from-median misses two datasets pulling toward opposite + # extremes at once (see Part E.10). OR-ing only adds flags, never removes. + phi_valid <- mom_df$implied_phi[!is.na(mom_df$implied_phi)] + spread <- if (length(phi_valid) >= 2) max(phi_valid) / min(phi_valid) else NA_real_ + mom_df <- dplyr::mutate( + mom_df, + is_outlier_spread = !is.na(implied_phi) & !is.na(spread) & + spread > phi_spread_threshold & + (implied_phi == max(phi_valid) | implied_phi == min(phi_valid)), + is_outlier = is_outlier_median | is_outlier_spread + ) results$mom_consistency <- mom_df # ── Check 2: Prior predictive compatibility ──────────────────────────────── @@ -1609,7 +1783,25 @@ pre_inference_checks <- function(datasets, sim_sd <- switch(dist_name, lognormal = exp(loc_draws) * sqrt(exp(phi_draws^2) - 1), gamma = exp(loc_draws) / sqrt(phi_draws), - weibull = exp(loc_draws) * sqrt(gamma(1 + 2/phi_draws) - gamma(1 + 1/phi_draws)^2) + weibull = exp(loc_draws) * sqrt(gamma(1 + 2/phi_draws) - gamma(1 + 1/phi_draws)^2), + # Raw moments matching the Stan model's own formulas; kappa_draws is + # only needed here since the other three families lack a 3rd shape param. + burr12 = { + kappa_draws <- exp(stats::rnorm(n_sim, stan_data$log_kappa_mean, stan_data$log_kappa_sd)) + lam <- exp(loc_draws) + m1 <- lam * kappa_draws * exp(lbeta(kappa_draws - 1/phi_draws, 1 + 1/phi_draws)) + m2 <- lam^2 * kappa_draws * exp(lbeta(kappa_draws - 2/phi_draws, 1 + 2/phi_draws)) + sqrt(abs(m2 - m1^2)) + }, + gengamma = { + kappa_draws <- exp(stats::rnorm(n_sim, stan_data$log_kappa_mean, stan_data$log_kappa_sd)) + gamma_shape <- 1 / kappa_draws^2 + m1 <- exp(loc_draws + 2*phi_draws/kappa_draws * log(kappa_draws) + + lgamma(gamma_shape + phi_draws/kappa_draws) - lgamma(gamma_shape)) + m2 <- exp(2*loc_draws + 4*phi_draws/kappa_draws * log(kappa_draws) + + lgamma(gamma_shape + 2*phi_draws/kappa_draws) - lgamma(gamma_shape)) + sqrt(abs(m2 - m1^2)) + } ) prior_pi <- stats::quantile(sim_sd, c(0.025, 0.975), na.rm = TRUE) @@ -2330,13 +2522,11 @@ fit_model <- function(sim_data, stan_model, #' pre-lever-1 production settings (`iter=12000`, `adapt_delta=0.999`, #' `max_treedepth=12`) as the last tier if cheaper settings do not converge - #' those settings were originally chosen because some chains did not -#' converge without them (see `REVISION_TODO.md`), so this is a floor, not -#' just a starting point to relax. +#' converge without them, so this is a floor, not just a starting point to relax. #' #' Most fits are expected to converge at the cheap first tier, especially #' now that lever 3 (`R/utils.R`'s `.order_stat_n_panels()`) has reduced -#' per-iteration cost and point 4's family gating -#' (`POINT4_LIKELIHOOD_MATHS.md` Part E) means gamma no longer needs a +#' per-iteration cost and point 4's family gating means gamma no longer needs a #' hierarchical `phi_d` funnel resolved. The escalation ladder exists for the #' cases that still need it, not as the expected path. #' @@ -2425,24 +2615,59 @@ fit_with_escalation <- function(stan_data, stan_model, rhat_target = 1.05, result } +#' Kill a process and every descendant it has forked +#' +#' `tools::pskill()` only kills the named PID. `rstan::sampling()` spawns its +#' own PSOCK cluster underneath, which would otherwise survive as zombies. +#' Walks `ps`'s process table to find and kill all descendants too. +#' +#' @param pid Integer or character process ID to kill, with its descendants. +#' @return Invisibly, the PIDs killed (including `pid`). +#' @noRd +.kill_process_tree <- function(pid) { + pid <- as.integer(pid) + tab <- tryCatch({ + lines <- system2("ps", c("-eo", "pid,ppid"), stdout = TRUE)[-1] + do.call(rbind, lapply(strsplit(trimws(lines), "\\s+"), function(x) as.integer(x[1:2]))) + }, error = function(e) NULL) + + all_pids <- pid + if (!is.null(tab) && nrow(tab) > 0) { + colnames(tab) <- c("pid", "ppid") + descendants_of <- function(root) { + kids <- tab[tab[, "ppid"] == root, "pid"] + if (length(kids) == 0) return(integer(0)) + c(kids, unlist(lapply(kids, descendants_of), use.names = FALSE)) + } + all_pids <- c(pid, descendants_of(pid)) + } + for (p in all_pids) tryCatch(tools::pskill(p, signal = tools::SIGKILL), error = function(e) NULL) + invisible(all_pids) +} + #' Fit a list of (dataset, family) tasks concurrently, leaving cores free #' #' @description -#' Runs [fit_with_escalation()] over a list of independent fitting tasks in -#' parallel (fork-based, via `parallel::mclapply()` - Unix/macOS only), each -#' task's chains still parallelised internally as usual. Deliberately caps -#' total core usage well below the machine's full core count so the machine -#' remains usable for other work while a corpus run is in progress - this is -#' a hard requirement, not a tuning default: leave `reserve_cores` alone -#' unless the person running this has explicitly said otherwise. -#' -#' Each task's result is written to its own file immediately on completion -#' (`task$output_file`), rather than accumulating in a single shared -#' in-memory list written once at the end - this avoids concurrent workers -#' racing on one output file, and means a crash partway through loses only -#' the tasks that hadn't finished, not everything. Call -#' [merge_parallel_fit_results()] afterwards to assemble the per-task files -#' into a single results list. +#' Runs [fit_with_escalation()] over a list of independent fitting tasks with +#' bounded concurrency (fork-based - Unix/macOS only), each task's chains +#' still parallelised internally as usual. Deliberately caps total core +#' usage well below the machine's full core count so the machine remains +#' usable for other work while a corpus run is in progress - this is a hard +#' requirement, not a tuning default: leave `reserve_cores` alone unless the +#' person running this has explicitly said otherwise. +#' +#' Streams rather than batches: uses a manually-managed rolling pool +#' (`parallel::mcparallel()`/`mccollect()`, not `mclapply()`) so a finished +#' slot is immediately handed the next queued task instead of waiting for +#' the whole set dispatched together to finish - this both keeps the core +#' pool continuously busy (a straggler task no longer stalls an entire +#' batch) and lets `on_complete` fire the moment *each* task finishes, not +#' just at the end. Each task's result is still also written to its own +#' file immediately on completion (`task$output_file`) regardless of +#' `on_complete`, so a crash partway through loses only the tasks that +#' hadn't finished yet, not everything; [merge_parallel_fit_results()] can +#' assemble those files after the fact if `on_complete` wasn't used to do it +#' incrementally. #' #' @param tasks A list of task specifications, each a list with: #' `label` (character, for logging), `datasets` (named list, as passed to @@ -2460,11 +2685,24 @@ fit_with_escalation <- function(stan_data, stan_model, rhat_target = 1.05, #' interactive use, not just background slack - do not reduce this without #' explicit instruction. #' @param rhat_target Passed through to [fit_with_escalation()]. +#' @param on_complete Optional `function(task, result)`, called in the +#' parent process as soon as each task finishes (`result` is the same list +#' already saved to `task$output_file`, or `list(error=...)` on failure). +#' Intended for incremental merge-and-save into a caller-side results +#' object, e.g. via `<<-` from a top-level analysis script - see +#' `analysis/main_analysis.R` for the pattern. Errors inside the callback +#' are caught and reported, not allowed to take down the whole run. +#' @param task_timeout_secs Wall-clock ceiling per task (all escalation tiers +#' combined), default 5400 (90 min). Guards against a chain wandering into +#' a genuinely slow numerical region and grinding forever without +#' erroring. Past this, the task is killed and recorded with +#' `error = "timed out after s"`. #' @return Invisibly, a character vector of the `output_file` paths written #' (some may be missing if a task errored - check before merging). #' @export fit_corpus_parallel <- function(tasks, chains_per_fit = 4, reserve_cores = 4, - rhat_target = 1.05) { + rhat_target = 1.05, on_complete = NULL, + task_timeout_secs = 90 * 60) { total_cores <- parallel::detectCores() usable_cores <- max(total_cores - reserve_cores, chains_per_fit) n_concurrent <- max(floor(usable_cores / chains_per_fit), 1) @@ -2473,7 +2711,7 @@ fit_corpus_parallel <- function(tasks, chains_per_fit = 4, reserve_cores = 4, total_cores, reserve_cores, n_concurrent, length(tasks) )) - parallel::mclapply(tasks, function(task) { + run_task <- function(task) { dist_type <- c(lognormal = 1L, gamma = 2L, weibull = 3L, burr = 4L, gengamma = 5L)[[task$dist_name]] stan_data <- tryCatch( prepare_stan_data_from_datasets(task$datasets, dist_type = dist_type), @@ -2492,7 +2730,68 @@ fit_corpus_parallel <- function(tasks, chains_per_fit = 4, reserve_cores = 4, runtime_secs = res$runtime_secs) saveRDS(out, task$output_file) invisible(NULL) - }, mc.cores = n_concurrent) + } + + pending <- tasks + in_flight <- list() # keyed by PID (as character) -> task spec + started_at <- list() # keyed by PID (as character) -> Sys.time() at launch + + launch_next <- function() { + if (length(pending) == 0) return(invisible(FALSE)) + task <- pending[[1]] + pending <<- pending[-1] + job <- parallel::mcparallel(run_task(task), silent = TRUE) + pid <- as.character(job$pid) + in_flight[[pid]] <<- task + started_at[[pid]] <<- Sys.time() + invisible(TRUE) + } + + # Handles one task reaching a terminal state (normal completion or forced + # timeout) identically: bookkeeping, on_complete, and refilling the slot. + finish_task <- function(pid, result) { + task <- in_flight[[pid]] + in_flight[[pid]] <<- NULL + started_at[[pid]] <<- NULL + n_done <<- n_done + 1L + message(sprintf(" [fit_corpus_parallel] completed %d/%d: %s", n_done, length(tasks), task$label)) + if (!is.null(on_complete)) { + tryCatch(on_complete(task, result), error = function(e) + message(" [fit_corpus_parallel] on_complete callback failed for ", task$label, ": ", conditionMessage(e))) + } + launch_next() + } + + while (length(pending) > 0 && length(in_flight) < n_concurrent) launch_next() + + n_done <- 0L + while (length(in_flight) > 0) { + done <- parallel::mccollect(wait = FALSE) + for (pid in intersect(names(done), names(in_flight))) { + task <- in_flight[[pid]] + result <- if (file.exists(task$output_file)) readRDS(task$output_file) else list(error = "no output file written") + finish_task(pid, result) + } + + # Kill anything that has overrun the wall-clock budget - a fit stuck in a + # pathologically slow numerical region never errors or returns on its + # own, so this is the only thing that reclaims the slot (see + # @param task_timeout_secs above for why this is necessary at all). + now <- Sys.time() + timed_out <- Filter(function(pid) as.numeric(now - started_at[[pid]], units = "secs") > task_timeout_secs, + names(in_flight)) + for (pid in timed_out) { + task <- in_flight[[pid]] + killed <- .kill_process_tree(pid) + message(sprintf(" [fit_corpus_parallel] TIMEOUT after %ds, killed pid %s and %d descendant(s): %s", + task_timeout_secs, pid, length(killed) - 1L, task$label)) + result <- list(error = sprintf("timed out after %ds", task_timeout_secs)) + if (!file.exists(task$output_file)) saveRDS(result, task$output_file) + finish_task(pid, result) + } + + if ((is.null(done) || length(done) == 0) && length(timed_out) == 0) Sys.sleep(1) + } invisible(vapply(tasks, function(t) t$output_file, character(1))) } From a60e080966341fd0148a330b50f3db1a692bc37f Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:30:50 +0100 Subject: [PATCH 11/30] Fix to ensure that background jobs run properly and don't leave any zombie processes. --- analysis/main_analysis.R | 262 ++++++++++++++++++++++++++------------- 1 file changed, 177 insertions(+), 85 deletions(-) diff --git a/analysis/main_analysis.R b/analysis/main_analysis.R index bb958eb..b3eb2fd 100644 --- a/analysis/main_analysis.R +++ b/analysis/main_analysis.R @@ -20,10 +20,19 @@ # $stan_data list passed to Stan # $datasets the dataset list used (possibly filtered / subsetted) # $checks output of pre_inference_checks() (NULL for subgroup runs) +# $tier, $max_rhat, $divergences, $converged, $runtime_secs +# diagnostics from fit_with_escalation() (R/utils.R) # -# The file is saved after every completed pathogen so a crash does not -# lose earlier work. Re-running the script skips any (pathogen, analysis, -# distribution) triple that already has a non-NULL entry. +# Fitting itself is queued across every pathogen first, then dispatched in +# one parallel batch (fit_corpus_parallel(), reserving RESERVE_CORES cores - +# see section 1) rather than one fit at a time. Each individual fit is +# additionally saved to its own file the moment it completes +# (results/main_analysis_tasks/), independent of the merged +# results/main_results.rds written once at the end - so a crash partway +# through only loses fits that hadn't completed yet, not the whole run, and +# re-running the script skips any (pathogen, analysis, distribution) triple +# whose task file (or, from before this restructuring, whose merged-results +# entry) already exists. # ============================================================================= # load_all() instead of library() so that unexported package objects @@ -56,13 +65,25 @@ options(mc.cores = parallel::detectCores()) # ── 1. Sampling settings ────────────────────────────────────────────────────── +# +# Fitting now goes through fit_with_escalation() (R/utils.R), which tries +# increasingly conservative settings until Rhat 0) { } -# ── 8. Main loop ────────────────────────────────────────────────────────────── +# ── 8. Build the analysis table for every pathogen, and one global task list ─ +# +# Building `analyses` (all/filtered/subgroups) stays per-pathogen and serial, +# as before - it's comparatively cheap and each pathogen's "filtered" variant +# depends on that pathogen's own pre_inference_checks() result. What changes +# is the fitting step: rather than fitting each (pathogen, analysis, family) +# combination immediately and serially, every combination that still needs +# fitting is appended to one task list across ALL pathogens, dispatched in a +# single parallel batch at the end (section 9) so the concurrency-limited +# core budget stays continuously busy instead of idling between pathogens. + +tasks <- list() for (pathogen in names(pathogen_registry)) { @@ -329,41 +340,43 @@ for (pathogen in names(pathogen_registry)) { # "all" analysis — always the full dataset, nothing to recover analyses[["all"]] <- list(datasets = datasets_full, checks = NULL) - # "filtered" analysis — recover or run fresh - prior_filtered <- all_results[[pathogen]][["filtered"]] - prior_filtered <- if (!is.null(prior_filtered)) Filter(Negate(is.null), prior_filtered) else list() - - if (length(prior_filtered) > 0) { - ref <- prior_filtered[[1]] - analyses[["filtered"]] <- list(datasets = ref$datasets, checks = ref$checks) - message("\n Recovered filtered datasets from existing results", - " (skipping pre_inference_checks).") - } else { - message("\n Running pre_inference_checks for filter (lognormal proxy)...") - checks_proxy <- tryCatch( + # "filtered" analysis - family-specific (see POINT4_LIKELIHOOD_MATHS.md + # Part E.10 for why a single shared lognormal proxy isn't enough). One + # filtered list per HIERARCHICAL_FAMILIES member. gamma reuses "all" + # unfiltered - it's protected instead by gamma_phi_extreme_safe(). + analyses[["filtered"]] <- list(by_family = list(gamma = analyses[["all"]])) + + for (dist_name in HIERARCHICAL_FAMILIES) { + prior <- all_results[[pathogen]][["filtered"]][[dist_name]] + if (!is.null(prior$datasets)) { + analyses[["filtered"]]$by_family[[dist_name]] <- list(datasets = prior$datasets, checks = prior$checks) + message("\n Recovered filtered datasets for ", dist_name, " from existing results.") + next + } + message("\n Running pre_inference_checks for filter (", dist_name, ")...") + checks_res <- tryCatch( suppressWarnings( pre_inference_checks( datasets_full, stan_model, - dist_type = 1L, # lognormal as proxy + dist_type = DIST_CODES[[dist_name]], verbose = FALSE, filter = TRUE ) ), error = function(e) { - message(" [WARN] pre_inference_checks failed: ", conditionMessage(e), - " — 'filtered' analysis will use full dataset.") + message(" [WARN] pre_inference_checks failed for ", dist_name, ": ", conditionMessage(e), + " — 'filtered' will use the full dataset for this family.") list(datasets = datasets_full) } ) - analyses[["filtered"]] <- list(datasets = checks_proxy$datasets, - checks = checks_proxy) - n_removed <- length(datasets_full) - length(checks_proxy$datasets) + analyses[["filtered"]]$by_family[[dist_name]] <- list(datasets = checks_res$datasets, checks = checks_res) + n_removed <- length(datasets_full) - length(checks_res$datasets) if (n_removed > 0) { - message(" Filter removed ", n_removed, " dataset(s): ", + message(" Filter (", dist_name, ") removed ", n_removed, " dataset(s): ", paste(setdiff(names(datasets_full), - names(checks_proxy$datasets)), collapse = ", ")) + names(checks_res$datasets)), collapse = ", ")) } else { - message(" Filter: no datasets removed.") + message(" Filter (", dist_name, "): no datasets removed.") } } @@ -411,20 +424,25 @@ for (pathogen in names(pathogen_registry)) { next } - # ── Fit all (analysis × distribution) combinations ───────────────────────── + # ── Decide what needs fitting; queue it rather than fit immediately ──────── for (analysis_label in names(analyses)) { if (is.null(all_results[[pathogen]][[analysis_label]])) all_results[[pathogen]][[analysis_label]] <- list() - analysis_datasets <- analyses[[analysis_label]]$datasets + for (dist_name in names(DIST_CODES)) { - if (length(analysis_datasets) == 0) { - message("\n [SKIP] ", analysis_label, ": 0 datasets remaining.") - next - } + # "filtered" is family-specific; other analyses aren't. + analysis_datasets <- if (analysis_label == "filtered") { + analyses[["filtered"]]$by_family[[dist_name]]$datasets + } else { + analyses[[analysis_label]]$datasets + } - for (dist_name in names(DIST_CODES)) { + if (length(analysis_datasets) == 0) { + message("\n [SKIP] ", analysis_label, " / ", dist_name, ": 0 datasets remaining.") + next + } # Skip if already done (includes the skipped-GG sentinel) if (!is.null(all_results[[pathogen]][[analysis_label]][[dist_name]])) { @@ -477,24 +495,98 @@ for (pathogen in names(pathogen_registry)) { next } - message("\n Fitting: ", pathogen, " | ", analysis_label, - " | ", dist_name, - " (n_datasets = ", length(analysis_datasets), ")") + # Gamma numerical-fragility check (see gamma_phi_extreme_safe() docs). + if (dist_name == "gamma" && + !gamma_phi_extreme_safe(analysis_datasets, verbose = FALSE)) { + message("\n [SKIP] ", pathogen, " / ", analysis_label, + " / gamma — a dataset's implied shape is extreme enough to", + " risk grad_reg_lower_inc_gamma's slow-series regime", + " (gamma_phi_extreme_safe() check failed).") + all_results[[pathogen]][[analysis_label]][["gamma"]] <- + list(skipped = TRUE, + reason = "gamma_phi_extreme_safe", + datasets = analysis_datasets) + next + } - result <- .fit_one(analysis_datasets, dist_name, pathogen, analysis_label) + # Burr XII per-study phi_d reliability check (see burr_phid_reliable() docs). + task_stan_model <- .model_for_family(dist_name) + if (dist_name == "burr" && + !burr_phid_reliable(analysis_datasets, stan_model, verbose = FALSE)) { + message("\n [INFO] ", pathogen, " / ", analysis_label, + " / burr — falling back to shared-phi Burr XII ", + "(burr_phid_reliable() check failed).") + task_stan_model <- stan_model_shared_phi + } - if (!is.null(result)) - result$checks <- analyses[[analysis_label]]$checks + out_file <- .task_file(pathogen, analysis_label, dist_name) + task <- list( + label = paste(pathogen, analysis_label, dist_name, sep = "/"), + pathogen = pathogen, + analysis_label = analysis_label, + dist_name = dist_name, + datasets = analysis_datasets, + stan_model = task_stan_model, + output_file = out_file, + checks = if (analysis_label == "filtered") { + analyses[["filtered"]]$by_family[[dist_name]]$checks + } else { + analyses[[analysis_label]]$checks + } + ) - all_results[[pathogen]][[analysis_label]][[dist_name]] <- result + if (file.exists(out_file)) { + # Completed in an earlier (possibly interrupted) run of this script, + # but not yet merged into all_results below - merge it, don't refit. + message("\n [RESUME] ", task$label, " — task file already exists, will merge without refitting.") + } else { + message("\n [QUEUE] ", task$label, " (n_datasets = ", length(analysis_datasets), ")") + } + tasks[[length(tasks) + 1]] <- task } } +} - # Save after each pathogen - saveRDS(all_results, OUTPUT_FILE) - message("\n Saved results to: ", OUTPUT_FILE) +# ── 9. Merge already-done tasks (from an earlier interrupted run) up front ─── +# Tasks whose output file already exists (see [RESUME] above) are excluded +# from dispatch in section 10, but still need merging in - do that now so +# main_results.rds reflects everything on disk even before any new fitting +# happens this run. + +for (task in tasks) { + if (file.exists(task$output_file) && is.null(all_results[[task$pathogen]][[task$analysis_label]][[task$dist_name]])) { + result <- readRDS(task$output_file) + if (is.null(result$error)) result$checks <- task$checks + all_results[[task$pathogen]][[task$analysis_label]][[task$dist_name]] <- result + } } +saveRDS(all_results, OUTPUT_FILE) + +# ── 10. Dispatch every remaining task, saving as each one completes ───────── +# fit_corpus_parallel()'s on_complete callback fires in this (parent) process +# the moment each individual task finishes - not batched, not deferred to the +# end - so results/main_results.rds is never more than one fit's worth of +# work behind, and stopping the run part-way through loses at most whatever +# was still mid-fit, never anything already completed. + +to_fit <- Filter(function(t) !file.exists(t$output_file), tasks) +message("\n", strrep("=", 70)) +message(length(tasks), " total (pathogen, analysis, family) combinations queued; ", + length(to_fit), " need fitting (", length(tasks) - length(to_fit), " already done).") +message(strrep("=", 70)) +if (length(to_fit) > 0) { + fit_corpus_parallel( + to_fit, reserve_cores = RESERVE_CORES, rhat_target = RHAT_TARGET, + task_timeout_secs = TASK_TIMEOUT_SECS, + on_complete = function(task, result) { + if (is.null(result$error)) result$checks <- task$checks + all_results[[task$pathogen]][[task$analysis_label]][[task$dist_name]] <<- result + saveRDS(all_results, OUTPUT_FILE) + message(" Saved results to: ", OUTPUT_FILE, " (", task$label, ")") + } + ) +} message("\n", strrep("=", 70)) message("All done. Results written to: ", OUTPUT_FILE) message(strrep("=", 70)) From 0bd4e73e6efcdf0c42d7204e9ef4652e3966a1b0 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:46:33 +0100 Subject: [PATCH 12/30] update documentation --- man/generate_hierarchical_data_mixed.Rd | 15 +++++++- man/plot_main_figure.Rd | 2 +- man/plot_temporal_trend.Rd | 51 +++++++++++++++++++++++++ man/pre_inference_checks.Rd | 24 +++++++++--- man/prepare_stan_data_from_datasets.Rd | 43 ++++++++++++++++----- 5 files changed, 118 insertions(+), 17 deletions(-) create mode 100644 man/plot_temporal_trend.Rd diff --git a/man/generate_hierarchical_data_mixed.Rd b/man/generate_hierarchical_data_mixed.Rd index d1b419e..c0c8ea2 100644 --- a/man/generate_hierarchical_data_mixed.Rd +++ b/man/generate_hierarchical_data_mixed.Rd @@ -12,7 +12,9 @@ generate_hierarchical_data_mixed( tau, phi, kappa = 1, - summary_type = NULL + summary_type = NULL, + round_order_stats = FALSE, + resolution = 1 ) } \arguments{ @@ -34,6 +36,17 @@ length \code{n_datasets} (one type per dataset), a length-3 probability vector (sample from types 1-3 with those probabilities), or a length-4 probability vector (sample from types 1-4 with those probabilities). Type 4 produces a frequency table of observations rounded to the nearest whole day.} + +\item{round_order_stats}{If \code{TRUE}, the median/min/max/Q1/Q3 reported for +summary types 1 and 2 are rounded to the nearest multiple of +\code{resolution} before being returned, matching how these statistics are +actually reported in the literature.} + +\item{resolution}{Rounding grid in days, used only when +\code{round_order_stats = TRUE}. Default \code{1} (nearest whole day); pass e.g. +\code{1/24} to simulate hour-resolution reporting. Recorded in the returned +\code{obs_data$resolution} field so the Stan model integrates over the same +window that was used to round the data.} } \value{ List containing true parameters and observed summary statistics diff --git a/man/plot_main_figure.Rd b/man/plot_main_figure.Rd index 5ca1758..4017227 100644 --- a/man/plot_main_figure.Rd +++ b/man/plot_main_figure.Rd @@ -45,7 +45,7 @@ a full set of pathogens). Pre-compute and cache this object.} \item{ncol}{Integer. Columns in the assembled figure (default 4).} -\item{base_size}{Numeric. Base font size for \code{\link[ggplot2:ggtheme]{ggplot2::theme_bw()}} +\item{base_size}{Numeric. Base font size for \code{\link[ggplot2:theme_bw]{ggplot2::theme_bw()}} (default 9).} } \value{ diff --git a/man/plot_temporal_trend.Rd b/man/plot_temporal_trend.Rd new file mode 100644 index 0000000..2cd8197 --- /dev/null +++ b/man/plot_temporal_trend.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ploting_utils.R +\name{plot_temporal_trend} +\alias{plot_temporal_trend} +\title{Temporal trend diagnostics for a type-7 line list fit} +\usage{ +plot_temporal_trend( + dataset, + posterior, + reference_date = NULL, + probs = c(0.5, 0.75, 0.95), + n_draws = 200L +) +} +\arguments{ +\item{dataset}{A single type-7 dataset list (the element passed to +\code{prepare_stan_data_from_datasets()}).} + +\item{posterior}{A list returned by \code{extract_posterior_draws()}.} + +\item{reference_date}{A \code{Date} giving day 0 of the calendar axis. +If \code{NULL}, the x-axis is labelled in days from reference.} + +\item{probs}{Numeric vector of quantile levels for Panel A. +Default: \code{c(0.5, 0.75, 0.95)}.} + +\item{n_draws}{Number of posterior draws to use for envelope uncertainty. +Default: 200.} +} +\value{ +A patchwork of two ggplot objects. +} +\description{ +Produces a two-panel diagnostic plot: +} +\details{ +\describe{ +\item{Panel A -- Truncation envelope}{Individual observed delays vs onset +date, overlaid with posterior median quantile curves (50th, 75th, 95th +percentile) of the delay distribution \emph{truncated} at each individual's +maximum observable delay (\code{T - expo_mid}). If points track the +envelope, truncation accounts for the apparent shortening of delays +over time. If points fall systematically below the envelope, delays +are genuinely shrinking faster than truncation predicts.} +\item{Panel B -- PIT over time}{Probability integral transform values +\eqn{F_D(d_i) / F_D(T - x_i)} for each observed case plotted against +onset date. Under the null (truncation only, no trend) PIT values are +approximately Uniform(0, 1) with no temporal pattern. A downward loess +trend indicates a genuine reduction in delays over time.} +} +} diff --git a/man/pre_inference_checks.Rd b/man/pre_inference_checks.Rd index bc94e9c..370db9e 100644 --- a/man/pre_inference_checks.Rd +++ b/man/pre_inference_checks.Rd @@ -10,6 +10,7 @@ pre_inference_checks( dist_type = 1, custom_priors = list(), phi_outlier_threshold = 5, + phi_spread_threshold = 7, phi_grid = seq(0.5, 50, by = 0.5), n_sim = 2000, loo_iter = 4000, @@ -22,10 +23,15 @@ pre_inference_checks( \item{datasets}{A named list of datasets in the format accepted by \code{\link[=prepare_stan_data_from_datasets]{prepare_stan_data_from_datasets()}}.} -\item{stan_model}{A compiled Stan model object from \code{\link[rstan:stan_model]{rstan::stan_model()}}.} +\item{stan_model}{A compiled Stan model object from \code{\link[rstan:stan_model]{rstan::stan_model()}}. +Must be the hierarchical per-study \code{phi_d} model - Checks 3-5 assume +that parameterisation and will error on a shared-\code{phi} model like +gamma's. Use \code{\link[=gamma_phi_extreme_safe]{gamma_phi_extreme_safe()}} for gamma instead.} \item{dist_type}{Integer distribution code: \code{1} = log-normal, \code{2} = gamma, -\code{3} = Weibull. Defaults to \code{1}.} +\code{3} = Weibull, \code{4} = Burr XII, \code{5} = generalised gamma. Defaults to \code{1}. +Checks 1-2 use \code{dist_type}'s own moment formulas; Checks 3-5 assume the +hierarchical model regardless.} \item{custom_priors}{Optional named list of prior overrides passed to \code{\link[=prepare_stan_data_from_datasets]{prepare_stan_data_from_datasets()}}.} @@ -34,6 +40,12 @@ pre_inference_checks( A dataset is flagged if its implied \code{phi} exceeds \code{phi_outlier_threshold * median(implied_phi)}. Defaults to \code{5}.} +\item{phi_spread_threshold}{Complementary criterion to +\code{phi_outlier_threshold}: flags the min/max datasets when +\code{max(implied_phi)/min(implied_phi)} exceeds this, catching two datasets +pulling toward opposite extremes (neither individually far enough from +the median to trip the other check). Calibrated on Weibull;} + \item{phi_grid}{Numeric vector of \code{phi} values for the log-likelihood surface scan. Defaults to \code{seq(0.5, 50, by = 0.5)}.} @@ -80,14 +92,14 @@ computational cost and a summary is printed to the console. The five checks performed are: \describe{ \item{1. Method-of-moments consistency}{Estimates \code{phi} from each dataset -individually using moment-based approximations and flags any dataset -whose implied \code{phi} is more than \code{phi_outlier_threshold} times the -median of all implied values.} +individually (using \code{dist_type}'s own formula, all five families) and +flags a dataset if it's far from the median (\code{phi_outlier_threshold}) +or is the min/max of a set whose spread exceeds \code{phi_spread_threshold}.} \item{2. Prior predictive compatibility}{Simulates summary statistics from the prior and checks whether each observed value falls within the 95\% prior predictive interval. Datasets outside this range suggest a prior--data mismatch.} -\item{3. MAP optimisation probe}{Runs \code{\link[rstan:stanmodel-method-optimizing]{rstan::optimizing()}} as a fast +\item{3. MAP optimisation probe}{Runs \code{\link[rstan:optimizing]{rstan::optimizing()}} as a fast proxy for MCMC convergence. Failure or extreme \code{phi} at the MAP estimate is a reliable early warning that HMC will struggle.} \item{4. Log-likelihood surface scan}{Evaluates the joint log-posterior diff --git a/man/prepare_stan_data_from_datasets.Rd b/man/prepare_stan_data_from_datasets.Rd index 3b0e329..7cc8e94 100644 --- a/man/prepare_stan_data_from_datasets.Rd +++ b/man/prepare_stan_data_from_datasets.Rd @@ -30,6 +30,25 @@ upper bound of the censoring interval and the count of individuals in that interval. When \code{freq_lower[i] == freq_upper[i]} the observation is treated as exact. \code{n} is optional and defaults to \code{sum(freq_count)}.} +\item{\code{expo_lower}, \code{expo_upper}, \code{event_lower}, \code{event_upper}, +\code{freq_count}}{Double interval-censored frequency table (summary +type 6). Both the exposure window (\code{expo_lower}, \code{expo_upper}) and +the event window (\code{event_lower}, \code{event_upper}) are interval-censored. +All five vectors must have the same length. Requires +\code{expo_upper[i] <= event_lower[i]} for all i (positive delays). \code{n} +is optional and defaults to \code{sum(freq_count)}.} +\item{\code{expo_lower}, \code{expo_upper}, \code{event_lower}, \code{event_upper}, +\code{event_observed}, \code{freq_count}, \code{truncation_time}}{Double +interval-censored with right truncation/censoring (summary type 7). +As type 6, plus \code{event_observed} (1 = onset seen, 0 = right-censored: +not yet observed by the analysis cutoff) and a single +\code{truncation_time} per dataset (the analysis cutoff \code{T}, in the same +time origin as the exposure/event windows). \code{truncation_time} is a +study-design choice, not a rounded observation of a random event +time, so it is never treated as day-rounded the way exposure/event +windows are. Set it using the same time-encoding convention as that +dataset's own windows: e.g. if event days are encoded as \verb{[day, day+1)} intervals, set \code{truncation_time} to \verb{(last observed day + 1)} to mean "complete through the end of that day", not to the bare +day number.} } Each element may also contain an optional \code{source} field — a free-text character string recording the bibliographic reference for that dataset @@ -45,10 +64,14 @@ Currently unused; reserved for future extension. Defaults to \code{0}.} \item{custom_priors}{Named list of prior overrides. Any values not supplied fall back to distribution-appropriate defaults (see Details). Recognised names: \code{mu0_sd}, \code{log_tau_mean}, \code{log_tau_sd}, \code{log_phi_mean}, -\code{log_phi_sd}.} +\code{log_phi_sd}, \code{log_omega_mean}, \code{log_omega_sd}. \code{log_phi_mean}/\code{log_phi_sd} +are the prior for \code{log_phi0} (population-mean dispersion); +\code{log_omega_mean}/\code{log_omega_sd} are the prior for \code{log_omega}, the +between-study SD of log dispersion (per-study \code{phi_d} is hierarchical, +not a shared scalar).} } \value{ -A named list suitable for passing to \code{\link[rstan:stanmodel-method-sampling]{rstan::sampling()}} as the +A named list suitable for passing to \code{\link[rstan:sampling]{rstan::sampling()}} as the \code{data} argument. The list always includes \code{freq_lower} and \code{freq_upper} fields (populated with zeros for non-type-5 datasets), as these are required by the Stan model regardless of which summary types are present. @@ -76,13 +99,15 @@ element(s) in \code{custom_priors}, e.g. the distribution-appropriate defaults above. } \note{ -\strong{Backward compatibility:} The Stan model requires \code{freq_lower} and -\code{freq_upper} to be present in the data list for all runs, including those -that contain only type 1--4 datasets. This is handled automatically when -using this function. If you construct the Stan data list manually (rather -than via this function), you must include these fields explicitly, e.g.: +\strong{Backward compatibility:} The Stan model requires \code{freq_lower}, +\code{freq_upper}, \code{event_lower}, and \code{event_upper} to be present in the data +list for all runs. These are populated automatically by this function. +If constructing the Stan data list manually, fill all four arrays with +zeros for non-applicable datasets, e.g.: -\if{html}{\out{
}}\preformatted{stan_data$freq_lower <- rep(0, stan_data$n_freq_total) -stan_data$freq_upper <- rep(0, stan_data$n_freq_total) +\if{html}{\out{
}}\preformatted{stan_data$freq_lower <- rep(0, stan_data$n_freq_total) +stan_data$freq_upper <- rep(0, stan_data$n_freq_total) +stan_data$event_lower <- rep(0, stan_data$n_freq_total) +stan_data$event_upper <- rep(0, stan_data$n_freq_total) }\if{html}{\out{
}} } From 256757ea11796f7c7fac5ae74ac1638e00e9df60 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:47:38 +0100 Subject: [PATCH 13/30] update test for code change --- tests/testthat/test-utils.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 28ababd..8337d9a 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -35,7 +35,8 @@ test_that("make_stan_init_fn closure returns a list with required names", { ) ) init <- make_stan_init_fn(sd)() - expect_named(init, c("mu0", "log_tau", "log_phi", "log_kappa", "loc_d_raw"), + expect_named(init, c("mu0", "log_tau", "log_phi0", "log_omega", "log_kappa", + "loc_d_raw", "log_phi_d_raw"), ignore.order = TRUE) }) @@ -50,7 +51,8 @@ test_that("make_stan_init_fn initialises parameters from stan_data", { init <- make_stan_init_fn(sd)() expect_equal(init$mu0, sd$mu0_mean) expect_equal(init$log_tau, sd$log_tau_mean) - expect_equal(init$log_phi, sd$log_phi_mean) + expect_equal(init$log_phi0, sd$log_phi_mean) + expect_equal(init$log_omega, sd$log_omega_mean) expect_equal(init$log_kappa, sd$log_kappa_mean) }) From 284140606d5168b2c6e54e8298c8b786b5f4ab7b Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:48:05 +0100 Subject: [PATCH 14/30] update documentation --- man/ddsynth-package.Rd | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/man/ddsynth-package.Rd b/man/ddsynth-package.Rd index fb0d18d..65f70f5 100644 --- a/man/ddsynth-package.Rd +++ b/man/ddsynth-package.Rd @@ -6,6 +6,8 @@ \alias{ddsynth-package} \title{ddsynth: Delay Distribution from Summary Statistics} \description{ +\if{html}{\figure{logo.svg}{options: style='float: right' alt='logo' width='120'}} + Methods to compute delay distributions from summary statistics. } \seealso{ @@ -20,4 +22,9 @@ Useful links: \author{ \strong{Maintainer}: Christian Morgenstern \email{c.morgenstern@imperial.ac.uk} +Authors: +\itemize{ + \item Christian Morgenstern \email{c.morgenstern@imperial.ac.uk} +} + } From 29920831393f98b82c79060e180c9412682fa92c Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:48:17 +0100 Subject: [PATCH 15/30] update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 62e00e8..70dc196 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -9,7 +9,6 @@ URL: https://cm401.github.io/ddsynth, https://github.com/cm401/ddsynth BugReports: https://github.com/cm401/ddsynth/issues Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 Imports: BSL, bridgesampling, @@ -44,3 +43,4 @@ Suggests: tidyverse Config/testthat/edition: 3 VignetteBuilder: knitr +Config/roxygen2/version: 8.0.0 From 2aac7bee26bdc06ab538ae4cc02a17dc389551a3 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:48:28 +0100 Subject: [PATCH 16/30] update NAMESPACE --- NAMESPACE | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 6ec00c8..7f71069 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ export(bsl_make_trace_df) export(bsl_run_diagnostics) export(bsl_summarise_posteriors) export(bsl_to_mcmc_list_multi) +export(burr_phid_reliable) export(check_coverage) export(compile_stan_model) export(compute_iqd) @@ -31,10 +32,15 @@ export(create_pred_q95_coverage_plot) export(create_results_summary) export(create_scenario) export(create_wis_plot) +export(detect_resolution) export(extract_dataset_summary) +export(extract_posterior_draws) export(extract_quantiles) export(filter_datasets) +export(fit_corpus_parallel) export(fit_model) +export(fit_with_escalation) +export(gamma_phi_extreme_safe) export(gamma_type2_reliable) export(generate_cdf_plot_simulation_study_input) export(generate_data_table) @@ -45,12 +51,14 @@ export(generate_scenario_library) export(generate_simulation_table1) export(generate_simulation_table2) export(make_stan_init_fn) +export(merge_parallel_fit_results) export(plot_main_figure) export(plot_main_figure_split) export(plot_simulation_study_figure) export(plot_simulation_study_figure2) export(plot_simulation_study_sens_figure) export(plot_simulation_study_si_figure) +export(plot_temporal_trend) export(pre_inference_checks) export(prepare_stan_data_from_datasets) export(run_simulation_study_generalized) From a4daab8e808046ffb5440b1ecbf3c6d44efa73ad Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:48:48 +0100 Subject: [PATCH 17/30] update global variables --- R/zzz.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/zzz.R b/R/zzz.R index acfc572..e5313f3 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -34,6 +34,7 @@ utils::globalVariables(c( # simulation / analysis result columns "analysis_", "cdf", "ci_95", "dataset", "datasets", "ESS", "high", "high_97.5", "i", "implied_phi", "is_outlier", + "is_outlier_median", "is_outlier_spread", "log_prob", "low", "low_2.5", "median_bias_mu0", "median_bias_phi", "median_bias_tau", "model", "mu0", From bccd4133f959262bd654a202d4329e208d8425e5 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:49:02 +0100 Subject: [PATCH 18/30] update comment --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 1d6c846..fa66ff3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1303,7 +1303,7 @@ should_attempt_gg <- function(datasets, #' Check whether Burr XII's per-study dispersion hierarchy is safe to attempt #' -#' Burr XII's mean+SD likelihood needs kappa*phi_d[d] > 4 per dataset (see +#' Burr XII's mean+SD likelihood needs `kappa*phi_d[d] > 4` per dataset (see #' the Stan model's summary_type==3 branch); under the per-study phi_d #' hierarchy this becomes n simultaneous constraints instead of one, which #' can fragment the feasible region into separate modes. Detected here via a From c94e8d7d18608fdcf8468b2f3b1a951f5690d380 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:49:25 +0100 Subject: [PATCH 19/30] update documentation --- man/compute_predictive_cdf.Rd | 2 +- man/detect_resolution.Rd | 63 +++++++++++++++++++++++++ man/extract_posterior_draws.Rd | 21 +++++++++ man/fit_corpus_parallel.Rd | 76 +++++++++++++++++++++++++++++++ man/fit_with_escalation.Rd | 52 +++++++++++++++++++++ man/gamma_phi_extreme_safe.Rd | 29 ++++++++++++ man/merge_parallel_fit_results.Rd | 23 ++++++++++ 7 files changed, 265 insertions(+), 1 deletion(-) create mode 100644 man/detect_resolution.Rd create mode 100644 man/extract_posterior_draws.Rd create mode 100644 man/fit_corpus_parallel.Rd create mode 100644 man/fit_with_escalation.Rd create mode 100644 man/gamma_phi_extreme_safe.Rd create mode 100644 man/merge_parallel_fit_results.Rd diff --git a/man/compute_predictive_cdf.Rd b/man/compute_predictive_cdf.Rd index 3f5df2d..9fe4e25 100644 --- a/man/compute_predictive_cdf.Rd +++ b/man/compute_predictive_cdf.Rd @@ -13,7 +13,7 @@ compute_predictive_cdf( ) } \arguments{ -\item{fit}{A \code{stanfit} object returned by \code{\link[rstan:stanmodel-method-sampling]{rstan::sampling()}}.} +\item{fit}{A \code{stanfit} object returned by \code{\link[rstan:sampling]{rstan::sampling()}}.} \item{dist_name}{Character string: \code{"lognormal"}, \code{"gamma"}, \code{"weibull"}, \code{"burr12"} (Burr Type XII), or \code{"gengamma"} (Generalised Gamma, Prentice diff --git a/man/detect_resolution.Rd b/man/detect_resolution.Rd new file mode 100644 index 0000000..c97c905 --- /dev/null +++ b/man/detect_resolution.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{detect_resolution} +\alias{detect_resolution} +\title{Detect the day-fraction reporting resolution of an order-statistic dataset} +\usage{ +detect_resolution(exact_vals, risky_vals = numeric(0), tol = 1e-06) +} +\arguments{ +\item{exact_vals}{Numeric vector of statistics that are always true order +statistics (min and max, for a median+range dataset). \code{NA}s are +dropped. Pass \code{numeric(0)} if none apply (e.g. a median+IQR dataset).} + +\item{risky_vals}{Numeric vector of statistics that may be interpolated +rather than raw order statistics (the median; and, for a median+IQR +dataset, the quartiles too). \code{NA}s are dropped. Default \code{numeric(0)}.} + +\item{tol}{Numerical tolerance for judging a value to be a multiple of a +candidate grid. Default \code{1e-6}.} +} +\value{ +A single number: the detected resolution in days (\code{1} = whole day, +\code{1/24} = hourly, etc.). Defaults to \code{1} if both arguments are empty +after dropping \code{NA}s. +} +\description{ +Infers how finely a study's reported order statistics were rounded, so the +day-rounded order-statistic likelihood (Reviewer 2, point 1(iii)) can use a +window narrower than a full day where the data supports it, rather than +assuming every dataset was rounded to the nearest whole day. +} +\details{ +\code{exact_vals} (the sample min and max for a median+range dataset) are +always true order statistics: an actual individual observation, under any +convention, at any sample size. \code{risky_vals} (the median, and for a +median+IQR dataset the reported quartiles) are not: for an even sample +size the standard median is the \emph{average} of the two middle order +statistics, and quartile conventions vary and routinely interpolate +between adjacent order statistics. A day-integer dataset can therefore +report a median or quartile with a spurious fractional part (most often an +exact half, from averaging two integers) that reflects the interpolation +arithmetic, not the study's real measurement precision. Checked against +the curated corpus: several real median+range datasets (e.g. n=28, n=8, +n=10, n=22) show exactly this pattern, a half-integer median next to +integer min/max, for both even and odd n. + +Because of this, \code{exact_vals} are checked against the full set of "nice" +divisors of a day (whole day, half-day, ..., hourly), coarsest first, +since an integer is trivially consistent with every finer grid too (e.g. +\code{5} is a multiple of \code{1/24} as well as of \code{1}) and the coarsest match is +the meaningful one. \code{risky_vals} are trusted only for signals that a +generic linear interpolation between two integers is unlikely to produce +by chance: an hour-based grid (hourly, 2-hourly, 3-hourly) or a decimal +precision of two or more places (a simple interpolation weight reproduces +at most one non-trivial decimal digit from two integers, e.g. an eighth +gives \code{x.125}, a genuine 3-decimal case, which is why the 2dp threshold is +conservative rather than exact). Otherwise \code{risky_vals} are ignored and +the result defaults to a whole day. This means the function will +sometimes underestimate a median+IQR dataset's true resolution (there is +no min/max to anchor it), but underestimating resolution only means +falling back to the wider, already-accepted day window, not repeating the +overconfidence problem this exists to fix. +} diff --git a/man/extract_posterior_draws.Rd b/man/extract_posterior_draws.Rd new file mode 100644 index 0000000..7ccfa53 --- /dev/null +++ b/man/extract_posterior_draws.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ploting_utils.R +\name{extract_posterior_draws} +\alias{extract_posterior_draws} +\title{Extract posterior draws of distribution parameters from a stanfit object} +\usage{ +extract_posterior_draws(fit, stan_data) +} +\arguments{ +\item{fit}{A \code{stanfit} object returned by \code{rstan::sampling()}.} + +\item{stan_data}{The Stan data list passed to fit (needed for \code{dist_type}).} +} +\value{ +A list with draws of loc (mu0), phi, kappa, and the dist_type integer. +} +\description{ +Returns a list with elements \code{loc}, \code{phi}, and \code{kappa} +(each a vector of posterior draws), plus \code{dist_type} (integer). +Designed for use with the type-7 temporal diagnostic functions below. +} diff --git a/man/fit_corpus_parallel.Rd b/man/fit_corpus_parallel.Rd new file mode 100644 index 0000000..dd35725 --- /dev/null +++ b/man/fit_corpus_parallel.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{fit_corpus_parallel} +\alias{fit_corpus_parallel} +\title{Fit a list of (dataset, family) tasks concurrently, leaving cores free} +\usage{ +fit_corpus_parallel( + tasks, + chains_per_fit = 4, + reserve_cores = 4, + rhat_target = 1.05, + on_complete = NULL, + task_timeout_secs = 90 * 60 +) +} +\arguments{ +\item{tasks}{A list of task specifications, each a list with: +\code{label} (character, for logging), \code{datasets} (named list, as passed to +\code{\link[=prepare_stan_data_from_datasets]{prepare_stan_data_from_datasets()}}), \code{dist_name} (one of "lognormal", +"gamma", "weibull", "burr", "gengamma"), \code{stan_model} (compiled model to +use for this task - the caller decides hierarchical vs. shared-phi per +family, see \code{analysis/main_analysis.R}'s \code{SHARED_PHI_FAMILIES}), and +\code{output_file} (path to save this task's result to).} + +\item{chains_per_fit}{Chains used within each individual fit (passed to +\code{\link[=fit_with_escalation]{fit_with_escalation()}} tiers implicitly - currently fixed at 4 within +that function; this argument only affects the core-budget arithmetic +below, so keep it in sync if that changes).} + +\item{reserve_cores}{Cores to leave free for other use on the machine. +Default 4 (out of this machine's 12), leaving meaningful headroom for +interactive use, not just background slack - do not reduce this without +explicit instruction.} + +\item{rhat_target}{Passed through to \code{\link[=fit_with_escalation]{fit_with_escalation()}}.} + +\item{on_complete}{Optional \verb{function(task, result)}, called in the +parent process as soon as each task finishes (\code{result} is the same list +already saved to \code{task$output_file}, or \code{list(error=...)} on failure). +Intended for incremental merge-and-save into a caller-side results +object, e.g. via \verb{<<-} from a top-level analysis script - see +\code{analysis/main_analysis.R} for the pattern. Errors inside the callback +are caught and reported, not allowed to take down the whole run.} + +\item{task_timeout_secs}{Wall-clock ceiling per task (all escalation tiers +combined), default 5400 (90 min). Guards against a chain wandering into +a genuinely slow numerical region and grinding forever without +erroring. Past this, the task is killed and recorded with +\code{error = "timed out after s"}.} +} +\value{ +Invisibly, a character vector of the \code{output_file} paths written +(some may be missing if a task errored - check before merging). +} +\description{ +Runs \code{\link[=fit_with_escalation]{fit_with_escalation()}} over a list of independent fitting tasks with +bounded concurrency (fork-based - Unix/macOS only), each task's chains +still parallelised internally as usual. Deliberately caps total core +usage well below the machine's full core count so the machine remains +usable for other work while a corpus run is in progress - this is a hard +requirement, not a tuning default: leave \code{reserve_cores} alone unless the +person running this has explicitly said otherwise. + +Streams rather than batches: uses a manually-managed rolling pool +(\code{parallel::mcparallel()}/\code{mccollect()}, not \code{mclapply()}) so a finished +slot is immediately handed the next queued task instead of waiting for +the whole set dispatched together to finish - this both keeps the core +pool continuously busy (a straggler task no longer stalls an entire +batch) and lets \code{on_complete} fire the moment \emph{each} task finishes, not +just at the end. Each task's result is still also written to its own +file immediately on completion (\code{task$output_file}) regardless of +\code{on_complete}, so a crash partway through loses only the tasks that +hadn't finished yet, not everything; \code{\link[=merge_parallel_fit_results]{merge_parallel_fit_results()}} can +assemble those files after the fact if \code{on_complete} wasn't used to do it +incrementally. +} diff --git a/man/fit_with_escalation.Rd b/man/fit_with_escalation.Rd new file mode 100644 index 0000000..ff9b6d5 --- /dev/null +++ b/man/fit_with_escalation.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{fit_with_escalation} +\alias{fit_with_escalation} +\title{Fit a Stan model with escalating settings, stopping once Rhat is acceptable} +\usage{ +fit_with_escalation( + stan_data, + stan_model, + rhat_target = 1.05, + seed = 123, + init = NULL, + verbose = TRUE +) +} +\arguments{ +\item{stan_data}{Data list for \code{rstan::sampling()}.} + +\item{stan_model}{Compiled Stan model.} + +\item{rhat_target}{Escalate if \code{max(Rhat)} exceeds this. Default 1.05, +matching the target agreed for the point 1/4 checkpoint run.} + +\item{seed}{Passed to every tier for reproducibility.} + +\item{init}{Optional init argument passed to every tier (e.g. +\code{make_stan_init_fn(stan_data)}); default \code{NULL} uses Stan's own default.} + +\item{verbose}{If \code{TRUE} (default), reports which tier was used and why.} +} +\value{ +A list: \code{fit} (the \code{stanfit} object from whichever tier +succeeded, or the last tier tried if none converged), \code{tier} (integer, +which tier succeeded or was last attempted), \code{max_rhat}, \code{divergences}, +\code{converged} (logical), and \code{runtime_secs} (total across all tiers +attempted). +} +\description{ +Tries a sequence of increasingly conservative sampling settings, stopping +at the first tier that achieves \code{max(Rhat) < rhat_target} with no +divergent transitions. Falls all the way back to the original +pre-lever-1 production settings (\code{iter=12000}, \code{adapt_delta=0.999}, +\code{max_treedepth=12}) as the last tier if cheaper settings do not converge - +those settings were originally chosen because some chains did not +converge without them, so this is a floor, not just a starting point to relax. + +Most fits are expected to converge at the cheap first tier, especially +now that lever 3 (\code{R/utils.R}'s \code{.order_stat_n_panels()}) has reduced +per-iteration cost and point 4's family gating means gamma no longer needs a +hierarchical \code{phi_d} funnel resolved. The escalation ladder exists for the +cases that still need it, not as the expected path. +} diff --git a/man/gamma_phi_extreme_safe.Rd b/man/gamma_phi_extreme_safe.Rd new file mode 100644 index 0000000..7bf0190 --- /dev/null +++ b/man/gamma_phi_extreme_safe.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{gamma_phi_extreme_safe} +\alias{gamma_phi_extreme_safe} +\title{Check whether a corpus is safe from gamma's slow-incomplete-gamma-series risk} +\usage{ +gamma_phi_extreme_safe(datasets, max_implied_phi = 60, verbose = TRUE) +} +\arguments{ +\item{datasets}{A named list of datasets as accepted by +\code{\link[=prepare_stan_data_from_datasets]{prepare_stan_data_from_datasets()}}.} + +\item{max_implied_phi}{Skip if any dataset's implied gamma shape exceeds +this.} + +\item{verbose}{Print a one-line verdict naming the offending dataset.} +} +\value{ +\code{TRUE} if safe, \code{FALSE} if gamma should be skipped for this +pathogen/analysis (no fallback model exists, unlike Burr XII's +\code{\link[=burr_phid_reliable]{burr_phid_reliable()}}). +} +\description{ +An extreme method-of-moments-implied gamma shape (often a small-n +\code{(max-min)/4} artifact) can drive NUTS into Stan's slow +\code{grad_reg_lower_inc_gamma} series during warmup, hanging for hours +without erroring. Not caught by \code{pre_inference_checks()}'s lognormal-proxy +filter. +} diff --git a/man/merge_parallel_fit_results.Rd b/man/merge_parallel_fit_results.Rd new file mode 100644 index 0000000..3aa52d5 --- /dev/null +++ b/man/merge_parallel_fit_results.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{merge_parallel_fit_results} +\alias{merge_parallel_fit_results} +\title{Assemble per-task .rds files from \code{\link[=fit_corpus_parallel]{fit_corpus_parallel()}} into one list} +\usage{ +merge_parallel_fit_results(output_files, labels) +} +\arguments{ +\item{output_files}{Character vector of file paths (as returned by +\code{\link[=fit_corpus_parallel]{fit_corpus_parallel()}}).} + +\item{labels}{Character vector, same length, used as names in the +returned list (typically \code{"."}).} +} +\value{ +A named list of the per-task results; entries for missing files +are \code{NULL} with a message, not a hard error, so a partially-complete +run can still be assembled and inspected. +} +\description{ +Assemble per-task .rds files from \code{\link[=fit_corpus_parallel]{fit_corpus_parallel()}} into one list +} From d3fbad2fd33d229f49d8d46cfb28b8bd56564b75 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 17:49:47 +0100 Subject: [PATCH 20/30] update documentation --- man/burr_phid_reliable.Rd | 45 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 man/burr_phid_reliable.Rd diff --git a/man/burr_phid_reliable.Rd b/man/burr_phid_reliable.Rd new file mode 100644 index 0000000..62294de --- /dev/null +++ b/man/burr_phid_reliable.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{burr_phid_reliable} +\alias{burr_phid_reliable} +\title{Check whether Burr XII's per-study dispersion hierarchy is safe to attempt} +\usage{ +burr_phid_reliable( + datasets, + stan_model, + n_starts = 10, + min_success_frac = 0.3, + lp_agreement_tol = 1, + verbose = TRUE +) +} +\arguments{ +\item{datasets}{A named list of datasets as accepted by +\code{\link[=prepare_stan_data_from_datasets]{prepare_stan_data_from_datasets()}}.} + +\item{stan_model}{The compiled hierarchical Burr XII model +(\code{dist_type = 4}), not the shared-phi variant.} + +\item{n_starts}{Number of random-init \code{rstan::optimizing()} calls.} + +\item{min_success_frac}{Minimum fraction of starts that must converge.} + +\item{lp_agreement_tol}{Max log-posterior spread across successful starts +before they're judged to be different modes.} + +\item{verbose}{Print a one-line verdict.} +} +\value{ +\code{TRUE} if safe to attempt the per-study hierarchy, \code{FALSE} if it +should fall back to shared-phi. Always \code{TRUE} when there are no +mean+SD datasets (the constraint can't fire). +} +\description{ +Burr XII's mean+SD likelihood needs \code{kappa*phi_d[d] > 4} per dataset (see +the Stan model's summary_type==3 branch); under the per-study phi_d +hierarchy this becomes n simultaneous constraints instead of one, which +can fragment the feasible region into separate modes. Detected here via a +cheap empirical stress test (several random-init \code{optimizing()} calls) +rather than a closed-form margin, which turned out unreliable in +practice. +} From e57551ad26ea45663cff941e114c2371d60fd8b1 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 18:26:34 +0100 Subject: [PATCH 21/30] bug fix (found by copilot code review!) --- inst/stan/hierarchical_data_synthesis_summary_stats.stan | 7 ++++++- ...erarchical_data_synthesis_summary_stats_shared_phi.stan | 4 +++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index 486431f..2a5dd68 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -125,7 +125,12 @@ functions { if (k > 1) log_F = dist_log_cdf_fun(x, dist_type, loc, phi, kappa); if (k < n) log_1mF = dist_log_ccdf_fun(x, dist_type, loc, phi, kappa); - real log_dens = lchoose(n, k) + log_f; + // Order-statistic normalising constant is n!/((k-1)!(n-k)!) = k*choose(n,k), + // not choose(n,k) alone (David & Nagaraja, Order Statistics). The extra + // log(k) vanishes exactly at k=1 (the minimum), which is why this was easy + // to miss - it grows with k, worst at k=n (the maximum), where the correct + // coefficient is n but choose(n,n)=1. + real log_dens = lchoose(n, k) + log(k) + log_f; if (k > 1) log_dens += (k - 1) * log_F; if (k < n) log_dens += (n - k) * log_1mF; return log_dens; diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan index f5fff47..8a9312b 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan @@ -139,7 +139,9 @@ functions { if (k > 1) log_F = dist_log_cdf_fun(x, dist_type, loc, phi, kappa); if (k < n) log_1mF = dist_log_ccdf_fun(x, dist_type, loc, phi, kappa); - real log_dens = lchoose(n, k) + log_f; + // Order-statistic normalising constant is n!/((k-1)!(n-k)!) = k*choose(n,k), + // not choose(n,k) alone. See hierarchical_data_synthesis_summary_stats.stan. + real log_dens = lchoose(n, k) + log(k) + log_f; if (k > 1) log_dens += (k - 1) * log_F; if (k < n) log_dens += (n - k) * log_1mF; return log_dens; From 0a924a44c2f13fef4b62a476802f63ee94985fd4 Mon Sep 17 00:00:00 2001 From: cm401 Date: Tue, 4 Aug 2026 18:46:14 +0100 Subject: [PATCH 22/30] Bug fix (thanks copilot) --- inst/stan/hierarchical_data_synthesis_summary_stats.stan | 2 +- .../hierarchical_data_synthesis_summary_stats_joint.stan | 6 +++--- ...hical_data_synthesis_summary_stats_joint_shared_phi.stan | 6 +++--- ...ierarchical_data_synthesis_summary_stats_shared_phi.stan | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index 2a5dd68..dec72dd 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -188,7 +188,7 @@ functions { 0.3818300505051189, 0.2797053914892767, 0.1294849661688697}; real half_res = resolution / 2; - real v_lo = fmax(v - half_res, 1e-6); + real v_lo = fmax(v - half_res, 0); real v_hi = v + half_res; real panel_width = (v_hi - v_lo) / n_panels; array[n_panels * 7] real log_terms; diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan index 8c85843..ac8ef23 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan @@ -201,9 +201,9 @@ functions { 0.4786286704993665, 0.2369268850561891}; real half_res = resolution / 2; - real v1_lo = fmax(v1 - half_res, 1e-6); real v1_hi = v1 + half_res; - real v2_lo = fmax(v2 - half_res, 1e-6); real v2_hi = v2 + half_res; - real v3_lo = fmax(v3 - half_res, 1e-6); real v3_hi = v3 + half_res; + real v1_lo = fmax(v1 - half_res, 0); real v1_hi = v1 + half_res; + real v2_lo = fmax(v2 - half_res, 0); real v2_hi = v2 + half_res; + real v3_lo = fmax(v3 - half_res, 0); real v3_hi = v3 + half_res; real mid1 = 0.5 * (v1_hi + v1_lo); real half1 = 0.5 * (v1_hi - v1_lo); real mid2 = 0.5 * (v2_hi + v2_lo); real half2 = 0.5 * (v2_hi - v2_lo); real mid3 = 0.5 * (v3_hi + v3_lo); real half3 = 0.5 * (v3_hi - v3_lo); diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan index a2fdd48..95c29c5 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan @@ -207,9 +207,9 @@ functions { 0.4786286704993665, 0.2369268850561891}; real half_res = resolution / 2; - real v1_lo = fmax(v1 - half_res, 1e-6); real v1_hi = v1 + half_res; - real v2_lo = fmax(v2 - half_res, 1e-6); real v2_hi = v2 + half_res; - real v3_lo = fmax(v3 - half_res, 1e-6); real v3_hi = v3 + half_res; + real v1_lo = fmax(v1 - half_res, 0); real v1_hi = v1 + half_res; + real v2_lo = fmax(v2 - half_res, 0); real v2_hi = v2 + half_res; + real v3_lo = fmax(v3 - half_res, 0); real v3_hi = v3 + half_res; real mid1 = 0.5 * (v1_hi + v1_lo); real half1 = 0.5 * (v1_hi - v1_lo); real mid2 = 0.5 * (v2_hi + v2_lo); real half2 = 0.5 * (v2_hi - v2_lo); real mid3 = 0.5 * (v3_hi + v3_lo); real half3 = 0.5 * (v3_hi - v3_lo); diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan index 8a9312b..cd8ab67 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan @@ -193,7 +193,7 @@ functions { 0.3818300505051189, 0.2797053914892767, 0.1294849661688697}; real half_res = resolution / 2; - real v_lo = fmax(v - half_res, 1e-6); + real v_lo = fmax(v - half_res, 0); real v_hi = v + half_res; real panel_width = (v_hi - v_lo) / n_panels; array[n_panels * 7] real log_terms; From b8c9fef95898e7ae5991635d482c1232b8159ba5 Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:53:28 +0100 Subject: [PATCH 23/30] add gamma_shared_phi_reliable --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index 7f71069..5ad10fc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ export(fit_corpus_parallel) export(fit_model) export(fit_with_escalation) export(gamma_phi_extreme_safe) +export(gamma_shared_phi_reliable) export(gamma_type2_reliable) export(generate_cdf_plot_simulation_study_input) export(generate_data_table) From f7f1b0b57a4283fba477f1f15f3994e5bcf5ef86 Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:54:03 +0100 Subject: [PATCH 24/30] add gamma_shared_phi_reliable --- R/utils.R | 160 ++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 144 insertions(+), 16 deletions(-) diff --git a/R/utils.R b/R/utils.R index fa66ff3..cb95dc1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -797,13 +797,13 @@ prepare_stan_data_from_datasets <- function(datasets, dist_type = 1, obs_stat3 = as.array(obs_stat3), resolution = as.array(resolution_vec), n_freq_total = length(freq_value_all), - freq_value = freq_value_all, - freq_lower = freq_lower_all, - freq_upper = freq_upper_all, - event_lower = event_lower_all, - event_upper = event_upper_all, - event_observed = event_observed_all, - freq_count = freq_count_all, + freq_value = as.array(freq_value_all), + freq_lower = as.array(freq_lower_all), + freq_upper = as.array(freq_upper_all), + event_lower = as.array(event_lower_all), + event_upper = as.array(event_upper_all), + event_observed = as.array(event_observed_all), + freq_count = as.array(freq_count_all), freq_start = as.array(freq_start_vec), freq_len = as.array(freq_len_vec), truncation_time = as.array(truncation_time_vec) @@ -1574,6 +1574,115 @@ gamma_phi_extreme_safe <- function(datasets, max_implied_phi = 60, verbose = TRU } +# Gamma shared-phi weak-identifiability heuristic ----------------------------- + +#' Check whether gamma's shared (mu0, tau, phi) surface is safe to attempt +#' +#' Diagnosed via `Zika/all/gamma` (2 datasets, mixed order-statistic and +#' frequency-interval types): repeated MCMC escalation gave the same +#' max_Rhat at both the cheap and moderate tiers - a genuinely +#' weakly-identified surface, not a hard boundary wall like Burr XII's +#' `kappa*phi_d>4` reject. Sample size alone does not predict this: +#' `MVD/all/gamma` (also 2 datasets, but two *homogeneous* quantile-type +#' datasets) has one clearly dominant mode and converges cleanly; +#' `YFV/all/gamma` (3 datasets, homogeneous frequency-table types) +#' converges to a single sharp optimum. +#' +#' Detected via repeated random-init `optimizing()` calls, matching +#' [burr_phid_reliable()]'s existing methodology, but with two changes +#' found necessary during calibration against the real corpus (not just +#' Zika): (1) Stan's default `init="random"` turned out to be a poor init +#' strategy for this model - it produced spurious optimiser failures even +#' on `MVD/all/gamma`, a known-good case (0/10 successes), fixed by +#' sampling each start from a generic wide normal instead. (2) requiring an +#' exact `return_code==0` was too strict for the same reason (many +#' known-good fits, e.g. `EVD/all/gamma`, only hit `return_code==0` on a +#' minority of starts) and the *range* of successful log-posteriors was not +#' robust - a single wild optimiser excursion (which happens even for +#' clean cases, unrelated to real multimodality) inflates the range +#' arbitrarily. The interquartile range (IQR) of all finite log-posteriors +#' obtained (regardless of return code) is far more robust: every +#' known-good case (MVD, YFV, SARS, Lassa, EVD) gives an IQR of exactly +#' 0.000 across repeated calibration runs with different seeds - the +#' central bulk of starts always finds the identical answer - while Zika's +#' IQR is consistently, clearly nonzero (0.3-1.2 across two independent +#' seed replications), and the already-known-bad Nipah/gamma and RVF/gamma +#' (both separately caught by [gamma_phi_extreme_safe()]) give IQRs in the +#' hundreds to thousands. +#' +#' @param datasets A named list of datasets as accepted by +#' [prepare_stan_data_from_datasets()]. +#' @param stan_model The compiled shared-phi model (`dist_type = 2`). +#' @param n_starts Number of random-init `rstan::optimizing()` calls. +#' @param min_success_frac Minimum fraction of starts that must return a +#' finite log-posterior (not error) at all. +#' @param iqr_tol Maximum tolerated interquartile range of log-posteriors +#' across finite starts before they're judged to reflect more than one +#' mode. +#' @param verbose Print a one-line verdict. +#' +#' @return `TRUE` if safe to attempt, `FALSE` if gamma should be skipped for +#' this pathogen/analysis (no fallback model exists, unlike Burr XII's +#' [burr_phid_reliable()]). +#' @export +gamma_shared_phi_reliable <- function(datasets, stan_model, n_starts = 20, + min_success_frac = 0.3, iqr_tol = 0.1, + verbose = TRUE) { + + stan_data <- tryCatch({ + sd_ <- prepare_stan_data_from_datasets(datasets, dist_type = 2L) + update_phi_prior(sd_, datasets) + }, error = function(e) NULL) + if (is.null(stan_data)) { + if (verbose) message("gamma_shared_phi_reliable: SKIP \u2014 data prep failed; treating gamma as unreliable to be safe.") + return(FALSE) + } + + # Generic, moderately wide inits (not tied to each dataset's own, + # possibly very narrow, prior sd) so different starts genuinely explore + # different regions - see calibration notes above. + init_fun <- function() list( + mu0 = stats::rnorm(1, stan_data$mu0_mean, 1), + log_tau = stats::rnorm(1, stan_data$log_tau_mean, 1), + log_phi = stats::rnorm(1, stan_data$log_phi_mean, 1), + log_kappa = stats::rnorm(1, 0, 1), + loc_d_raw = as.array(stats::rnorm(stan_data$n_datasets, 0, 1)) + ) + + vals <- numeric(0) + for (i in seq_len(n_starts)) { + opt <- tryCatch( + rstan::optimizing(stan_model, data = stan_data, seed = 20000 + i, hessian = FALSE, + as_vector = FALSE, init = init_fun()), + error = function(e) NULL + ) + if (!is.null(opt) && is.finite(opt$value)) vals <- c(vals, opt$value) + } + + success_frac <- length(vals) / n_starts + if (success_frac < min_success_frac) { + if (verbose) message(sprintf( + "gamma_shared_phi_reliable: SKIP \u2014 too many optimiser failures (%d/%d returned a finite value, need >= %.0f%%); ", + length(vals), n_starts, 100 * min_success_frac), + "the shared (mu0, tau, phi) surface is likely too weakly identified from this data.") + return(FALSE) + } + + iqr_val <- stats::IQR(vals) + if (iqr_val > iqr_tol) { + if (verbose) message(sprintf( + "gamma_shared_phi_reliable: SKIP \u2014 independent starts disagree (log-posterior IQR = %.3f > %.3f), no dominant mode.", + iqr_val, iqr_tol)) + return(FALSE) + } + + if (verbose) message(sprintf( + "gamma_shared_phi_reliable: OK \u2014 %d/%d starts returned a finite value with a single dominant mode (IQR = %.2e).", + length(vals), n_starts, iqr_val)) + TRUE +} + + # Compile Stan model ------------------------------------------------------- #' Compile a ddsynth Stan model @@ -1661,6 +1770,13 @@ compile_stan_model <- function(model = c("factorised", "joint")) { #' single-dataset fits. Defaults to `4000`. #' @param loo_chains Number of chains for the leave-one-out fits. Defaults to #' `2`. +#' @param loo_timeout_secs Wall-clock ceiling per individual LOO fit in Check +#' 5, forked via [parallel::mcparallel()] and killed with +#' `.kill_process_tree()` if it overruns. A normal fit takes a few seconds; +#' this guards against the rare dataset whose single-parameter posterior +#' lands in a genuinely slow numerical region and never returns. Default +#' `120` (2 min). A killed fit is recorded as `NA` in `loo_fits`, the same +#' as any other Check 5 failure. #' @param verbose Logical. If `TRUE` (default), prints a formatted summary of #' all check results to the console. #' @param filter Logical. If `TRUE`, any dataset flagged by at least one @@ -1694,6 +1810,7 @@ pre_inference_checks <- function(datasets, n_sim = 2000, loo_iter = 4000, loo_chains = 2, + loo_timeout_secs = 120, verbose = TRUE, filter = FALSE) { @@ -1880,15 +1997,26 @@ pre_inference_checks <- function(datasets, rhat = NA_real_, n_eff = NA_real_)) } - fit <- tryCatch( - suppressWarnings( - rstan::sampling(stan_model, data = single_data, - iter = loo_iter, chains = loo_chains, - refresh = 0, show_messages = FALSE) - ), - error = function(e) NULL - ) - if (is.null(fit) || fit@mode != 0L) { + # Forked with a timeout (not a plain tryCatch): a fit stuck in a + # pathologically slow numerical region for this one dataset never + # errors on its own, so this is the only thing that reclaims it. Same + # mechanism as fit_corpus_parallel()'s task timeout, just scaled down - + # a single-dataset fit at fixed settings normally takes a few seconds. + fit <- tryCatch({ + job <- parallel::mcparallel( + suppressWarnings( + rstan::sampling(stan_model, data = single_data, + iter = loo_iter, chains = loo_chains, + refresh = 0, show_messages = FALSE) + ), + silent = TRUE + ) + collected <- parallel::mccollect(job, wait = FALSE, timeout = loo_timeout_secs) + result <- collected[[as.character(job$pid)]] + if (is.null(result)) .kill_process_tree(job$pid) + result + }, error = function(e) NULL) + if (is.null(fit) || !inherits(fit, "stanfit") || fit@mode != 0L) { return(tibble::tibble(dataset = name, phi_mean = NA_real_, phi_lo = NA_real_, phi_hi = NA_real_, rhat = NA_real_, n_eff = NA_real_)) From 51795e3bf7f65c1e22cd79f4c12d3c4463e505e0 Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:54:49 +0100 Subject: [PATCH 25/30] add smooth log-barrier --- ...erarchical_data_synthesis_summary_stats.stan | 17 ++++++++++++++++- ...ical_data_synthesis_summary_stats_joint.stan | 10 +++++++++- ...ynthesis_summary_stats_joint_shared_phi.stan | 10 +++++++++- ...data_synthesis_summary_stats_shared_phi.stan | 17 ++++++++++++++++- 4 files changed, 50 insertions(+), 4 deletions(-) diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats.stan b/inst/stan/hierarchical_data_synthesis_summary_stats.stan index dec72dd..818843d 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats.stan @@ -687,10 +687,25 @@ model { // than the k*c > 2 needed for the variance alone. Hard barrier: // reject this region of parameter space for datasets that report // a mean and SD. - if (kappa * phi <= 4.0) { + real kc = kappa * phi; + if (kc <= 4.0) { moments_ok = 0; target += negative_infinity(); } else { + // The moments below already diverge smoothly (not a jump) as + // kc->4+ (lbeta's first argument -> 0+), and bvn_log_dens() + // already guards against the resulting overflow. But the switch + // right at kc=4, from computing this (possibly huge) value to an + // exact -Inf, is itself a non-differentiable cliff that gives + // gradient-based samplers/optimisers no advance warning. Adding a + // smooth log-barrier that fades to exactly 0 by kc=4+KC_MARGIN + // gives an early, well-defined gradient pushing away from the + // boundary, while leaving every configuration outside this small + // margin (the overwhelming majority of parameter space) + // numerically identical to before. + if (kc < 4.0 + 0.5) { + target += log(kc - 4.0) - log(0.5); + } real lam = exp(loc); real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan index ac8ef23..74bdd7e 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint.stan @@ -650,10 +650,18 @@ model { } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa // 4th moment (needed for Var(S^2)) requires k*c > 4, stricter than // the k*c > 2 needed for the variance alone. - if (kappa * phi <= 4.0) { + real kc = kappa * phi; + if (kc <= 4.0) { moments_ok = 0; target += negative_infinity(); } else { + // Smooth log-barrier just above the true boundary (see + // hierarchical_data_synthesis_summary_stats.stan for the full + // rationale): fades to exactly 0 by kc=4+KC_MARGIN, leaving + // every configuration outside this small margin unchanged. + if (kc < 4.0 + 0.5) { + target += log(kc - 4.0) - log(0.5); + } real lam = exp(loc); real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan index 95c29c5..d891ee3 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_joint_shared_phi.stan @@ -637,10 +637,18 @@ model { } else if (dist_type == 4) { // burr XII: lambda=exp(loc), c=phi, k=kappa // 4th moment (needed for Var(S^2)) requires k*c > 4, stricter than // the k*c > 2 needed for the variance alone. - if (kappa * phi <= 4.0) { + real kc = kappa * phi; + if (kc <= 4.0) { moments_ok = 0; target += negative_infinity(); } else { + // Smooth log-barrier just above the true boundary (see + // hierarchical_data_synthesis_summary_stats.stan for the full + // rationale): fades to exactly 0 by kc=4+KC_MARGIN, leaving + // every configuration outside this small margin unchanged. + if (kc < 4.0 + 0.5) { + target += log(kc - 4.0) - log(0.5); + } real lam = exp(loc); real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); diff --git a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan index cd8ab67..32c28fa 100644 --- a/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan +++ b/inst/stan/hierarchical_data_synthesis_summary_stats_shared_phi.stan @@ -658,10 +658,25 @@ model { // than the k*c > 2 needed for the variance alone. Hard barrier: // reject this region of parameter space for datasets that report // a mean and SD. - if (kappa * phi <= 4.0) { + real kc = kappa * phi; + if (kc <= 4.0) { moments_ok = 0; target += negative_infinity(); } else { + // The moments below already diverge smoothly (not a jump) as + // kc->4+ (lbeta's first argument -> 0+), and bvn_log_dens() + // already guards against the resulting overflow. But the switch + // right at kc=4, from computing this (possibly huge) value to an + // exact -Inf, is itself a non-differentiable cliff that gives + // gradient-based samplers/optimisers no advance warning. Adding a + // smooth log-barrier that fades to exactly 0 by kc=4+KC_MARGIN + // gives an early, well-defined gradient pushing away from the + // boundary, while leaving every configuration outside this small + // margin (the overwhelming majority of parameter space) + // numerically identical to before. + if (kc < 4.0 + 0.5) { + target += log(kc - 4.0) - log(0.5); + } real lam = exp(loc); real m1 = lam * kappa * exp(lbeta(kappa - 1.0/phi, 1 + 1.0/phi)); real m2 = lam^2 * kappa * exp(lbeta(kappa - 2.0/phi, 1 + 2.0/phi)); From b40ba3baf57c2a68206769da4277b27883b04f4f Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:57:14 +0100 Subject: [PATCH 26/30] time limit on pre-inference checks --- analysis/main_analysis.R | 64 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 63 insertions(+), 1 deletion(-) diff --git a/analysis/main_analysis.R b/analysis/main_analysis.R index b3eb2fd..f455887 100644 --- a/analysis/main_analysis.R +++ b/analysis/main_analysis.R @@ -85,6 +85,12 @@ RESERVE_CORES <- 4 # this the task is killed and recorded as timed out so the run keeps moving. TASK_TIMEOUT_SECS <- 90 * 60 +# Per-dataset ceiling for pre_inference_checks()'s Check 5 LOO fits (a much +# smaller, fixed-settings single-dataset fit, not a full escalation-ladder +# corpus fit) - measured normal cost is ~4-5s/dataset, so 2 min gives ample +# headroom while still catching a fit stuck in a pathological region. +CHECKS_LOO_TIMEOUT_SECS <- 120 + DIST_CODES <- c(lognormal = 1L, gamma = 2L, weibull = 3L, burr = 4L, gengamma = 5L) @@ -115,6 +121,13 @@ dir.create(OUTPUT_DIR, showWarnings = FALSE) TASK_DIR <- file.path(OUTPUT_DIR, "main_analysis_tasks") dir.create(TASK_DIR, showWarnings = FALSE) +# pre_inference_checks() results (one per pathogen x hierarchical family), +# cached independently of TASK_DIR/main_results.rds so recovery of the +# "filtered" dataset list doesn't depend on whether the corresponding fit - +# or any fit at all - has completed yet. +CHECKS_DIR <- file.path(OUTPUT_DIR, "main_analysis_checks") +dir.create(CHECKS_DIR, showWarnings = FALSE) + # ── 3. Pathogen registry ────────────────────────────────────────────────────── # Add or remove pathogens here. The name on the left is used as the key in @@ -277,6 +290,10 @@ SHARED_PHI_FAMILIES <- c("gamma") file.path(TASK_DIR, paste0(pathogen, "__", analysis_label, "__", dist_name, ".rds")) } +.checks_file <- function(pathogen, dist_name) { + file.path(CHECKS_DIR, paste0(pathogen, "__", dist_name, ".rds")) +} + # ── 7. Load results and apply force-rerun ──────────────────────────────────── @@ -298,6 +315,18 @@ if (length(FORCE_RERUN) > 0) { message("Force-rerun: clearing stored results for '", p, "'.") all_results[[p]] <- NULL } + + # A force-rerun should also recompute pre_inference_checks(), not just the + # fits - otherwise the cache below would keep serving the old filtered + # dataset list straight through the "cleared" run. + for (p in FORCE_RERUN) { + stale_checks <- Sys.glob(file.path(CHECKS_DIR, paste0(p, "__*.rds"))) + if (length(stale_checks) > 0) { + message("Force-rerun: clearing ", length(stale_checks), + " cached pre_inference_checks() result(s) for '", p, "'.") + unlink(stale_checks) + } + } } @@ -347,12 +376,24 @@ for (pathogen in names(pathogen_registry)) { analyses[["filtered"]] <- list(by_family = list(gamma = analyses[["all"]])) for (dist_name in HIERARCHICAL_FAMILIES) { + + checks_file <- .checks_file(pathogen, dist_name) + + if (file.exists(checks_file)) { + checks_res <- readRDS(checks_file) + analyses[["filtered"]]$by_family[[dist_name]] <- list(datasets = checks_res$datasets, checks = checks_res) + message("\n Recovered filtered datasets for ", dist_name, " from cached checks file.") + next + } + prior <- all_results[[pathogen]][["filtered"]][[dist_name]] if (!is.null(prior$datasets)) { analyses[["filtered"]]$by_family[[dist_name]] <- list(datasets = prior$datasets, checks = prior$checks) message("\n Recovered filtered datasets for ", dist_name, " from existing results.") + if (!is.null(prior$checks)) saveRDS(prior$checks, checks_file) next } + message("\n Running pre_inference_checks for filter (", dist_name, ")...") checks_res <- tryCatch( suppressWarnings( @@ -360,7 +401,8 @@ for (pathogen in names(pathogen_registry)) { datasets_full, stan_model, dist_type = DIST_CODES[[dist_name]], verbose = FALSE, - filter = TRUE + filter = TRUE, + loo_timeout_secs = CHECKS_LOO_TIMEOUT_SECS ) ), error = function(e) { @@ -369,6 +411,7 @@ for (pathogen in names(pathogen_registry)) { list(datasets = datasets_full) } ) + saveRDS(checks_res, checks_file) analyses[["filtered"]]$by_family[[dist_name]] <- list(datasets = checks_res$datasets, checks = checks_res) n_removed <- length(datasets_full) - length(checks_res$datasets) if (n_removed > 0) { @@ -509,6 +552,25 @@ for (pathogen in names(pathogen_registry)) { next } + # Gamma shared-(mu0,tau,phi) weak-identifiability check (see + # gamma_shared_phi_reliable() docs). Distinct from the two checks above: + # not a hard boundary/slow-series issue, a genuinely flat/multimodal + # surface diagnosed via Zika/all/gamma. Not predicted by sample size + # alone (MVD/all/gamma has the same n=2 but converges cleanly), so this + # runs unconditionally rather than being gated on n_datasets. + if (dist_name == "gamma" && + !gamma_shared_phi_reliable(analysis_datasets, stan_model_shared_phi, verbose = FALSE)) { + message("\n [SKIP] ", pathogen, " / ", analysis_label, + " / gamma — independent optimiser starts found no dominant", + " mode in the shared (mu0, tau, phi) surface", + " (gamma_shared_phi_reliable() check failed).") + all_results[[pathogen]][[analysis_label]][["gamma"]] <- + list(skipped = TRUE, + reason = "gamma_shared_phi_reliable", + datasets = analysis_datasets) + next + } + # Burr XII per-study phi_d reliability check (see burr_phid_reliable() docs). task_stan_model <- .model_for_family(dist_name) if (dist_name == "burr" && From 049e6bb46fdab16115a5ee0771918754484044e2 Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:57:29 +0100 Subject: [PATCH 27/30] add documentation --- man/pre_inference_checks.Rd | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/man/pre_inference_checks.Rd b/man/pre_inference_checks.Rd index 370db9e..c657e4e 100644 --- a/man/pre_inference_checks.Rd +++ b/man/pre_inference_checks.Rd @@ -15,6 +15,7 @@ pre_inference_checks( n_sim = 2000, loo_iter = 4000, loo_chains = 2, + loo_timeout_secs = 120, verbose = TRUE, filter = FALSE ) @@ -58,6 +59,14 @@ single-dataset fits. Defaults to \code{4000}.} \item{loo_chains}{Number of chains for the leave-one-out fits. Defaults to \code{2}.} +\item{loo_timeout_secs}{Wall-clock ceiling per individual LOO fit in Check +5, forked via \code{\link[parallel:mcparallel]{parallel::mcparallel()}} and killed with +\code{.kill_process_tree()} if it overruns. A normal fit takes a few seconds; +this guards against the rare dataset whose single-parameter posterior +lands in a genuinely slow numerical region and never returns. Default +\code{120} (2 min). A killed fit is recorded as \code{NA} in \code{loo_fits}, the same +as any other Check 5 failure.} + \item{verbose}{Logical. If \code{TRUE} (default), prints a formatted summary of all check results to the console.} From 00b63c4c733b0a18244eaac00570db735d115099 Mon Sep 17 00:00:00 2001 From: cm401 Date: Thu, 6 Aug 2026 10:57:37 +0100 Subject: [PATCH 28/30] fix test --- tests/testthat/test-prepare-stan-data.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-prepare-stan-data.R b/tests/testthat/test-prepare-stan-data.R index 27c4ee5..bd4bc82 100644 --- a/tests/testthat/test-prepare-stan-data.R +++ b/tests/testthat/test-prepare-stan-data.R @@ -35,8 +35,8 @@ test_that("type-4 (freq_value/freq_count) flat arrays and indexing are correct", expect_equal(sd$n_freq_total, 9L) # 5 + 4 entries expect_equal(as.integer(sd$freq_start), c(1L, 6L)) expect_equal(as.integer(sd$freq_len), c(5L, 4L)) - expect_equal(sd$freq_value[1:5], c(1, 2, 3, 4, 5)) - expect_equal(sd$freq_value[6:9], c(3, 4, 5, 6)) + expect_equal(as.vector(sd$freq_value[1:5]), c(1, 2, 3, 4, 5)) + expect_equal(as.vector(sd$freq_value[6:9]), c(3, 4, 5, 6)) # n: first dataset omits n → sum(freq_count) = 20; second provides n = 20 expect_equal(as.integer(sd$n_obs), c(20L, 20L)) }) @@ -47,8 +47,8 @@ test_that("type-5 (interval-censored freq) flat arrays and indexing are correct" expect_equal(sd$n_freq_total, 7L) # 4 + 3 entries expect_equal(as.integer(sd$freq_start), c(1L, 5L)) expect_equal(as.integer(sd$freq_len), c(4L, 3L)) - expect_equal(sd$freq_lower[1:4], c(0, 3, 6, 9)) - expect_equal(sd$freq_upper[1:4], c(3, 6, 9, 12)) + expect_equal(as.vector(sd$freq_lower[1:4]), c(0, 3, 6, 9)) + expect_equal(as.vector(sd$freq_upper[1:4]), c(3, 6, 9, 12)) # n: first dataset omits n → sum(freq_count) = 26; second provides n = 16 expect_equal(as.integer(sd$n_obs), c(26L, 16L)) }) From a3d217691107762d574f458d1df01df9b0705083 Mon Sep 17 00:00:00 2001 From: cm401 Date: Fri, 7 Aug 2026 07:50:59 +0100 Subject: [PATCH 29/30] fix to plots of fits --- R/ploting_utils.R | 40 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 37 insertions(+), 3 deletions(-) diff --git a/R/ploting_utils.R b/R/ploting_utils.R index 4c2e25f..cb45b29 100644 --- a/R/ploting_utils.R +++ b/R/ploting_utils.R @@ -1210,17 +1210,51 @@ compute_pathogen_model_bayes_factors <- function(all_results, analysis = "filter dist_results <- all_results[[pathogen]][[analysis]] if (is.null(dist_results)) next + # Only fits usable at all: not NULL/skipped-sentinel, has a fit and the + # dataset list used to build it (needed below to identify which + # observations are common across families). + usable <- Filter(function(nm) { + r <- dist_results[[nm]] + !is.null(r) && !isTRUE(r$skipped) && !is.null(r$fit) && !is.null(r$datasets) + }, names(dist_results)) + if (length(usable) == 0L) next + + # Since "filtered" is now family-specific (see POINT4_LIKELIHOOD_MATHS.md + # Part E.10), each family may have excluded a different subset of + # datasets. elpd_loo is a SUM over observations, so comparing it across + # families with different observation counts/membership would bias + # weights toward whichever family happened to filter out more data, + # regardless of genuine relative fit quality. Restricting every family's + # LOO computation to the datasets common to all of them makes the + # comparison apples-to-apples; each family's own final reported fit + # (e.g. in Table 1) is unaffected - only this cross-family weighting + # step is restricted. + common_datasets <- Reduce(intersect, lapply(usable, function(nm) names(dist_results[[nm]]$datasets))) + if (length(common_datasets) == 0L) { + message(" [WARN] ", pathogen, ": no datasets common to every family's '", + analysis, "' fit - skipping model comparison.") + next + } + elpds <- c() - for (dist_name in names(dist_results)) { + for (dist_name in usable) { r <- dist_results[[dist_name]] - # Skip: NULL slot, skipped-GG sentinel, or failed fit - if (is.null(r) || isTRUE(r$skipped) || is.null(r$fit)) next elpd <- tryCatch({ # Extract log_lik matrix (draws × log_lik slots) ll_mat <- rstan::extract(r$fit, "log_lik")$log_lik + # log_lik has 3 columns per dataset (vector[n_datasets*3] in Stan, + # filled dataset-by-dataset with idx += 3 each time), in the same + # order as r$datasets. Map the common dataset names to THIS fit's + # own column indices - a given dataset can sit at a different index + # in different families' filtered lists. + own_idx <- match(common_datasets, names(r$datasets)) + if (anyNA(own_idx)) stop("a common dataset is missing from this fit's own datasets") + keep_cols <- as.vector(vapply(own_idx, function(d) (3L * (d - 1L)) + 1:3, integer(3))) + ll_mat <- ll_mat[, keep_cols, drop = FALSE] + # The Stan model stores zero-filled placeholder columns for unused # summary-statistic slots (e.g. slot 3 for mean+SD datasets, slots # 2 and 3 for frequency-table datasets). Remove them before LOO so From 1179a4c904959054b90d706c19de4472c6908b51 Mon Sep 17 00:00:00 2001 From: cm401 Date: Fri, 7 Aug 2026 07:51:30 +0100 Subject: [PATCH 30/30] improvements on how we kill processes --- R/utils.R | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 59 insertions(+), 4 deletions(-) diff --git a/R/utils.R b/R/utils.R index cb95dc1..f31690a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2749,6 +2749,11 @@ fit_with_escalation <- function(stan_data, stan_model, rhat_target = 1.05, #' own PSOCK cluster underneath, which would otherwise survive as zombies. #' Walks `ps`'s process table to find and kill all descendants too. #' +#' `pid` is assumed to be an `mcparallel()` job PID still registered in +#' `parallel`'s internal job table, so after killing the whole tree we +#' `mccollect()` on `pid` alone (not its descendants, which were never +#' `parallel` jobs themselves) to reap it and avoid leaving a zombie. +#' #' @param pid Integer or character process ID to kill, with its descendants. #' @return Invisibly, the PIDs killed (including `pid`). #' @noRd @@ -2770,6 +2775,11 @@ fit_with_escalation <- function(stan_data, stan_model, rhat_target = 1.05, all_pids <- c(pid, descendants_of(pid)) } for (p in all_pids) tryCatch(tools::pskill(p, signal = tools::SIGKILL), error = function(e) NULL) + # Bounded, not wait=TRUE: a SIGKILL'd process should reap almost instantly, + # but a process wedged in uninterruptible I/O sleep could block forever, + # which would turn this cleanup step into a new hang. + tryCatch(suppressWarnings(parallel::mccollect(pid, wait = FALSE, timeout = 5)), + error = function(e) NULL) invisible(all_pids) } @@ -4028,6 +4038,35 @@ generate_hierarchical_data_mixed <- function(n_datasets, } } + # Per-order-statistic adaptive quadrature panel count (Lever 3; performance + # only, see prepare_stan_data_from_datasets() for the real-data version). + # Uses the known true phi/kappa directly rather than a method-of-moments + # guess, since ground truth is available here. + dist_type_int <- switch(dist_type, + "lognormal" = 1L, "gamma" = 2L, "weibull" = 3L, + "burr12" = 4L, "gengamma" = 5L) + n_panels_stat1 <- integer(n_datasets) + n_panels_stat2 <- integer(n_datasets) + n_panels_stat3 <- integer(n_datasets) + for (d in seq_len(n_datasets)) { + n <- n_obs[d] + if (summary_type[d] == 1L) { + k_median <- (n + 1L) %/% 2L + n_panels_stat1[d] <- .order_stat_n_panels(obs_stat1[d], n, k_median, resolution_vec[d], dist_type_int, phi, kappa) + n_panels_stat2[d] <- .order_stat_n_panels(obs_stat2[d], n, 1L, resolution_vec[d], dist_type_int, phi, kappa) + n_panels_stat3[d] <- .order_stat_n_panels(obs_stat3[d], n, n, resolution_vec[d], dist_type_int, phi, kappa) + } else if (summary_type[d] == 2L) { + k_median <- (n + 1L) %/% 2L + k_q25 <- max((n + 1L) %/% 4L, 1L) + k_q75 <- min(max((3L * (n + 1L)) %/% 4L, k_q25 + 1L), n) + n_panels_stat1[d] <- .order_stat_n_panels(obs_stat1[d], n, k_median, resolution_vec[d], dist_type_int, phi, kappa) + n_panels_stat2[d] <- .order_stat_n_panels(obs_stat2[d], n, k_q25, resolution_vec[d], dist_type_int, phi, kappa) + n_panels_stat3[d] <- .order_stat_n_panels(obs_stat3[d], n, k_q75, resolution_vec[d], dist_type_int, phi, kappa) + } else { + n_panels_stat1[d] <- 24L; n_panels_stat2[d] <- 24L; n_panels_stat3[d] <- 24L + } + } + list( true_params = list( mu0 = mu0, @@ -4050,15 +4089,25 @@ generate_hierarchical_data_mixed <- function(n_datasets, obs_stat2 = as.array(obs_stat2), obs_stat3 = as.array(obs_stat3), resolution = as.array(resolution_vec), + n_panels_stat1 = as.array(n_panels_stat1), + n_panels_stat2 = as.array(n_panels_stat2), + n_panels_stat3 = as.array(n_panels_stat3), # Frequency table fields (populated only when summary_type == 4) n_freq_total = length(freq_value_flat), - freq_value = freq_value_flat, - freq_count = freq_count_flat, + freq_value = as.array(freq_value_flat), + freq_count = as.array(freq_count_flat), freq_start = as.array(freq_start_vec), freq_len = as.array(freq_len_vec), # Frequency-table interval bounds (type-5 datasets only; zeros for types 1-4) - freq_lower = rep(0.0, length(freq_value_flat)), - freq_upper = rep(0.0, length(freq_value_flat)), + freq_lower = as.array(rep(0.0, length(freq_value_flat))), + freq_upper = as.array(rep(0.0, length(freq_value_flat))), + # Double-censoring fields (summary_type 6/7) - this generator never + # produces those types, so these are unused placeholders, matching + # prepare_stan_data_from_datasets()'s convention for the same case. + event_lower = as.array(rep(0.0, length(freq_value_flat))), + event_upper = as.array(rep(0.0, length(freq_value_flat))), + event_observed = as.array(rep(1L, length(freq_value_flat))), + truncation_time = as.array(rep(0.0, n_datasets)), # Priors — calibrated defaults matching prepare_stan_data_from_datasets() mu0_mean = 1.0, mu0_sd = 1.0, @@ -4068,6 +4117,12 @@ generate_hierarchical_data_mixed <- function(n_datasets, lognormal = -0.7, gamma = 2.5, weibull = 1.0, burr12 = 0.7, gengamma = -0.5), log_phi_sd = 0.5, + # Between-study SD of log dispersion (point 4) - family-specific + # values matching update_phi_prior()'s dist_defaults table. + log_omega_mean = switch(dist_type, + lognormal = -0.9, gamma = -0.4, weibull = -0.8, + burr12 = -0.9, gengamma = -0.7), + log_omega_sd = 0.5, log_kappa_mean = switch(dist_type, lognormal = 0.0, gamma = 0.0, weibull = 0.0, burr12 = 1.0, gengamma = 0.0),