92 lines
4.2 KiB
R
92 lines
4.2 KiB
R
# What the analyst sees: simulated Medicare claims (plan D17).
|
|
# Latent quantities (Z_t, true smoking, frailty, skill, style, progression rate) never
|
|
# leave this function except in `hidden`, which analysis code must not touch.
|
|
|
|
HIDDEN_COLS <- c("skill", "style", "frailty", "fi_noise", "smoking_true", "z0", "rate", "venous", "z")
|
|
|
|
#' Turn a population and its simulated course into claims-like records.
|
|
#'
|
|
#' @return list(patients = one row per patient: measured baseline and coded event times;
|
|
#' pm = person-months (id, t, sev_obs) from month 0 to death or month 59;
|
|
#' hidden = latent traits, for oracle analyses and checks only).
|
|
make_records <- function(pop, course, par) {
|
|
pat <- pop$pat; ev <- course$events; ms <- par$measurement
|
|
M <- par$size$months
|
|
smoking <- if (isTRUE(ms$smoking) || identical(ms$smoking, "true")) pat$smoking_true else pat$smoking_coded
|
|
rel <- ms$frailty_reliability
|
|
fi <- sqrt(rel) * pat$frailty + sqrt(1 - rel) * pat$fi_noise
|
|
|
|
patients <- data.table(id = pat$id, phys_id = pat$phys_id, obl = pat$obl, age = pat$age,
|
|
female = pat$female, black = pat$black, year = pat$year,
|
|
diabetes = pat$diabetes, ckd = pat$ckd, chf = pat$chf, copd = pat$copd,
|
|
prior_cvd = pat$prior_cvd, smoking = smoking, frailty_index = fi)
|
|
patients <- cbind(patients, ev[, !"id"])
|
|
# t_clti_true is latent: only the coded date is in claims
|
|
patients[, t_clti_true := NULL]
|
|
|
|
# observed severity: exact Z_t (clean worlds) or a claims proxy (world W5, WR)
|
|
last <- pmin(ifelse(is.na(ev$t_death), M - 1L, ev$t_death), M - 1L)
|
|
nrep <- last + 1L
|
|
id <- rep(pat$id, nrep)
|
|
t <- sequence(nrep) - 1L
|
|
idx <- cbind(id, t + 1L)
|
|
if (identical(ms$severity, "exact")) {
|
|
sev <- course$z[idx]
|
|
} else {
|
|
w <- ms$proxy_window
|
|
cs <- t(apply(course$counts, 1, function(x) { x[is.na(x)] <- 0L; cumsum(x) }))
|
|
lagged <- cbind(matrix(0, nrow(cs), w), cs)[, seq_len(M)]
|
|
sev <- log1p(cs[idx] - lagged[idx])
|
|
}
|
|
pm <- data.table(id = id, t = t, sev_obs = sev)
|
|
|
|
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)
|
|
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.
|
|
assert_no_hidden <- function(dt) {
|
|
bad <- intersect(names(dt), HIDDEN_COLS)
|
|
if (length(bad)) stop("latent columns in analysis data: ", paste(bad, collapse = ", "))
|
|
invisible(TRUE)
|
|
}
|
|
|
|
#' One replicate's records: population, natural course, claims view.
|
|
simulate_records <- function(par, rep = 1L, n = par$size$n_patients) {
|
|
seed <- replicate_seed(par$world, par$scenario, rep)
|
|
pop <- make_population(par, n = n, seed = seed)
|
|
course <- simulate_course(pop, par, policy("natural"), seed = seed + 104729L, record = TRUE)
|
|
make_records(pop, course, par)
|
|
}
|
|
|
|
#' Reproducible seed for a world x scenario x replicate.
|
|
replicate_seed <- function(world, scenario, rep) {
|
|
key <- paste(world, scenario, rep, sep = "|")
|
|
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
|
|
}
|