Validation, NCE analysis, per-replicate oracle for landmark/naive, RCT truths script, resumable experiment runner
- W0 harm validation (40 reps): CCW and sequential ITT unbiased for their truths (|z| <= 0.7) - PVI models fitted separately inside and after the window - experiments.yml grid (8 worlds x 3 scenarios; designs x V1-V4; NCE; RCTs); smoke run clean Co-Authored-By: Claude Opus 5.5 <[email protected]>
This commit is contained in:
Claude Opus 5.5
+31
-12
@@ -21,13 +21,15 @@ VARIANTS <- c("V1_ignore", "V2_cluster", "V3_random", "V4_within")
|
||||
#' MALE and no PVI before the decision in month t: the risk set of the PVI model.
|
||||
pvi_risk_set <- function(rec) {
|
||||
p <- rec$patients
|
||||
pm <- merge(rec$pm, p[, c("id", "phys_id", BASE_COVS, "t_pvi", "pvi_elective", "t_male", "t_death"),
|
||||
extra <- intersect("t_pvi_orig", names(p))
|
||||
pm <- merge(rec$pm, p[, c("id", "phys_id", BASE_COVS, "t_pvi", "pvi_elective", "t_male", "t_death", extra),
|
||||
with = FALSE], by = "id")
|
||||
pm <- pm[(is.na(t_death) | t_death > t) & (is.na(t_male) | t_male > t) & (is.na(t_pvi) | t_pvi >= t)]
|
||||
pm[, pvi := as.integer(!is.na(t_pvi) & t_pvi == t)]
|
||||
sev0 <- rec$pm[t == 0, .(id, sev0 = sev_obs)]
|
||||
pm <- merge(pm, sev0, by = "id")
|
||||
pm[, `:=`(win = as.integer(t < rec$par$size$window), tt = pmin(t, 12))]
|
||||
if (length(extra)) pm[, pvi_before := as.integer(!is.na(t_pvi_orig) & t_pvi_orig < t)]
|
||||
pm[]
|
||||
}
|
||||
|
||||
@@ -41,7 +43,7 @@ pvi_risk_set <- function(rec) {
|
||||
#' variant: V1/V2 no physician terms; V3 physician random intercept (glmer, nAGQ = 0);
|
||||
#' V4 physician fixed effects (fixest). Under V4 a physician with no PVI in a phase has
|
||||
#' no estimable intercept for it; the maximum-likelihood probability there is 0.
|
||||
fit_pvi <- function(data, newdata, variant) {
|
||||
fit_pvi <- function(data, newdata, variant, extra_covs = NULL) {
|
||||
out <- numeric(nrow(newdata))
|
||||
for (w in c(1L, 0L)) {
|
||||
i_new <- newdata$win == w
|
||||
@@ -49,13 +51,14 @@ fit_pvi <- function(data, newdata, variant) {
|
||||
d <- data[win == w]
|
||||
nd <- newdata[i_new]
|
||||
tt_levels <- if (w == 1L) "factor(tt)" else "splines::ns(t, df = 4)"
|
||||
out[i_new] <- fit_pvi_phase(d, nd, variant, tt_levels)
|
||||
# no exposure at all in a phase (the NCE after the window): probability 0
|
||||
out[i_new] <- if (sum(d$pvi) == 0) 0 else fit_pvi_phase(d, nd, variant, tt_levels, extra_covs)
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
fit_pvi_phase <- function(d, nd, variant, time_terms) {
|
||||
covs <- c(BASE_COVS, "sev_obs", "sev0")
|
||||
fit_pvi_phase <- function(d, nd, variant, time_terms, extra_covs = NULL) {
|
||||
covs <- c(BASE_COVS, "sev_obs", "sev0", extra_covs)
|
||||
if (variant == "V4_within") covs <- setdiff(covs, "obl")
|
||||
rhs <- paste(c(covs, time_terms), collapse = " + ")
|
||||
if (variant %in% c("V1_ignore", "V2_cluster")) {
|
||||
@@ -161,12 +164,13 @@ run_design <- function(rec, design, variant, outcomes = c(male = "t_male", disea
|
||||
nco1 = "t_nco1", nco2 = "t_nco2")) {
|
||||
rec <- restrict_variant(rec, variant)
|
||||
rs <- if (design %in% c("ccw", "seq")) pvi_risk_set(rec) else NULL
|
||||
phat <- if (design == "ccw") fit_pvi(rs, rs, variant) else NULL
|
||||
phat <- if (design == "ccw") fit_pvi(rs, rs, variant, rec$extra_covs) else NULL
|
||||
cmp <- if (is.null(rec$comparators)) c("B1", "B2") else rec$comparators
|
||||
out <- lapply(names(outcomes), function(o) {
|
||||
r <- switch(design,
|
||||
naive = cbind(contrast = "early_none", est_naive(rec, outcomes[[o]], variant)),
|
||||
landmark = cbind(contrast = "early_none", est_landmark(rec, outcomes[[o]], variant)),
|
||||
ccw = est_ccw(rec, outcomes[[o]], variant, rs = copy(rs), phat = phat),
|
||||
landmark = cbind(contrast = "early_none", est_landmark(rec, outcomes[[o]], variant, extra_covs = rec$extra_covs)),
|
||||
ccw = est_ccw(rec, outcomes[[o]], variant, rs = copy(rs), phat = phat, comparators = cmp),
|
||||
seq = cbind(contrast = "now_not", est_seq(rec, outcomes[[o]], variant, rs = copy(rs))))
|
||||
r[, `:=`(outcome = o, design = design, variant = variant, n = nrow(rec$patients))]
|
||||
use_patient <- variant == "V1_ignore"
|
||||
@@ -178,13 +182,13 @@ run_design <- function(rec, design, variant, outcomes = c(male = "t_male", disea
|
||||
|
||||
#' Naive "ever early PVI" design: exposure = PVI in months 0..W-1, follow-up from month 0,
|
||||
#' baseline propensity score. Immortal time is present by construction.
|
||||
est_naive <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60L) {
|
||||
est_naive <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60L, extra_covs = NULL) {
|
||||
W <- rec$par$size$window
|
||||
p <- copy(rec$patients)
|
||||
p[, `:=`(t_out = get(outcome), arm = ifelse(!is.na(t_pvi) & t_pvi < W, "early", "none"))]
|
||||
p <- merge(p, rec$pm[t == 0, .(id, sev_obs)], by = "id")
|
||||
p[, pvi := as.integer(arm == "early")]
|
||||
ps <- fit_pvi_ps(p, variant, covs = c(BASE_COVS, "sev_obs")) # sev_obs is the month-0 value here
|
||||
ps <- fit_pvi_ps(p, variant, covs = c(BASE_COVS, "sev_obs", extra_covs)) # sev_obs is the month-0 value here
|
||||
p[, w := ifelse(arm == "early", 1 / ps, 1 / (1 - ps))]
|
||||
d <- expand_followup(p[!is.na(w)], 0L, horizon)
|
||||
rd_from_aj(aj_cif(d, horizon), "early", "none")
|
||||
@@ -212,7 +216,7 @@ fit_pvi_ps <- function(p, variant, covs = c(BASE_COVS, "sev_obs", "sev0")) {
|
||||
#' Landmark at month W (D13): patients alive and MALE-free at the start of month W;
|
||||
#' exposure = PVI in months 0..W-1; covariates at diagnosis and at month W-1;
|
||||
#' outcome counted in months W..horizon-1.
|
||||
est_landmark <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60L) {
|
||||
est_landmark <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60L, extra_covs = NULL) {
|
||||
W <- rec$par$size$window
|
||||
p <- copy(rec$patients)[(is.na(t_death) | t_death >= W) & (is.na(t_male) | t_male >= W)]
|
||||
p[, `:=`(t_out = get(outcome), arm = ifelse(!is.na(t_pvi) & t_pvi < W, "early", "none"))]
|
||||
@@ -220,7 +224,7 @@ est_landmark <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon
|
||||
p <- merge(p, rec$pm[t == W - 1L, .(id, sev_obs)], by = "id")
|
||||
p <- merge(p, rec$pm[t == 0, .(id, sev0 = sev_obs)], by = "id")
|
||||
p[, pvi := as.integer(arm == "early")]
|
||||
ps <- fit_pvi_ps(p, variant)
|
||||
ps <- fit_pvi_ps(p, variant, covs = c(BASE_COVS, "sev_obs", "sev0", extra_covs))
|
||||
p[, w := ifelse(arm == "early", 1 / ps, 1 / (1 - ps))]
|
||||
d <- expand_followup(p[!is.na(w)], W, horizon)
|
||||
rd_from_aj(aj_cif(d, horizon), "early", "none")
|
||||
@@ -300,3 +304,18 @@ est_seq <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60
|
||||
data.table(est = sum(res$wt * res$est), se_patient = sqrt(sum(pi$inf^2)),
|
||||
se_cluster = sqrt(sum(tapply(pi$inf, pi$phys_id, sum)^2)), risk1 = NA_real_, risk0 = NA_real_)
|
||||
}
|
||||
|
||||
#' Negative-control exposure (D32, D36): the early low-value procedure (NCE, months
|
||||
#' 0..W-1) takes the place of early PVI as the exposure; early-PVI status is adjusted
|
||||
#' for (time-varying "PVI before t" in CCW, "PVI in the window" at the landmark).
|
||||
#' Only the landmark and CCW (A vs B1) designs are run.
|
||||
nce_records <- function(rec, adjust_pvi = TRUE) {
|
||||
W <- rec$par$size$window
|
||||
p <- copy(rec$patients)
|
||||
p[, `:=`(t_pvi_orig = t_pvi, pvi_before = as.integer(!is.na(t_pvi) & t_pvi < W))]
|
||||
p[, `:=`(t_pvi = t_nce, pvi_elective = !is.na(t_nce))]
|
||||
rec$patients <- p
|
||||
rec$extra_covs <- if (adjust_pvi) "pvi_before" else NULL
|
||||
rec$comparators <- "B1"
|
||||
rec
|
||||
}
|
||||
|
||||
@@ -0,0 +1,29 @@
|
||||
# Own estimands of the non-interventional designs (plan 5.5). The landmark and naive
|
||||
# contrasts have no intervention that defines them; their own estimand is what the same
|
||||
# estimator gives with every confounder measured (oracle): exact severity, true frailty
|
||||
# and smoking, and the latent physician traits. A large-n limit is too noisy (the
|
||||
# landmark estimator has few treated patients), so the oracle estimator is run on every
|
||||
# replicate's own data: estimation bias = mean(estimate - oracle estimate), paired, and
|
||||
# the oracle mean estimates the own estimand.
|
||||
|
||||
#' The replicate's records with the hidden truth in place of the claims proxies.
|
||||
oracle_records <- function(rec) {
|
||||
o <- rec
|
||||
o$pm <- merge(rec$pm[, .(id, t)], rec$hidden_pm, by = c("id", "t"))[, .(id, t, sev_obs = z)]
|
||||
h <- rec$hidden
|
||||
o$patients <- merge(copy(rec$patients)[, c("frailty_index", "smoking") := NULL],
|
||||
h[, .(id, frailty_index = frailty, smoking = smoking_true, skill, style)], by = "id")
|
||||
o$extra_covs <- c("skill", "style")
|
||||
o
|
||||
}
|
||||
|
||||
#' Oracle versions of the landmark and naive designs (V1, patient-level SE).
|
||||
run_oracle <- function(rec, outcomes = c(male = "t_male", disease = "t_disease", nco1 = "t_nco1", nco2 = "t_nco2")) {
|
||||
o <- oracle_records(rec)
|
||||
rbindlist(lapply(names(outcomes), function(nm) {
|
||||
lm <- est_landmark(o, outcomes[[nm]], "V1_ignore", extra_covs = o$extra_covs)
|
||||
nv <- est_naive(o, outcomes[[nm]], "V1_ignore", extra_covs = o$extra_covs)
|
||||
rbind(cbind(design = "landmark", lm), cbind(design = "naive", nv))[
|
||||
, `:=`(outcome = nm, contrast = "early_none", variant = "oracle", se = se_patient)]
|
||||
}))
|
||||
}
|
||||
+2
-1
@@ -43,7 +43,8 @@ make_records <- function(pop, course, par) {
|
||||
hidden <- data.table(id = pat$id, skill = pat$skill, style = pat$style, frailty = pat$frailty,
|
||||
smoking_true = pat$smoking_true, rate = pat$rate,
|
||||
t_clti_true = ev$t_clti_true)
|
||||
list(patients = patients, pm = pm, hidden = hidden, par = par)
|
||||
hidden_pm <- data.table(id = id, t = t, z = course$z[idx])
|
||||
list(patients = patients, pm = pm, hidden = hidden, hidden_pm = hidden_pm, par = par)
|
||||
}
|
||||
|
||||
#' Stop if an analysis table carries a latent column.
|
||||
|
||||
@@ -0,0 +1,20 @@
|
||||
# RCT ITT truths for every world x scenario (the landmark and naive own estimands are
|
||||
# estimated within replicates by run_oracle()). Writes simulations/truths/truths_rct.csv.
|
||||
# Usage: Rscript simulations/03_limits.R [n] [cores]
|
||||
pkgload::load_all("pvisim", quiet = TRUE)
|
||||
suppressPackageStartupMessages(library(data.table))
|
||||
a <- commandArgs(TRUE)
|
||||
n <- if (length(a) >= 1) as.numeric(a[1]) else 5e5
|
||||
cores <- if (length(a) >= 2) as.integer(a[2]) else 6L
|
||||
raw <- yaml::read_yaml(default_params_path())
|
||||
jobs <- CJ(world = names(raw$worlds), scenario = names(raw$scenarios), sorted = FALSE)
|
||||
res <- parallel::mclapply(seq_len(nrow(jobs)), function(i) {
|
||||
w <- jobs$world[i]; s <- jobs$scenario[i]
|
||||
par <- load_params(w, s)
|
||||
rbind(rct_truth(par, "realistic", n = 1e6)[outcome %in% c("male", "disease", "nco1", "nco2")],
|
||||
rct_truth(par, "ideal", n = 1e6)[outcome %in% c("male", "disease", "nco1", "nco2")])
|
||||
}, mc.cores = cores)
|
||||
bad <- vapply(res, inherits, TRUE, "try-error")
|
||||
if (any(bad)) stop(res[bad][[1]])
|
||||
fwrite(rbindlist(res), "simulations/truths/truths_rct.csv")
|
||||
cat("wrote simulations/truths/truths_rct.csv\n")
|
||||
@@ -0,0 +1,12 @@
|
||||
# Experiment grids (plan sections 5.2, 7, 9). Run with simulations/run_experiment.R <grid> [--scale draft|final]
|
||||
main:
|
||||
worlds: [W0, W1, W1_rho0, W2, W3, W4, W5, WR]
|
||||
scenarios: ["null", harm, benefit_harm]
|
||||
designs: [naive, landmark, ccw, seq]
|
||||
variants: [V1_ignore, V3_random, V4_within] # V1 also yields V2 (cluster-robust SE)
|
||||
nce: true # negative-control exposure (landmark, CCW), D32/D36
|
||||
rct: [realistic, ideal]
|
||||
scales:
|
||||
smoke: {n_patients: 20000, reps: 1}
|
||||
draft: {n_patients: 50000, reps: 100}
|
||||
final: {n_patients: 50000, reps: 500} # to be revisited after the draft (sample size, D25/D29)
|
||||
@@ -0,0 +1,60 @@
|
||||
# Run an experiment grid; one CSV per world x scenario x replicate, so runs are resumable.
|
||||
# Usage: Rscript simulations/run_experiment.R main [--scale draft] [--cores 10] [--worlds W0,W2]
|
||||
pkgload::load_all("pvisim", quiet = TRUE)
|
||||
suppressPackageStartupMessages(library(data.table))
|
||||
a <- commandArgs(TRUE)
|
||||
opt <- function(flag, default) { i <- match(flag, a); if (is.na(i)) default else a[i + 1] }
|
||||
grid_name <- a[1]
|
||||
scale <- opt("--scale", "draft")
|
||||
cores <- as.integer(opt("--cores", "10"))
|
||||
cfg <- yaml::read_yaml("simulations/config/experiments.yml")
|
||||
g <- cfg[[grid_name]]; sc <- cfg$scales[[scale]]
|
||||
worlds <- if (is.null(opt("--worlds", NULL))) g$worlds else strsplit(opt("--worlds", NULL), ",")[[1]]
|
||||
outdir <- file.path("results", grid_name, scale)
|
||||
jobs <- CJ(world = worlds, scenario = unlist(g$scenarios), rep = seq_len(sc$reps), sorted = FALSE)
|
||||
jobs[, file := file.path(outdir, world, scenario, sprintf("rep%03d.csv", rep))]
|
||||
todo <- jobs[!file.exists(file)]
|
||||
cat(sprintf("%s/%s: %d jobs, %d to do, %d cores\n", grid_name, scale, nrow(jobs), nrow(todo), cores))
|
||||
|
||||
one_job <- function(i) {
|
||||
j <- todo[i]
|
||||
par <- load_params(j$world, j$scenario)
|
||||
rec <- simulate_records(par, rep = j$rep, n = sc$n_patients)
|
||||
out <- list()
|
||||
for (v in g$variants) {
|
||||
for (d in g$designs) {
|
||||
r <- run_design(rec, d, v)
|
||||
if (v == "V1_ignore") { # same fit, two SEs
|
||||
r2 <- copy(r)[, `:=`(variant = "V2_cluster", se = se_cluster)]
|
||||
r <- rbind(r, r2)
|
||||
}
|
||||
out[[length(out) + 1]] <- r[, analysis := "main"]
|
||||
}
|
||||
if (isTRUE(g$nce)) for (d in c("landmark", "ccw")) {
|
||||
r <- run_design(nce_records(rec), d, v, outcomes = c(male = "t_male", disease = "t_disease"))
|
||||
if (v == "V1_ignore") r <- rbind(r, copy(r)[, `:=`(variant = "V2_cluster", se = se_cluster)])
|
||||
out[[length(out) + 1]] <- r[, analysis := "nce"]
|
||||
}
|
||||
}
|
||||
for (d in c("landmark", "ccw")) { # unadjusted NCE (supplement, D36), V1/V2 only
|
||||
r <- run_design(nce_records(rec, adjust_pvi = FALSE), d, "V1_ignore", outcomes = c(male = "t_male", disease = "t_disease"))
|
||||
out[[length(out) + 1]] <- r[, analysis := "nce_unadjusted"]
|
||||
}
|
||||
out[[length(out) + 1]] <- run_oracle(rec)[, analysis := "main"] # own estimand of landmark / naive
|
||||
for (dz in g$rct) {
|
||||
r <- run_rct(par, dz, rep = j$rep)
|
||||
out[[length(out) + 1]] <- r[, `:=`(contrast = analysis, analysis = "rct", variant = "none", se = se_patient)]
|
||||
}
|
||||
res <- rbindlist(out, fill = TRUE)[, `:=`(world = j$world, scenario = j$scenario, rep = j$rep)]
|
||||
dir.create(dirname(j$file), recursive = TRUE, showWarnings = FALSE)
|
||||
fwrite(res, j$file)
|
||||
NULL
|
||||
}
|
||||
t0 <- Sys.time()
|
||||
res <- parallel::mclapply(seq_len(nrow(todo)), function(i) tryCatch(one_job(i), error = function(e)
|
||||
sprintf("%s/%s/%d: %s", todo$world[i], todo$scenario[i], todo$rep[i], conditionMessage(e))),
|
||||
mc.cores = cores, mc.preschedule = FALSE)
|
||||
err <- unlist(res[!vapply(res, is.null, TRUE)])
|
||||
cat(sprintf("done in %.1f h; %d errors\n", as.numeric(Sys.time() - t0, units = "hours"), length(err)))
|
||||
dir.create(outdir, recursive = TRUE, showWarnings = FALSE)
|
||||
if (length(err)) { writeLines(err, file.path(outdir, sprintf("errors_%s.txt", format(Sys.time(), "%Y%m%d_%H%M")))); cat(head(err, 3), sep = "\n") }
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -19,7 +19,8 @@ res <- rbindlist(parallel::mclapply(seq_len(reps), function(r) {
|
||||
fill = TRUE)
|
||||
}, mc.cores = cores), fill = TRUE)
|
||||
|
||||
tr <- fread("simulations/truths/truths.csv")[world == ..world & scenario == ..scenario]
|
||||
w_ <- world; s_ <- scenario
|
||||
tr <- fread("simulations/truths/truths.csv")[world == w_ & scenario == s_]
|
||||
map <- data.table(design = c("ccw", "ccw", "seq"), contrast = c("A_B1", "A_B2", "now_not"),
|
||||
estimand = c("rd_A_B1", "rd_A_B2", "seq_itt"))
|
||||
s <- res[, .(mean_est = mean(est), emp_se = sd(est), mean_se = mean(se), reps = .N),
|
||||
|
||||
Reference in New Issue
Block a user