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

D53: landmark on baseline covariates (month-5 version as landmark_m5), NCO-1 depends on PVI-free severity, physician-cluster bootstrap script

Browse Source 
Co-Authored-By: Claude Opus 5.5 <[email protected]>
This commit is contained in:
chendun1995
2026-10-28 07:20:32 -04:00
co-authored by Claude Opus 5.5
parent fbc417662c
commit 5304c89316
10 changed files with 86 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files
pvisim/R/estimators.R
+9 -4
View File
@@ -197,6 +197,9 @@ run_designs <- function(rec, designs, variant, outcomes = c(male = "t_male", dis
cbind(contrast = "early_none", est_naive(rec, outcomes[[o]], variant), outcome = o))),
landmark = rbindlist(lapply(names(outcomes), function(o)
cbind(contrast = "early_none", est_landmark(rec, outcomes[[o]], variant, extra_covs = rec$extra_covs), outcome = o))),
landmark_m5 = rbindlist(lapply(names(outcomes), function(o)
cbind(contrast = "early_none", est_landmark(rec, outcomes[[o]], variant, extra_covs = rec$extra_covs,
at_landmark = TRUE), outcome = o))),
ccw = est_ccw(rec, outcomes, variant, rs = copy(rs), phat = phat, comparators = cmp),
seq = cbind(contrast = "now_not", est_seq(rec, outcomes, variant, rs = copy(rs), phat = phat)))
r[, `:=`(design = design, variant = variant, n = nrow(rec$patients))]
@@ -239,9 +242,11 @@ 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, extra_covs = NULL) {
#' exposure = PVI in months 0..W-1; covariates at diagnosis; outcome counted in months
#' W..horizon-1. With at_landmark = TRUE the propensity score also uses severity at month
#' W-1, which a PVI has already changed (supplement, D53).
est_landmark <- function(rec, outcome = "t_male", variant = "V1_ignore", horizon = 60L, extra_covs = NULL,
at_landmark = FALSE) {
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"))]
@@ -249,7 +254,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, covs = c(BASE_COVS, "sev_obs", "sev0", extra_covs))
ps <- fit_pvi_ps(p, variant, covs = c(BASE_COVS, "sev0", if (at_landmark) "sev_obs", 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")
pvisim/R/limits.R
+3 -2
View File
@@ -17,13 +17,14 @@ oracle_records <- function(rec) {
o
}
#' Oracle versions of the landmark and naive designs (V1, patient-level SE).
#' Oracle versions of the landmark (both versions) 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)
l5 <- est_landmark(o, outcomes[[nm]], "V1_ignore", extra_covs = o$extra_covs, at_landmark = TRUE)
nv <- est_naive(o, outcomes[[nm]], "V1_ignore", extra_covs = o$extra_covs)
rbind(cbind(design = "landmark", lm), cbind(design = "naive", nv))[
rbind(cbind(design = "landmark", lm), cbind(design = "landmark_m5", l5), cbind(design = "naive", nv))[
, `:=`(outcome = nm, contrast = "early_none", variant = "oracle", se = se_patient)]
}))
}
pvisim/R/records.R
+21
View File
@@ -68,3 +68,24 @@ replicate_seed <- function(world, scenario, rep) {
h <- sum(utf8ToInt(key) * seq_along(utf8ToInt(key))^2)
as.integer((h * 2654435761) %% 2147483647)
}
#' Physician-cluster bootstrap resample of a replicate's records (D28): physicians are
#' drawn with replacement and each draw brings all of its patients, with new patient and
#' physician ids so repeated physicians count as separate clusters.
bootstrap_records <- function(rec, seed) {
set.seed(seed)
phys <- unique(rec$patients$phys_id)
draw <- data.table(phys_id = sample(phys, length(phys), replace = TRUE), new_phys = seq_along(phys))
map <- rec$patients[, .(id, phys_id)][draw, on = "phys_id", allow.cartesian = TRUE]
map[, new_id := seq_len(.N)]
remap <- function(x) {
x <- x[map[, .(id, new_id)], on = "id", allow.cartesian = TRUE]
x[, id := new_id][, new_id := NULL][]
}
out <- rec
out$patients <- remap(rec$patients)[map[, .(new_id, new_phys)], on = c(id = "new_id"), phys_id := i.new_phys]
out$pm <- setkey(remap(rec$pm), id, t)
out$hidden <- remap(rec$hidden)
out$hidden_pm <- remap(rec$hidden_pm)
out
}
pvisim/R/simulate.R
+8 -3
View File
@@ -127,12 +127,14 @@ simulate_course <- function(pop, par, pol = policy("natural"), seed = 1L, record
lp_rr0 <- rr$intercept + rr$skill * pat$skill + rr$style * pat$style
lp_nco1 <- nc$nco1$intercept + nc$nco1$frailty * pat$frailty + nc$nco1$smoking * pat$smoking_true +
nc$nco1$age10 * a10
nco1_z <- if (is.null(nc$nco1$z)) 0 else nc$nco1$z
lp_nco2 <- nc$nco2$intercept + nc$nco2$style * pat$style + nc$nco2$venous * pat$venous
lp_nce <- nc$nce$intercept + nc$nce$style * pat$style + nc$nce$frailty * pat$frailty
kappa_post <- ef$kappa * exp(-ef$skill_kappa * pat$skill)
# state
Z <- pat$z0
Zn <- pat$z0 # severity on the natural course without any PVI (relief or kappa): drives NCO-1 (D53)
alive <- rep(TRUE, N); treated <- rep(FALSE, N); clti_true <- rep(FALSE, N)
clti_code <- rep(FALSE, N); male <- rep(FALSE, N)
t_pvi <- t_clti_true <- t_clti_code <- t_amp <- t_bypass <- t_rr <- t_male <- t_death <-
@@ -147,8 +149,11 @@ simulate_course <- function(pop, par, pol = policy("natural"), seed = 1L, record
for (t in 0:(M - 1)) {
U <- matrix(runif(N * ns), N, ns, dimnames = list(NULL, STREAMS))
a <- alive
if (t > 0) Z[a] <- Z[a] + pat$rate[a] + kappa_post[a] * treated[a] +
par$severity$eps_sd * qnorm(U[a, "eps"])
if (t > 0) {
eps <- par$severity$eps_sd * qnorm(U[a, "eps"])
Z[a] <- Z[a] + pat$rate[a] + kappa_post[a] * treated[a] + eps
Zn[a] <- Zn[a] + pat$rate[a] + eps
}
if (record) {
zmat[a, t + 1] <- Z[a]
cmat[a, t + 1] <- qpois(U[a, "proxy"], exp(par$measurement$proxy_intercept + par$measurement$proxy_z * Z[a]))
@@ -183,7 +188,7 @@ simulate_course <- function(pop, par, pol = policy("natural"), seed = 1L, record
}
# negative controls (never depend on PVI)
x <- a & is.na(t_nco1) & U[, "nco1"] < plogis(lp_nco1); t_nco1[x] <- t
x <- a & is.na(t_nco1) & U[, "nco1"] < plogis(lp_nco1 + nco1_z * Zn); t_nco1[x] <- t
x <- a & is.na(t_nco2) & U[, "nco2"] < plogis(lp_nco2); t_nco2[x] <- t
if (t < W) { x <- a & is.na(t_nce) & U[, "nce"] < plogis(lp_nce); t_nce[x] <- t }