chendun1995/tte-surgery
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

D55: EHR/registry-like world (noisy severity), non-random trial consent, trial analyses at 12/24/60 months

Browse Source 
Co-Authored-By: Claude Opus 5.5 <[email protected]>
This commit is contained in:
chendun1995
2026-10-28 16:26:01 -04:00
co-authored by Claude Opus 5.5
parent 307f75b63e
commit d369a16208
8 changed files with 72 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files
pvisim/R/rct.R
+32 -16
View File
@@ -1,16 +1,27 @@
# Simulated randomized trials (plan section 8, D18).
#
# Realistic RCT: hospital-based (OBL = 0) physicians in the top third of skill and the
# bottom half of style; 30% of their eligible patients consent; n = 240.
# bottom half of style; on average 30% of their eligible patients consent, less often when
# older or frailer (OR 0.7 per 10 years and per SD of frailty; D55); n = 240.
# Ideal pragmatic RCT: all physicians, everyone consents, large n.
# Assignment A: PVI at a scheduled month 0..2 (uniform); 10% refuse and follow usual care.
# Assignment B: no protocol PVI in the window; crossover happens through the DGP's own
# PVI process (usual care), and usual care continues after the window.
RCT_DESIGNS <- list(
realistic = list(n = 240L, consent = 0.30, select = TRUE),
ideal = list(n = NA, consent = 1.00, select = FALSE)
realistic = list(n = 240L, consent = 0.30, select = TRUE, consent_or = c(age10 = 0.7, frailty = 0.7)),
ideal = list(n = NA, consent = 1.00, select = FALSE, consent_or = NULL)
)
RCT_HORIZONS <- c(12L, 24L, 60L) # trials usually report at 1-2 years (D55)
#' Probability that each eligible patient consents: mean `spec$consent`, lower for older
#' and frailer patients (Wasmann 2019, King 2005: refusers differ moderately by covariates).
consent_prob <- function(pat, spec) {
if (is.null(spec$consent_or)) return(rep(spec$consent, nrow(pat)))
lp <- log(spec$consent_or[["age10"]]) * (pat$age - 76) / 10 + log(spec$consent_or[["frailty"]]) * pat$frailty
a <- uniroot(function(a) mean(plogis(a + lp)) - spec$consent, c(-10, 10))$root
plogis(a + lp)
}
#' Physicians a realistic trial would recruit.
trial_physicians <- function(phys) {
@@ -25,7 +36,7 @@ enrol_trial <- function(pop, design = c("realistic", "ideal"), n = NULL, seed =
set.seed(seed)
pat <- pop$pat
if (spec$select) pat <- pat[phys_id %in% trial_physicians(pop$phys)]
pat <- pat[runif(.N) < spec$consent]
pat <- pat[runif(.N) < consent_prob(pat, spec)]
n <- if (!is.null(n)) n else if (is.na(spec$n)) nrow(pat) else spec$n
if (nrow(pat) < n) stop("not enough consenting patients: ", nrow(pat), " < ", n)
pat <- pat[sort(sample.int(.N, n))]
@@ -58,33 +69,38 @@ run_rct <- function(par, design = "realistic", rep = 1L, outcomes = c(male = "t_
W <- par$size$window
ev[, `:=`(phys_id = trial$pop$pat$phys_id, assigned = trial$arm,
treated_win = ifelse(!is.na(t_pvi) & t_pvi < W, "early", "none"))]
rbindlist(lapply(names(outcomes), function(o) {
rbindlist(lapply(names(outcomes), function(o) rbindlist(lapply(RCT_HORIZONS, function(h) {
p <- ev[, .(id, phys_id, assigned, treated_win, t_out = get(outcomes[[o]]), t_death)]
itt <- rd_from_aj(aj_cif(expand_followup(copy(p)[, `:=`(arm = assigned, w = 1)], 0L)), "A", "B")
at <- rd_from_aj(aj_cif(expand_followup(copy(p)[, `:=`(arm = treated_win, w = 1)], 0L)), "early", "none")
itt <- rd_from_aj(aj_cif(expand_followup(copy(p)[, `:=`(arm = assigned, w = 1)], 0L, h), h), "A", "B")
at <- rd_from_aj(aj_cif(expand_followup(copy(p)[, `:=`(arm = treated_win, w = 1)], 0L, h), h), "early", "none")
rbind(cbind(analysis = "itt", itt), cbind(analysis = "as_treated", at))[
, `:=`(outcome = o, design = paste0("rct_", design), n = nrow(ev),
, `:=`(outcome = o, horizon = h, design = paste0("rct_", design), n = nrow(ev),
crossover_B = mean(ev$treated_win[ev$assigned == "B"] == "early"),
nonadherence_A = mean(ev$treated_win[ev$assigned == "A"] == "none"))]
}))
}))))
}
#' ITT truth for a trial design: everyone in a large trial-eligible population assigned
#' A vs everyone assigned B, same protocol (refusal, scheduling, natural crossover).
#' Consent is random, so it does not change the trial population and is skipped here.
rct_truth <- function(par, design = "realistic", n = 1e6, seed = 20261029L, horizon = 60L) {
#' Patients are weighted by their probability of consenting, so the truth refers to the
#' population that enrols. Horizons: 60 months (estimand rct_<design>_itt) and the
#' shorter trial horizons (rct_<design>_itt_h12, _h24).
rct_truth <- function(par, design = "realistic", n = 1e6, seed = 20261029L, horizons = RCT_HORIZONS) {
pop <- truth_population(par, n = n, seed = seed)
pat <- if (design == "realistic") pop$pat[phys_id %in% trial_physicians(pop$phys)] else pop$pat
pc <- consent_prob(pat, RCT_DESIGNS[[design]])
set.seed(seed + 1L)
k <- nrow(pat)
trial <- list(pop = list(phys = pop$phys, pat = copy(pat)[, id := seq_len(.N)]),
arm = rep("A", k), refuse = runif(k) < 0.10, sched = sample(0:2, k, replace = TRUE))
runs <- lapply(c("A", "B"), function(a)
simulate_course(trial$pop, par, trial_policy(trial, assign = a), seed = seed + 2L, record = FALSE)$events)
rbindlist(lapply(names(OUTCOMES), function(o) {
d <- as.numeric(by_h(runs[[1]][[OUTCOMES[[o]]]], horizon)) - as.numeric(by_h(runs[[2]][[OUTCOMES[[o]]]], horizon))
w <- pc / sum(pc)
rbindlist(lapply(names(OUTCOMES), function(o) rbindlist(lapply(horizons, function(h) {
d <- as.numeric(by_h(runs[[1]][[OUTCOMES[[o]]]], h)) - as.numeric(by_h(runs[[2]][[OUTCOMES[[o]]]], h))
m <- sum(w * d)
data.table(world = par$world, scenario = par$scenario, outcome = o,
estimand = paste0("rct_", design, "_itt"), value = mean(d), mcse = sd(d) / sqrt(length(d)),
n = length(d))
}))
estimand = paste0("rct_", design, "_itt", if (h != 60L) paste0("_h", h)), value = m,
mcse = sqrt(sum(w^2 * (d - m)^2)), n = length(d))
}))))
}