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.
|
||||
|
||||
Reference in New Issue
Block a user