# Supplementary R code for the core analytical procedures
#
# This supplementary script contains the core R code for all major
# analyses reported in the manuscript, including phase-specific multiple
# imputation, candidate model development, temporal validation,
# recalibration, annual performance monitoring, time-aware random forest
# updating, paired DeLong comparisons, bootstrap uncertainty estimation,
# and decision curve analysis.
#
# This file is not intended to represent the complete end-to-end
# production pipeline. Institution-specific source-data cleaning,
# data harmonization and verification, local file management,
# intermediate diagnostic outputs, and nonessential figure-formatting
# procedures are not included.
#
# The complete four-center participant-level dataset is not distributed
# with this script because of institutional data-sharing restrictions and
# participant privacy considerations. Data availability is described in
# the manuscript. To run the code, users should provide an approved
# analytic dataset with the harmonized variable names specified below.
#
# Reproducibility configuration ----------------------------------------

# By default, the current working directory is used as the project
# directory. Alternatively, set the IVIGR_PROJECT_DIR environment
# variable before running this script.
project_dir <- Sys.getenv("IVIGR_PROJECT_DIR", unset = getwd())
project_dir <- normalizePath(
  project_dir,
  winslash = "/",
  mustWork = TRUE
)

# The analytic dataset is not included with this code. Users may either
# place an approved dataset at data/alldata.csv or set the
# IVIGR_DATA_FILE environment variable to its location.
data_file <- Sys.getenv(
  "IVIGR_DATA_FILE",
  unset = file.path(project_dir, "data", "alldata.csv")
)

if (!file.exists(data_file)) {
  stop(
    paste0(
      "Analytic data file not found: ", data_file, "\n",
      "Set IVIGR_DATA_FILE to the path of an approved harmonized dataset."
    )
  )
}

alldata <- read.csv(
  data_file,
  stringsAsFactors = FALSE,
  check.names = FALSE
)

required_columns <- c(
  "Gender", "Age_months", "Center", "Time", "Year", "Admission_Date",
  "IVIGR", "CALs",
  "Cervical_Lymphadenopathy", "Conjunctival_Injection",
  "Edema_of_the_Hands_and_Feet", "Oral_Mucosal_Change", "Rash",
  "WBC", "Neu_percent", "Hb", "PLT", "CRP", "ALB", "ALT", "AST"
)

missing_columns <- setdiff(required_columns, names(alldata))

if (length(missing_columns) > 0) {
  stop(
    paste(
      "The analytic dataset is missing required columns:",
      paste(missing_columns, collapse = ", ")
    )
  )
}


#####  Multiple imputation within calendar phases #####
library(mice)

run_mi_one_period <- function(dat, m=10, maxit=20, seed=123){
  
  vars_pred <- c("WBC","Neu_percent","Hb","PLT","AST","ALT","ALB","CRP",
                 "Cervical_Lymphadenopathy","Rash","Oral_Mucosal_Change",
                 "Edema_of_the_Hands_and_Feet","Conjunctival_Injection")
  
  imp_vars <- c("Gender","Age_months","Center","Time","IVIGR","CALs", vars_pred)
  impdat <- dat[, imp_vars]
  
  centers4 <- c("FJSL","FZFY","Suzhou","Yangzhou")
  times3   <- c("Before_COVID","During_COVID","After_COVID")
  
  # Use fixed levels for categorical variables across calendar phases.
  impdat$Gender <- factor(impdat$Gender, levels = c(1, 2))
  impdat$Center <- factor(impdat$Center, levels = centers4)
  impdat$Time   <- factor(impdat$Time,   levels = times3)
  
  # Use fixed 0/1 factor levels for binary variables.
  bin_vars <- c("Cervical_Lymphadenopathy","Rash","Oral_Mucosal_Change",
                "Edema_of_the_Hands_and_Feet","Conjunctival_Injection",
                "IVIGR","CALs")
  
  for(v in bin_vars){
    if(v %in% names(impdat)) impdat[[v]] <- factor(impdat[[v]], levels = c(0, 1))
  }
  
  # methods
  meth <- make.method(impdat)
  meth[] <- ""
  
  # Fully observed design and outcome variables are not imputed.
  meth["Gender"]     <- ""
  meth["Age_months"] <- ""
  meth["Center"]     <- ""
  meth["Time"]       <- ""
  meth["IVIGR"]      <- ""
  meth["CALs"]       <- ""
  
  cont <- c("WBC","Neu_percent","Hb","PLT","AST","ALT","ALB","CRP")
  cont <- intersect(cont, names(impdat))
  meth[cont] <- "pmm"
  
  bin <- c("Cervical_Lymphadenopathy","Rash",
           "Oral_Mucosal_Change","Edema_of_the_Hands_and_Feet","Conjunctival_Injection")
  bin <- intersect(bin, names(impdat))
  meth[bin] <- "logreg"
  
  # predictorMatrix
  pred <- make.predictorMatrix(impdat)
  pred[,] <- 1
  diag(pred) <- 0
  
  set.seed(seed)
  mice(impdat, m=m, maxit=maxit, method=meth, predictorMatrix=pred, printFlag=TRUE)
}

dat_bef <- subset(alldata, Time=="Before_COVID")
dat_dur <- subset(alldata, Time=="During_COVID")
dat_aft <- subset(alldata, Time=="After_COVID")

imp_bef <- run_mi_one_period(dat_bef, m=10, maxit=20, seed=123)
imp_dur <- run_mi_one_period(dat_dur, m=10, maxit=20, seed=123)
imp_aft <- run_mi_one_period(dat_aft, m=10, maxit=20, seed=123)

saveRDS(list(bef=imp_bef, dur=imp_dur, aft=imp_aft),
        file=file.path(project_dir, "imp_byTime_m10.rds"))

#####  Model development, validation, and recalibration #####
## 0) Reproducibility settings

GLOBAL_SEED <- 123

try(
  RNGkind(kind = "Mersenne-Twister",
          normal.kind = "Inversion",
          sample.kind = "Rejection"),
  silent = TRUE
)

set.seed(GLOBAL_SEED)

Sys.setenv(
  OMP_NUM_THREADS = "1",
  MKL_NUM_THREADS = "1",
  OPENBLAS_NUM_THREADS = "1",
  VECLIB_MAXIMUM_THREADS = "1"
)

required_pkgs <- c(
  "mice", "pROC", "glmnet", "caret",
  "randomForest", "kernlab", "doParallel", "foreach"
)

missing_pkgs <- required_pkgs[!sapply(required_pkgs, requireNamespace, quietly = TRUE)]

if(length(missing_pkgs) > 0){
  stop(
    "Please install missing packages first: ",
    paste(missing_pkgs, collapse = ", ")
  )
}

suppressPackageStartupMessages({
  library(mice)
  library(pROC)
  library(glmnet)
  library(caret)
  library(randomForest)
  library(kernlab)
  library(doParallel)
  library(foreach)
})

cat("\nReproducible MI model + recalibration analysis started\n")
cat("GLOBAL_SEED =", GLOBAL_SEED, "\n")

n_cores <- suppressWarnings(as.integer(Sys.getenv(
  "IVIGR_N_CORES",
  unset = as.character(max(1L, parallel::detectCores() - 2L))
)))
if(!is.finite(n_cores) || n_cores < 1L) n_cores <- 1L
cl <- parallel::makeCluster(n_cores)
doParallel::registerDoParallel(cl)
parallel_backend_created <- TRUE

cat("Parallel backend registered with", n_cores, "cores.\n")
cat("BLAS/OpenMP threads are kept at 1 to avoid over-subscription.\n")

## 1) Paths and data

base_dir <- project_dir
out_dir  <- file.path(base_dir, "reviewer_recalibration_outputs")

dir.create(out_dir, recursive = TRUE, showWarnings = FALSE)

imp_path <- file.path(project_dir, "imp_byTime_m10.rds")

cat("\nInput imputation object:\n")
cat(imp_path, "\n")
cat("\nInput outcome coding is assumed to have been validated before multiple imputation.\n")

imp <- readRDS(file.path(project_dir, "imp_byTime_m10.rds"))

imp_bef <- imp$bef
imp_dur <- imp$dur
imp_aft <- imp$aft

outcome <- "IVIGR"

bin_cols <- c(
  "Cervical_Lymphadenopathy",
  "Rash",
  "Oral_Mucosal_Change",
  "Edema_of_the_Hands_and_Feet",
  "Conjunctival_Injection"
)

cont_cols <- c(
  "Age_months", "WBC", "Neu_percent", "Hb", "PLT",
  "AST", "ALT", "ALB", "CRP"
)

xvars_base <- c("Center", "Gender", cont_cols, bin_cols)
models <- c("logistic", "lasso", "elnet", "rf", "svm")
grid_fpr <- seq(0, 1, by = 0.01)
B_boot <- 500

cat("\nOutcome:", outcome, "\n")
cat("Bootstrap resamples:", B_boot, "\n")
cat("Predictors:\n")
print(xvars_base)

## 2) Helper functions

as01_2to0 <- function(x){
  if(is.factor(x)) x <- as.character(x)
  x <- trimws(as.character(x))
  x_num <- suppressWarnings(as.integer(x))
  out <- rep(NA_integer_, length(x_num))
  out[x_num %in% c(0L, 2L)] <- 0L
  out[x_num == 1L] <- 1L
  out
}

drop_nzv <- function(train_df, xvars){
  keep <- sapply(xvars, function(v){
    if(!v %in% names(train_df)) return(FALSE)
    ux <- unique(train_df[[v]][!is.na(train_df[[v]])])
    length(ux) >= 2
  })
  xvars[keep]
}

eps <- 1e-6

clamp01 <- function(p){
  pmin(pmax(p, eps), 1 - eps)
}

metric_names_all <- c(
  "AUC", "Brier", "Cal_Int", "Cal_Slope", "OE",
  "Sens", "Spec", "PPV", "NPV", "F1", "Acc", "Threshold"
)

empty_metrics <- function(thr = NA_real_){
  out <- rep(NA_real_, length(metric_names_all))
  names(out) <- metric_names_all
  out["Threshold"] <- thr
  out
}

get_metrics <- function(y, p, thr){
  y <- as.integer(y == 1L)
  p <- as.numeric(p)
  ok <- !is.na(y) & !is.na(p)
  y <- y[ok]
  p <- clamp01(p[ok])
  if(length(y) == 0 || length(unique(y)) < 2){
    return(empty_metrics(thr))
  }
  aucv <- tryCatch(
    as.numeric(pROC::auc(pROC::roc(y, p, quiet = TRUE, direction = "<"))),
    error = function(e) NA_real_
  )
  brier <- mean((p - y)^2, na.rm = TRUE)
  lp <- qlogis(p)
  cal_fit <- tryCatch(
    suppressWarnings(glm(y ~ lp, family = binomial())),
    error = function(e) NULL
  )
  if(is.null(cal_fit)){
    cal_int <- NA_real_
    cal_slope <- NA_real_
  } else {
    co <- coef(cal_fit)
    cal_int <- unname(co[1])
    cal_slope <- unname(co[2])
  }
  O <- sum(y, na.rm = TRUE)
  E <- sum(p, na.rm = TRUE)
  OE <- ifelse(E > 0, O / E, NA_real_)
  pred <- as.integer(p >= thr)
  TP <- sum(pred == 1 & y == 1, na.rm = TRUE)
  TN <- sum(pred == 0 & y == 0, na.rm = TRUE)
  FP <- sum(pred == 1 & y == 0, na.rm = TRUE)
  FN <- sum(pred == 0 & y == 1, na.rm = TRUE)
  sens <- ifelse((TP + FN) > 0, TP / (TP + FN), NA_real_)
  spec <- ifelse((TN + FP) > 0, TN / (TN + FP), NA_real_)
  ppv  <- ifelse((TP + FP) > 0, TP / (TP + FP), NA_real_)
  npv  <- ifelse((TN + FN) > 0, TN / (TN + FN), NA_real_)
  acc  <- ifelse((TP + TN + FP + FN) > 0,
                 (TP + TN) / (TP + TN + FP + FN),
                 NA_real_)
  f1 <- if(!is.na(ppv) && !is.na(sens) && (ppv + sens) > 0){
    2 * ppv * sens / (ppv + sens)
  } else {
    NA_real_
  }
  c(
    AUC = aucv,
    Brier = brier,
    Cal_Int = cal_int,
    Cal_Slope = cal_slope,
    OE = OE,
    Sens = sens,
    Spec = spec,
    PPV = ppv,
    NPV = npv,
    F1 = f1,
    Acc = acc,
    Threshold = thr
  )
}

recal_int_fit <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  lp <- qlogis(p)
  fit <- suppressWarnings(glm(y ~ 1 + offset(lp), family = binomial()))
  a <- unname(coef(fit)[1])
  list(alpha = a, p_new = plogis(a + lp))
}

recal_intslope_fit <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  lp <- qlogis(p)
  fit <- suppressWarnings(glm(y ~ lp, family = binomial()))
  co <- coef(fit)
  a <- unname(co[1])
  b <- unname(co[2])
  list(alpha = a, beta = b, p_new = plogis(a + b * lp))
}

summarize_res_list <- function(res_list){
  res2 <- res_list[!sapply(res_list, is.null)]
  if(length(res2) == 0){
    stop("No valid results. Likely too strict filtering or too small sample.")
  }
  arr <- simplify2array(res2)
  mean_mat <- apply(arr, c(1, 2), mean, na.rm = TRUE)
  sd_mat   <- apply(arr, c(1, 2), sd,   na.rm = TRUE)
  list(mean = mean_mat, sd = sd_mat, m_used = length(res2))
}

fmt_tbl <- function(mean_mat, sd_mat){
  fmt <- function(m, s) sprintf("%.4f (%.4f)", m, s)
  out <- matrix(
    "",
    nrow = nrow(mean_mat),
    ncol = ncol(mean_mat),
    dimnames = dimnames(mean_mat)
  )
  for(rn in rownames(mean_mat)){
    for(cn in colnames(mean_mat)){
      out[rn, cn] <- fmt(mean_mat[rn, cn], sd_mat[rn, cn])
    }
  }
  out
}

mm_align_to_train <- function(formX, train_df, new_df){
  mm_tr  <- model.matrix(formX, data = train_df)[, -1, drop = FALSE]
  mm_new <- model.matrix(formX, data = new_df)[, -1, drop = FALSE]
  miss <- setdiff(colnames(mm_tr), colnames(mm_new))
  if(length(miss) > 0){
    add <- matrix(0, nrow = nrow(mm_new), ncol = length(miss))
    colnames(add) <- miss
    mm_new <- cbind(mm_new, add)
  }
  mm_new <- mm_new[, colnames(mm_tr), drop = FALSE]
  list(mm_tr = mm_tr, mm_new = mm_new)
}

pool_glm_or <- function(fit_list){
  fit_list <- fit_list[!sapply(fit_list, is.null)]
  if(length(fit_list) < 2){
    stop("Too few glm fits to pool.")
  }
  terms <- Reduce(intersect, lapply(fit_list, function(f) names(coef(f))))
  betas <- sapply(fit_list, function(f) coef(f)[terms])
  ses2 <- sapply(fit_list, function(f){
    vc <- vcov(f)
    diag(vc)[terms]
  })
  m <- ncol(betas)
  qbar <- rowMeans(betas)
  ubar <- rowMeans(ses2)
  b <- apply(betas, 1, var)
  tvar <- ubar + (1 + 1 / m) * b
  se <- sqrt(tvar)
  df <- (m - 1) * (1 + ubar / ((1 + 1 / m) * b))^2
  df[!is.finite(df)] <- m - 1
  lo <- qbar + qt(0.025, df = df) * se
  hi <- qbar + qt(0.975, df = df) * se
  stat <- qbar / se
  pval <- 2 * pt(-abs(stat), df = df)
  data.frame(
    term = terms,
    beta = qbar,
    se = se,
    df = df,
    stat = stat,
    p = pval,
    OR = exp(qbar),
    OR_L = exp(lo),
    OR_U = exp(hi),
    row.names = NULL
  )
}

roc_interp <- function(y, p, grid_fpr){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  r <- pROC::roc(y, p, quiet = TRUE, direction = "<")
  fpr <- 1 - r$specificities
  tpr <- r$sensitivities
  ord <- order(fpr)
  fpr <- fpr[ord]
  tpr <- tpr[ord]
  approx(x = fpr, y = tpr, xout = grid_fpr, ties = "ordered", rule = 2)$y
}

make_caret_seeds <- function(n_resamples = 10, tune_max, seed = 1){
  set.seed(seed)
  seeds <- vector("list", n_resamples + 1)
  for(j in seq_len(n_resamples)){
    seeds[[j]] <- sample.int(10000000, tune_max)
  }
  seeds[[n_resamples + 1]] <- sample.int(10000000, 1)
  seeds
}

make_fit_control <- function(seed, tune_max){
  caret::trainControl(
    method = "cv",
    number = 10,
    classProbs = TRUE,
    summaryFunction = caret::twoClassSummary,
    savePredictions = "final",
    allowParallel = TRUE,
    seeds = make_caret_seeds(n_resamples = 10, tune_max = tune_max, seed = seed)
  )
}

boot_metrics <- function(y, p, thr, B = 500, seed = 123){
  set.seed(seed)
  y <- as.integer(y == 1L)
  p <- clamp01(as.numeric(p))
  ok <- !is.na(y) & !is.na(p)
  y <- y[ok]
  p <- p[ok]
  n <- length(y)
  boot_mat <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(metric_names_all),
    dimnames = list(NULL, metric_names_all)
  )
  if(n == 0){
    return(as.data.frame(boot_mat))
  }
  for(b in seq_len(B)){
    idx <- sample(seq_len(n), size = n, replace = TRUE)
    y_b <- y[idx]
    p_b <- p[idx]
    if(length(unique(y_b)) < 2){
      boot_mat[b, ] <- empty_metrics(thr)
    } else {
      boot_mat[b, ] <- tryCatch(
        get_metrics(y_b, p_b, thr),
        error = function(e) empty_metrics(thr)
      )
    }
  }
  out <- as.data.frame(boot_mat)
  out$Bootstrap <- seq_len(B)
  out
}

add_boot_meta <- function(df, model, period, strategy, imputation){
  df$Model <- model
  df$Period <- period
  df$Strategy <- strategy
  df$Imputation <- imputation
  df
}

res_list_to_df <- function(res_list, strategy){
  out_list <- list()
  for(i in seq_along(res_list)){
    if(is.null(res_list[[i]])) next
    mat <- res_list[[i]]
    df <- as.data.frame(mat)
    df$Row <- rownames(mat)
    split_row <- strsplit(df$Row, "_")
    df$Period <- sapply(split_row, function(z) z[1])
    df$Model  <- sapply(split_row, function(z) paste(z[-1], collapse = "_"))
    df$Strategy <- strategy
    df$Imputation <- i
    rownames(df) <- NULL
    out_list[[length(out_list) + 1]] <- df
  }
  do.call(rbind, out_list)
}

time_sep_res_to_df <- function(time_sep_res){
  out_list <- list()
  for(i in seq_along(time_sep_res)){
    if(is.null(time_sep_res[[i]])) next
    for(mod in names(time_sep_res[[i]])){
      mat <- time_sep_res[[i]][[mod]]
      df <- as.data.frame(mat)
      df$Strategy <- rownames(mat)
      df$Model <- mod
      df$Period <- "aft"
      df$Imputation <- i
      rownames(df) <- NULL
      out_list[[length(out_list) + 1]] <- df
    }
  }
  do.call(rbind, out_list)
}

make_summary_table <- function(point_df, boot_df,
                               group_cols,
                               metrics_show = c("AUC", "Brier", "Cal_Int", "Cal_Slope", "OE")){
  groups <- unique(point_df[, group_cols, drop = FALSE])
  out_list <- list()
  for(g in seq_len(nrow(groups))){
    group_now <- groups[g, , drop = FALSE]
    idx_point <- rep(TRUE, nrow(point_df))
    idx_boot <- rep(TRUE, nrow(boot_df))
    for(gc in group_cols){
      idx_point <- idx_point & point_df[[gc]] == group_now[[gc]][1]
      idx_boot  <- idx_boot  & boot_df[[gc]]  == group_now[[gc]][1]
    }
    for(metric in metrics_show){
      est <- mean(point_df[[metric]][idx_point], na.rm = TRUE)
      vals <- boot_df[[metric]][idx_boot]
      ci_l <- as.numeric(quantile(vals, 0.025, na.rm = TRUE))
      ci_u <- as.numeric(quantile(vals, 0.975, na.rm = TRUE))
      tmp <- data.frame(
        group_now,
        Metric = metric,
        Estimate = est,
        CI_L = ci_l,
        CI_U = ci_u,
        Formatted = sprintf("%.4f (%.4f to %.4f)", est, ci_l, ci_u),
        stringsAsFactors = FALSE
      )
      out_list[[length(out_list) + 1]] <- tmp
    }
  }
  do.call(rbind, out_list)
}

avg_roc_mat <- function(roc_list, models, grid_fpr){
  mats <- roc_list[!sapply(roc_list, is.null)]
  if(length(mats) == 0){
    stop("No ROC data to plot.")
  }
  out <- matrix(
    NA_real_,
    nrow = length(models),
    ncol = length(grid_fpr),
    dimnames = list(models, NULL)
  )
  for(m in models){
    tmp <- do.call(rbind, lapply(mats, function(mm){
      if(is.null(mm)) return(rep(NA_real_, length(grid_fpr)))
      if(!m %in% rownames(mm)) return(rep(NA_real_, length(grid_fpr)))
      as.numeric(mm[m, ])
    }))
    out[m, ] <- colMeans(tmp, na.rm = TRUE)
  }
  out
}

plot_mean_roc_color <- function(grid_fpr, roc_mean, auc_mean, main_title){
  models_plot <- rownames(roc_mean)
  cols <- rainbow(length(models_plot))
  plot(
    0, 0,
    type = "n",
    xlim = c(0, 1),
    ylim = c(0, 1),
    xlab = "1 - Specificity",
    ylab = "Sensitivity",
    main = main_title
  )
  abline(0, 1, lty = 2)
  for(j in seq_along(models_plot)){
    m <- models_plot[j]
    lines(grid_fpr, roc_mean[m, ], col = cols[j], lwd = 2)
  }
  leg <- sprintf("%s (AUC=%.3f)", models_plot, auc_mean[models_plot])
  legend(
    "bottomright",
    legend = leg,
    col = cols,
    lwd = 3,
    bty = "n",
    cex = 1,
    y.intersp = 0.9,
    x.intersp = 0.6,
    seg.len = 2.5
  )
}

## 3) Prepare objects

m_use <- min(imp_bef$m, imp_dur$m, imp_aft$m)

cat("\nNumber of imputations used:", m_use, "\n")

res_raw <- vector("list", m_use)
res_int <- vector("list", m_use)
res_is  <- vector("list", m_use)
ab_int <- vector("list", m_use)
ab_is  <- vector("list", m_use)
best_rf  <- vector("list", m_use)
best_svm <- vector("list", m_use)
glm_fits <- vector("list", m_use)
roc_raw_dur <- vector("list", m_use)
roc_raw_aft <- vector("list", m_use)
pred_raw_dur <- vector("list", m_use)
pred_raw_aft <- vector("list", m_use)
pred_int_dur <- vector("list", m_use)
pred_int_aft <- vector("list", m_use)
pred_is_dur <- vector("list", m_use)
pred_is_aft <- vector("list", m_use)
lasso_cv <- vector("list", m_use)
elnet_cv <- vector("list", m_use)
lasso_spec <- vector("list", m_use)
elnet_spec <- vector("list", m_use)
train_spec <- vector("list", m_use)
time_sep_res  <- vector("list", m_use)
time_sep_boot <- vector("list", m_use)
time_sep_ab   <- vector("list", m_use)
phase_boot <- vector("list", m_use)

centers4 <- sort(unique(c(
  as.character(imp_bef$data$Center),
  as.character(imp_dur$data$Center),
  as.character(imp_aft$data$Center)
)))

cat("\nCenters detected from imputation objects:\n")
print(centers4)

preSteps_svm <- c("center", "scale")

## 4) Main loop across imputations

for(i in seq_len(m_use)){
  cat("\nRunning imputation", i, "of", m_use, "\n")
  set.seed(GLOBAL_SEED + 1000 + i)
  train <- mice::complete(imp_bef, i)
  dur   <- mice::complete(imp_dur, i)
  aft   <- mice::complete(imp_aft, i)
  train$Center <- factor(train$Center, levels = centers4)
  dur$Center   <- factor(dur$Center,   levels = centers4)
  aft$Center   <- factor(aft$Center,   levels = centers4)
  train$Gender <- factor(train$Gender)
  dur$Gender   <- factor(dur$Gender, levels = levels(train$Gender))
  aft$Gender   <- factor(aft$Gender, levels = levels(train$Gender))
  for(v in bin_cols){
    if(v %in% names(train)) train[[v]] <- as01_2to0(train[[v]])
    if(v %in% names(dur))   dur[[v]]   <- as01_2to0(dur[[v]])
    if(v %in% names(aft))   aft[[v]]   <- as01_2to0(aft[[v]])
  }
  train[[outcome]] <- as01_2to0(train[[outcome]])
  dur[[outcome]]   <- as01_2to0(dur[[outcome]])
  aft[[outcome]]   <- as01_2to0(aft[[outcome]])
  xvars <- drop_nzv(train, xvars_base)
  if(length(xvars) < 2){
    cat("[SKIP] Too few usable predictors in imputation", i, "\n")
    next
  }
  keep_tr <- complete.cases(train[, xvars, drop = FALSE]) & !is.na(train[[outcome]])
  keep_du <- complete.cases(dur[,   xvars, drop = FALSE]) & !is.na(dur[[outcome]])
  keep_af <- complete.cases(aft[,   xvars, drop = FALSE]) & !is.na(aft[[outcome]])
  train <- train[keep_tr, , drop = FALSE]
  dur   <- dur[keep_du,   , drop = FALSE]
  aft   <- aft[keep_af,   , drop = FALSE]
  if(nrow(train) < 80 || nrow(dur) < 40 || nrow(aft) < 40){
    cat("[SKIP] Too small sample after filtering in imputation", i, "\n")
    next
  }
  if(length(unique(train[[outcome]])) < 2 ||
     length(unique(dur[[outcome]]))   < 2 ||
     length(unique(aft[[outcome]]))   < 2){
    cat("[SKIP] Outcome has only one class in imputation", i, "\n")
    next
  }
  thr_i <- mean(train[[outcome]] == 1, na.rm = TRUE)
  thr_i <- pmin(pmax(thr_i, 0.01), 0.99)
  cat("n train =", nrow(train),
      "; n during =", nrow(dur),
      "; n after =", nrow(aft),
      "; train event rate =", round(thr_i, 4), "\n")
  formX <- as.formula(paste("~", paste(xvars, collapse = "+")))
  mm_dur_obj <- mm_align_to_train(formX, train, dur)
  mm_aft_obj <- mm_align_to_train(formX, train, aft)
  mm_tr <- mm_dur_obj$mm_tr
  mm_du <- mm_dur_obj$mm_new
  mm_af <- mm_aft_obj$mm_new
  y_tr <- train[[outcome]]
  y_du <- dur[[outcome]]
  y_af <- aft[[outcome]]
  set.seed(GLOBAL_SEED + 2000 + i)
  foldid <- sample(rep(1:10, length.out = nrow(mm_tr)))
  train_spec[[i]] <- list(
    outcome = outcome,
    xvars = xvars,
    formX = formX,
    centers4 = centers4,
    gender_levels = levels(train$Gender),
    bin_cols = bin_cols,
    cont_cols = cont_cols,
    mm_cols = colnames(mm_tr),
    thr_train_prev = thr_i,
    n_train = nrow(train),
    n_dur = nrow(dur),
    n_aft = nrow(aft),
    event_train = sum(y_tr == 1),
    event_dur = sum(y_du == 1),
    event_aft = sum(y_af == 1)
  )
  fit_glm <- suppressWarnings(glm(
    as.formula(paste(outcome, "~", paste(xvars, collapse = "+"))),
    data = train[, c(outcome, xvars), drop = FALSE],
    family = binomial()
  ))
  glm_fits[[i]] <- fit_glm
  p_du_glm <- predict(fit_glm, newdata = dur[, xvars, drop = FALSE], type = "response")
  p_af_glm <- predict(fit_glm, newdata = aft[, xvars, drop = FALSE], type = "response")
  set.seed(GLOBAL_SEED + 3000 + i)
  cv_las <- glmnet::cv.glmnet(
    x = mm_tr,
    y = y_tr,
    family = "binomial",
    alpha = 1,
    nfolds = 10,
    foldid = foldid,
    type.measure = "auc",
    standardize = TRUE
  )
  set.seed(GLOBAL_SEED + 4000 + i)
  cv_en <- glmnet::cv.glmnet(
    x = mm_tr,
    y = y_tr,
    family = "binomial",
    alpha = 0.5,
    nfolds = 10,
    foldid = foldid,
    type.measure = "auc",
    standardize = TRUE
  )
  lasso_cv[[i]] <- cv_las
  elnet_cv[[i]] <- cv_en
  lasso_spec[[i]] <- list(
    alpha = 1,
    lambda_min = cv_las$lambda.min,
    lambda_1se = cv_las$lambda.1se,
    coef_min = as.matrix(coef(cv_las, s = "lambda.min")),
    coef_1se = as.matrix(coef(cv_las, s = "lambda.1se")),
    mm_cols = colnames(mm_tr),
    xvars = xvars
  )
  elnet_spec[[i]] <- list(
    alpha = 0.5,
    lambda_min = cv_en$lambda.min,
    lambda_1se = cv_en$lambda.1se,
    coef_min = as.matrix(coef(cv_en, s = "lambda.min")),
    coef_1se = as.matrix(coef(cv_en, s = "lambda.1se")),
    mm_cols = colnames(mm_tr),
    xvars = xvars
  )
  p_du_las <- as.numeric(predict(cv_las, newx = mm_du, s = "lambda.min", type = "response"))
  p_af_las <- as.numeric(predict(cv_las, newx = mm_af, s = "lambda.min", type = "response"))
  p_du_en <- as.numeric(predict(cv_en, newx = mm_du, s = "lambda.min", type = "response"))
  p_af_en <- as.numeric(predict(cv_en, newx = mm_af, s = "lambda.min", type = "response"))
  train_c <- train[, c(outcome, xvars), drop = FALSE]
  dur_c   <- dur[,   c(outcome, xvars), drop = FALSE]
  aft_c   <- aft[,   c(outcome, xvars), drop = FALSE]
  train_c[[outcome]] <- factor(ifelse(train_c[[outcome]] == 1, "Yes", "No"), levels = c("Yes", "No"))
  dur_c[[outcome]] <- factor(ifelse(dur_c[[outcome]] == 1, "Yes", "No"), levels = c("Yes", "No"))
  aft_c[[outcome]] <- factor(ifelse(aft_c[[outcome]] == 1, "Yes", "No"), levels = c("Yes", "No"))
  p_eff <- ncol(model.matrix(
    as.formula(paste("~", paste(xvars, collapse = "+"), "-1")),
    data = train_c
  ))
  mtry_max <- min(p_eff, max(2, floor(sqrt(p_eff)) * 2))
  rf_grid <- expand.grid(mtry = unique(pmin(seq(2, mtry_max, by = 2), p_eff)))
  fitControl_rf <- make_fit_control(seed = GLOBAL_SEED + 5000 + i, tune_max = nrow(rf_grid))
  set.seed(GLOBAL_SEED + 6000 + i)
  rf_fit <- caret::train(
    as.formula(paste(outcome, "~", paste(xvars, collapse = "+"))),
    data = train_c,
    method = "rf",
    metric = "ROC",
    trControl = fitControl_rf,
    tuneGrid = rf_grid,
    ntree = 500
  )
  best_rf[[i]] <- rf_fit$bestTune
  p_du_rf <- predict(rf_fit, newdata = dur_c, type = "prob")[, "Yes"]
  p_af_rf <- predict(rf_fit, newdata = aft_c, type = "prob")[, "Yes"]
  svm_radial_grid <- expand.grid(
    sigma = c(0.001, 0.005, 0.01, 0.05, 0.1),
    C = c(0.01, 0.1, 1, 10, 100)
  )
  fitControl_svm <- make_fit_control(seed = GLOBAL_SEED + 7000 + i, tune_max = nrow(svm_radial_grid))
  set.seed(GLOBAL_SEED + 8000 + i)
  svm_fit <- caret::train(
    as.formula(paste(outcome, "~", paste(xvars, collapse = "+"))),
    data = train_c,
    method = "svmRadial",
    metric = "ROC",
    trControl = fitControl_svm,
    tuneGrid = svm_radial_grid,
    preProcess = preSteps_svm
  )
  best_svm[[i]] <- svm_fit$bestTune
  p_du_svm <- predict(svm_fit, newdata = dur_c, type = "prob")[, "Yes"]
  p_af_svm <- predict(svm_fit, newdata = aft_c, type = "prob")[, "Yes"]
  p_du_list <- list(
    logistic = p_du_glm,
    lasso = p_du_las,
    elnet = p_du_en,
    rf = p_du_rf,
    svm = p_du_svm
  )
  p_af_list <- list(
    logistic = p_af_glm,
    lasso = p_af_las,
    elnet = p_af_en,
    rf = p_af_rf,
    svm = p_af_svm
  )
  pred_raw_dur[[i]] <- list(y = y_du, p = p_du_list)
  pred_raw_aft[[i]] <- list(y = y_af, p = p_af_list)
  res_raw[[i]] <- rbind(
    dur_logistic = get_metrics(y_du, p_du_glm, thr_i),
    aft_logistic = get_metrics(y_af, p_af_glm, thr_i),
    dur_lasso    = get_metrics(y_du, p_du_las, thr_i),
    aft_lasso    = get_metrics(y_af, p_af_las, thr_i),
    dur_elnet    = get_metrics(y_du, p_du_en,  thr_i),
    aft_elnet    = get_metrics(y_af, p_af_en,  thr_i),
    dur_rf       = get_metrics(y_du, p_du_rf,  thr_i),
    aft_rf       = get_metrics(y_af, p_af_rf,  thr_i),
    dur_svm      = get_metrics(y_du, p_du_svm, thr_i),
    aft_svm      = get_metrics(y_af, p_af_svm, thr_i)
  )
  roc_raw_dur[[i]] <- rbind(
    logistic = roc_interp(y_du, p_du_glm, grid_fpr),
    lasso    = roc_interp(y_du, p_du_las, grid_fpr),
    elnet    = roc_interp(y_du, p_du_en,  grid_fpr),
    rf       = roc_interp(y_du, p_du_rf,  grid_fpr),
    svm      = roc_interp(y_du, p_du_svm, grid_fpr)
  )
  roc_raw_aft[[i]] <- rbind(
    logistic = roc_interp(y_af, p_af_glm, grid_fpr),
    lasso    = roc_interp(y_af, p_af_las, grid_fpr),
    elnet    = roc_interp(y_af, p_af_en,  grid_fpr),
    rf       = roc_interp(y_af, p_af_rf,  grid_fpr),
    svm      = roc_interp(y_af, p_af_svm, grid_fpr)
  )
  tmp_ts_res  <- list()
  tmp_ts_boot <- list()
  tmp_ts_ab   <- list()
  for(mod in names(p_du_list)){
    rec_int <- recal_int_fit(y_du, p_du_list[[mod]])
    rec_is  <- recal_intslope_fit(y_du, p_du_list[[mod]])
    lp_af <- qlogis(clamp01(p_af_list[[mod]]))
    p_af_raw <- p_af_list[[mod]]
    p_af_int <- plogis(rec_int$alpha + lp_af)
    p_af_is  <- plogis(rec_is$alpha + rec_is$beta * lp_af)
    tmp_ts_res[[mod]] <- rbind(
      raw_after = get_metrics(y_af, p_af_raw, thr_i),
      int_recal_from_during_after = get_metrics(y_af, p_af_int, thr_i),
      intslope_recal_from_during_after = get_metrics(y_af, p_af_is, thr_i)
    )
    tmp_ts_ab[[mod]] <- data.frame(
      Model = mod,
      Imputation = i,
      alpha_intercept_only = rec_int$alpha,
      alpha_intercept_slope = rec_is$alpha,
      beta_intercept_slope = rec_is$beta,
      stringsAsFactors = FALSE
    )
    seed_base_ts <- GLOBAL_SEED + 100000 + i * 1000
    boot_raw <- boot_metrics(
      y = y_af,
      p = p_af_raw,
      thr = thr_i,
      B = B_boot,
      seed = seed_base_ts + 1 + match(mod, names(p_du_list)) * 10
    )
    boot_raw <- add_boot_meta(boot_raw, model = mod, period = "aft", strategy = "raw_after", imputation = i)
    boot_int <- boot_metrics(
      y = y_af,
      p = p_af_int,
      thr = thr_i,
      B = B_boot,
      seed = seed_base_ts + 2 + match(mod, names(p_du_list)) * 10
    )
    boot_int <- add_boot_meta(boot_int, model = mod, period = "aft", strategy = "int_recal_from_during_after", imputation = i)
    boot_is <- boot_metrics(
      y = y_af,
      p = p_af_is,
      thr = thr_i,
      B = B_boot,
      seed = seed_base_ts + 3 + match(mod, names(p_du_list)) * 10
    )
    boot_is <- add_boot_meta(boot_is, model = mod, period = "aft", strategy = "intslope_recal_from_during_after", imputation = i)
    tmp_ts_boot[[mod]] <- rbind(boot_raw, boot_int, boot_is)
  }
  time_sep_res[[i]]  <- tmp_ts_res
  time_sep_boot[[i]] <- do.call(rbind, tmp_ts_boot)
  time_sep_ab[[i]]   <- do.call(rbind, tmp_ts_ab)
  r_du_glm_i <- recal_int_fit(y_du, p_du_glm)
  r_af_glm_i <- recal_int_fit(y_af, p_af_glm)
  r_du_las_i <- recal_int_fit(y_du, p_du_las)
  r_af_las_i <- recal_int_fit(y_af, p_af_las)
  r_du_en_i <- recal_int_fit(y_du, p_du_en)
  r_af_en_i <- recal_int_fit(y_af, p_af_en)
  r_du_rf_i <- recal_int_fit(y_du, p_du_rf)
  r_af_rf_i <- recal_int_fit(y_af, p_af_rf)
  r_du_svm_i <- recal_int_fit(y_du, p_du_svm)
  r_af_svm_i <- recal_int_fit(y_af, p_af_svm)
  pred_int_dur[[i]] <- list(
    y = y_du,
    p = list(
      logistic = r_du_glm_i$p_new,
      lasso = r_du_las_i$p_new,
      elnet = r_du_en_i$p_new,
      rf = r_du_rf_i$p_new,
      svm = r_du_svm_i$p_new
    )
  )
  pred_int_aft[[i]] <- list(
    y = y_af,
    p = list(
      logistic = r_af_glm_i$p_new,
      lasso = r_af_las_i$p_new,
      elnet = r_af_en_i$p_new,
      rf = r_af_rf_i$p_new,
      svm = r_af_svm_i$p_new
    )
  )
  res_int[[i]] <- rbind(
    dur_logistic = get_metrics(y_du, r_du_glm_i$p_new, thr_i),
    aft_logistic = get_metrics(y_af, r_af_glm_i$p_new, thr_i),
    dur_lasso    = get_metrics(y_du, r_du_las_i$p_new, thr_i),
    aft_lasso    = get_metrics(y_af, r_af_las_i$p_new, thr_i),
    dur_elnet    = get_metrics(y_du, r_du_en_i$p_new,  thr_i),
    aft_elnet    = get_metrics(y_af, r_af_en_i$p_new,  thr_i),
    dur_rf       = get_metrics(y_du, r_du_rf_i$p_new,  thr_i),
    aft_rf       = get_metrics(y_af, r_af_rf_i$p_new,  thr_i),
    dur_svm      = get_metrics(y_du, r_du_svm_i$p_new, thr_i),
    aft_svm      = get_metrics(y_af, r_af_svm_i$p_new, thr_i)
  )
  r_du_glm_is <- recal_intslope_fit(y_du, p_du_glm)
  r_af_glm_is <- recal_intslope_fit(y_af, p_af_glm)
  r_du_las_is <- recal_intslope_fit(y_du, p_du_las)
  r_af_las_is <- recal_intslope_fit(y_af, p_af_las)
  r_du_en_is <- recal_intslope_fit(y_du, p_du_en)
  r_af_en_is <- recal_intslope_fit(y_af, p_af_en)
  r_du_rf_is <- recal_intslope_fit(y_du, p_du_rf)
  r_af_rf_is <- recal_intslope_fit(y_af, p_af_rf)
  r_du_svm_is <- recal_intslope_fit(y_du, p_du_svm)
  r_af_svm_is <- recal_intslope_fit(y_af, p_af_svm)
  pred_is_dur[[i]] <- list(
    y = y_du,
    p = list(
      logistic = r_du_glm_is$p_new,
      lasso = r_du_las_is$p_new,
      elnet = r_du_en_is$p_new,
      rf = r_du_rf_is$p_new,
      svm = r_du_svm_is$p_new
    )
  )
  pred_is_aft[[i]] <- list(
    y = y_af,
    p = list(
      logistic = r_af_glm_is$p_new,
      lasso = r_af_las_is$p_new,
      elnet = r_af_en_is$p_new,
      rf = r_af_rf_is$p_new,
      svm = r_af_svm_is$p_new
    )
  )
  res_is[[i]] <- rbind(
    dur_logistic = get_metrics(y_du, r_du_glm_is$p_new, thr_i),
    aft_logistic = get_metrics(y_af, r_af_glm_is$p_new, thr_i),
    dur_lasso    = get_metrics(y_du, r_du_las_is$p_new, thr_i),
    aft_lasso    = get_metrics(y_af, r_af_las_is$p_new, thr_i),
    dur_elnet    = get_metrics(y_du, r_du_en_is$p_new,  thr_i),
    aft_elnet    = get_metrics(y_af, r_af_en_is$p_new,  thr_i),
    dur_rf       = get_metrics(y_du, r_du_rf_is$p_new,  thr_i),
    aft_rf       = get_metrics(y_af, r_af_rf_is$p_new,  thr_i),
    dur_svm      = get_metrics(y_du, r_du_svm_is$p_new, thr_i),
    aft_svm      = get_metrics(y_af, r_af_svm_is$p_new, thr_i)
  )
  ab_is[[i]] <- rbind(
    dur_logistic = c(alpha = r_du_glm_is$alpha, beta = r_du_glm_is$beta),
    aft_logistic = c(alpha = r_af_glm_is$alpha, beta = r_af_glm_is$beta),
    dur_lasso    = c(alpha = r_du_las_is$alpha, beta = r_du_las_is$beta),
    aft_lasso    = c(alpha = r_af_las_is$alpha, beta = r_af_las_is$beta),
    dur_elnet    = c(alpha = r_du_en_is$alpha,  beta = r_du_en_is$beta),
    aft_elnet    = c(alpha = r_af_en_is$alpha,  beta = r_af_en_is$beta),
    dur_rf       = c(alpha = r_du_rf_is$alpha,  beta = r_du_rf_is$beta),
    aft_rf       = c(alpha = r_af_rf_is$alpha,  beta = r_af_rf_is$beta),
    dur_svm      = c(alpha = r_du_svm_is$alpha, beta = r_du_svm_is$beta),
    aft_svm      = c(alpha = r_af_svm_is$alpha, beta = r_af_svm_is$beta)
  )
  ab_int[[i]] <- rbind(
    dur_logistic = c(alpha = r_du_glm_i$alpha),
    aft_logistic = c(alpha = r_af_glm_i$alpha),
    dur_lasso    = c(alpha = r_du_las_i$alpha),
    aft_lasso    = c(alpha = r_af_las_i$alpha),
    dur_elnet    = c(alpha = r_du_en_i$alpha),
    aft_elnet    = c(alpha = r_af_en_i$alpha),
    dur_rf       = c(alpha = r_du_rf_i$alpha),
    aft_rf       = c(alpha = r_af_rf_i$alpha),
    dur_svm      = c(alpha = r_du_svm_i$alpha),
    aft_svm      = c(alpha = r_af_svm_i$alpha)
  )
  tmp_phase_boot <- list()
  boot_counter <- 1
  for(mod in models){
    seed_base_phase <- GLOBAL_SEED + 200000 + i * 1000 + match(mod, models) * 100
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_du, pred_raw_dur[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 1),
      model = mod, period = "dur", strategy = "raw", imputation = i
    )
    boot_counter <- boot_counter + 1
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_af, pred_raw_aft[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 2),
      model = mod, period = "aft", strategy = "raw", imputation = i
    )
    boot_counter <- boot_counter + 1
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_du, pred_int_dur[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 3),
      model = mod, period = "dur", strategy = "apparent_int", imputation = i
    )
    boot_counter <- boot_counter + 1
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_af, pred_int_aft[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 4),
      model = mod, period = "aft", strategy = "apparent_int", imputation = i
    )
    boot_counter <- boot_counter + 1
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_du, pred_is_dur[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 5),
      model = mod, period = "dur", strategy = "apparent_intslope", imputation = i
    )
    boot_counter <- boot_counter + 1
    tmp_phase_boot[[boot_counter]] <- add_boot_meta(
      boot_metrics(y_af, pred_is_aft[[i]]$p[[mod]], thr_i, B = B_boot, seed = seed_base_phase + 6),
      model = mod, period = "aft", strategy = "apparent_intslope", imputation = i
    )
    boot_counter <- boot_counter + 1
  }
  phase_boot[[i]] <- do.call(rbind, tmp_phase_boot)
  cat("Completed imputation", i, "\n")
}

## 5) Main summaries

A1_raw <- summarize_res_list(res_raw)
A1_int <- summarize_res_list(res_int)
A1_is  <- summarize_res_list(res_is)

cat("\nMAIN MODEL PERFORMANCE SUMMARY\n")
cat("m_used =", A1_raw$m_used, "out of", m_use, "\n")

out_tbl_raw <- fmt_tbl(A1_raw$mean, A1_raw$sd)
out_tbl_int <- fmt_tbl(A1_int$mean, A1_int$sd)
out_tbl_is  <- fmt_tbl(A1_is$mean,  A1_is$sd)

cat("\n===== RAW mean (sd) across imputations =====\n")
print(out_tbl_raw)

cat("\n===== APPARENT INT-ONLY RECALIBRATION mean (sd) across imputations =====\n")
print(out_tbl_int)

cat("\n===== APPARENT INT+SLOPE RECALIBRATION mean (sd) across imputations =====\n")
print(out_tbl_is)

ab_int_sum <- summarize_res_list(ab_int)
ab_is_sum  <- summarize_res_list(ab_is)

alpha_tbl <- fmt_tbl(ab_int_sum$mean, ab_int_sum$sd)
alpha_beta_tbl <- fmt_tbl(ab_is_sum$mean, ab_is_sum$sd)

cat("\n===== Apparent recalibration alpha, INT-ONLY, mean (sd) =====\n")
print(alpha_tbl)

cat("\n===== Apparent recalibration alpha/beta, INT+SLOPE, mean (sd) =====\n")
print(alpha_beta_tbl)

## 6) Reviewer output: bootstrap CI tables

metrics_reviewer <- c("AUC", "Brier", "Cal_Int", "Cal_Slope", "OE")

phase_point_df <- rbind(
  res_list_to_df(res_raw, "raw"),
  res_list_to_df(res_int, "apparent_int"),
  res_list_to_df(res_is,  "apparent_intslope")
)

phase_boot_df <- do.call(
  rbind,
  phase_boot[!sapply(phase_boot, is.null)]
)

phase_summary <- make_summary_table(
  point_df = phase_point_df,
  boot_df = phase_boot_df,
  group_cols = c("Model", "Period", "Strategy"),
  metrics_show = metrics_reviewer
)

time_sep_point_df <- time_sep_res_to_df(time_sep_res)

time_sep_boot_df <- do.call(
  rbind,
  time_sep_boot[!sapply(time_sep_boot, is.null)]
)

time_sep_ab_df <- do.call(
  rbind,
  time_sep_ab[!sapply(time_sep_ab, is.null)]
)

time_sep_summary <- make_summary_table(
  point_df = time_sep_point_df,
  boot_df = time_sep_boot_df,
  group_cols = c("Model", "Period", "Strategy"),
  metrics_show = metrics_reviewer
)

cat("\nREVIEWER OUTPUT 1\n")
cat("Bootstrap 95% CI for raw and apparent period-specific recalibration\n")
cat("Note: apparent recalibration uses the same period for estimation and evaluation.\n")

print(
  phase_summary[
    order(phase_summary$Model,
          phase_summary$Period,
          phase_summary$Strategy,
          phase_summary$Metric),
  ],
  row.names = FALSE
)

cat("\nREVIEWER OUTPUT 2\n")
cat("Time-separated recalibration\n")
cat("Recalibration parameters estimated in during-COVID and evaluated in after-COVID.\n")
cat("Bootstrap 95% CI with B =", B_boot, "\n")

print(
  time_sep_summary[
    order(time_sep_summary$Model,
          time_sep_summary$Strategy,
          time_sep_summary$Metric),
  ],
  row.names = FALSE
)

cat("\nREVIEWER OUTPUT 3\n")
cat("Time-separated recalibration parameters estimated in during-COVID\n")

print(time_sep_ab_df, row.names = FALSE)

## 7) ROC curves
out_dir <- file.path(project_dir, "reviewer_recalibration_outputs")

dat <- readRDS(
  file.path(out_dir, "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

grid_fpr <- dat$grid_fpr
roc_dur_mean <- dat$roc_dur_mean
roc_aft_mean <- dat$roc_aft_mean
auc_dur <- dat$auc_dur
auc_aft <- dat$auc_aft

plot_mean_roc_color <- function(grid_fpr, roc_mean, auc_mean, main_title){
  models_plot <- rownames(roc_mean)
  cols <- rainbow(length(models_plot))
  
  plot(
    0, 0,
    type = "n",
    xlim = c(0, 1),
    ylim = c(0, 1),
    xlab = "1 - Specificity",
    ylab = "Sensitivity",
    main = main_title
  )
  
  abline(0, 1, lty = 2)
  
  for(j in seq_along(models_plot)){
    m <- models_plot[j]
    lines(grid_fpr, roc_mean[m, ], col = cols[j], lwd = 2)
  }
  
  leg <- sprintf("%s (AUC=%.3f)", models_plot, auc_mean[models_plot])
  
  legend(
    "bottomright",
    legend = leg,
    col = cols,
    lwd = 2,
    bty = "n",
    cex = 0.9
  )
}

pdf(
  file = file.path(out_dir, "mean_roc_during_covid_raw.pdf"),
  width = 6,
  height = 5
)

plot_mean_roc_color(
  grid_fpr = grid_fpr,
  roc_mean = roc_dur_mean,
  auc_mean = auc_dur,
  main_title = "Mean ROC: During-COVID validation"
)

dev.off()

pdf(
  file = file.path(out_dir, "mean_roc_after_covid_raw.pdf"),
  width = 6,
  height = 5
)

plot_mean_roc_color(
  grid_fpr = grid_fpr,
  roc_mean = roc_aft_mean,
  auc_mean = auc_aft,
  main_title = "Mean ROC: After-COVID validation"
)

dev.off()

plot_mean_roc_color(
  grid_fpr = grid_fpr,
  roc_mean = roc_dur_mean,
  auc_mean = auc_dur,
  main_title = "Mean ROC: During-COVID validation"
)

plot_mean_roc_color(
  grid_fpr = grid_fpr,
  roc_mean = roc_aft_mean,
  auc_mean = auc_aft,
  main_title = "Mean ROC: After-COVID validation"
)

## 8) RF/SVM tuning output

best_rf2  <- best_rf[!sapply(best_rf, is.null)]
best_svm2 <- best_svm[!sapply(best_svm, is.null)]

if(length(best_rf2) > 0){
  rf_tune_df <- do.call(rbind, lapply(best_rf2, as.data.frame))
  cat("\nRF bestTune by imputation\n")
  print(rf_tune_df)
  cat("\nRF bestTune frequency:\n")
  print(as.data.frame(table(rf_tune_df$mtry)))
} else {
  rf_tune_df <- NULL
}

if(length(best_svm2) > 0){
  svm_tune_df <- do.call(rbind, lapply(best_svm2, as.data.frame))
  cat("\nSVM bestTune by imputation\n")
  print(svm_tune_df)
  cat("\nSVM bestTune frequency, sigma by C:\n")
  print(as.data.frame(table(svm_tune_df$sigma, svm_tune_df$C)))
} else {
  svm_tune_df <- NULL
}

## 9) Pooled OR for logistic model

glm_fits2 <- glm_fits[!sapply(glm_fits, is.null)]

if(length(glm_fits2) >= 2){
  pooled_or <- pool_glm_or(glm_fits2)
  cat("\nPooled OR, logistic model from Before-COVID training\n")
  print(pooled_or[order(pooled_or$term), ])
} else {
  pooled_or <- NULL
  cat("\n[WARN] Too few logistic fits to pool OR/CI.\n")
}

## 10) Save outputs

write.csv(
  phase_summary,
  file.path(out_dir, "phase_raw_apparent_recalibration_bootstrap_B500_summary.csv"),
  row.names = FALSE
)

write.csv(
  time_sep_summary,
  file.path(out_dir, "time_separated_recalibration_bootstrap_B500_summary.csv"),
  row.names = FALSE
)

write.csv(
  time_sep_ab_df,
  file.path(out_dir, "time_separated_recalibration_parameters_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  phase_point_df,
  file.path(out_dir, "phase_raw_apparent_recalibration_point_estimates_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  time_sep_point_df,
  file.path(out_dir, "time_separated_recalibration_point_estimates_by_imputation.csv"),
  row.names = FALSE
)

if(!is.null(rf_tune_df)){
  write.csv(
    rf_tune_df,
    file.path(out_dir, "rf_bestTune_by_imputation.csv"),
    row.names = FALSE
  )
}

if(!is.null(svm_tune_df)){
  write.csv(
    svm_tune_df,
    file.path(out_dir, "svm_bestTune_by_imputation.csv"),
    row.names = FALSE
  )
}

if(!is.null(pooled_or)){
  write.csv(
    pooled_or,
    file.path(out_dir, "pooled_logistic_OR_before_covid.csv"),
    row.names = FALSE
  )
}

writeLines(
  capture.output(sessionInfo()),
  con = file.path(out_dir, "sessionInfo.txt")
)

data <- list(
  reproducibility = list(
    GLOBAL_SEED = GLOBAL_SEED,
    B_boot = B_boot,
    RNGkind = RNGkind(),
    parallel_enabled = TRUE,
    parallel_cores = n_cores,
    base_dir = base_dir,
    out_dir = out_dir,
    imp_path = imp_path
  ),
  outcome = outcome,
  models = models,
  grid_fpr = grid_fpr,
  centers4 = centers4,
  res_raw = res_raw,
  res_int = res_int,
  res_is  = res_is,
  ab_int = ab_int,
  ab_is = ab_is,
  time_sep_res = time_sep_res,
  time_sep_boot = time_sep_boot,
  time_sep_ab = time_sep_ab,
  time_sep_ab_df = time_sep_ab_df,
  time_sep_point_df = time_sep_point_df,
  time_sep_boot_df = time_sep_boot_df,
  time_sep_summary = time_sep_summary,
  phase_boot = phase_boot,
  phase_point_df = phase_point_df,
  phase_boot_df = phase_boot_df,
  phase_summary = phase_summary,
  roc_raw_dur = roc_raw_dur,
  roc_raw_aft = roc_raw_aft,
  roc_dur_mean = roc_dur_mean,
  roc_aft_mean = roc_aft_mean,
  auc_dur = auc_dur,
  auc_aft = auc_aft,
  best_rf = best_rf,
  best_svm = best_svm,
  rf_tune_df = rf_tune_df,
  svm_tune_df = svm_tune_df,
  glm_fits = glm_fits,
  pooled_or = pooled_or,
  pred_raw_dur = pred_raw_dur,
  pred_raw_aft = pred_raw_aft,
  pred_int_dur = pred_int_dur,
  pred_int_aft = pred_int_aft,
  pred_is_dur = pred_is_dur,
  pred_is_aft = pred_is_aft,
  A1_raw = A1_raw,
  A1_int = A1_int,
  A1_is = A1_is,
  out_tbl_raw = out_tbl_raw,
  out_tbl_int = out_tbl_int,
  out_tbl_is = out_tbl_is,
  alpha_tbl = alpha_tbl,
  alpha_beta_tbl = alpha_beta_tbl,
  train_spec = train_spec,
  lasso_cv = lasso_cv,
  elnet_cv = elnet_cv,
  lasso_spec = lasso_spec,
  elnet_spec = elnet_spec
)

saveRDS(
  data,
  file.path(out_dir, "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds"),
  compress = "xz"
)

if(exists("parallel_backend_created") && isTRUE(parallel_backend_created)){
  parallel::stopCluster(cl)
  foreach::registerDoSEQ()
  cat("\nParallel backend stopped.\n")
}

cat("\nAnalysis completed successfully.\n")
cat("Outputs saved to:\n")
cat(out_dir, "\n")
cat("\nKey reviewer tables:\n")
cat("1) phase_raw_apparent_recalibration_bootstrap_B500_summary.csv\n")
cat("2) time_separated_recalibration_bootstrap_B500_summary.csv\n")
cat("3) time_separated_recalibration_parameters_by_imputation.csv\n")
cat("4) sessionInfo.txt\n")


#####  Calibration plots #####
data <- readRDS(file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds"))

models <- data$models
if(is.null(models)) models <- c("logistic","lasso","elnet","rf","svm")

eps <- 1e-6
clamp01 <- function(p) pmin(pmax(p, eps), 1 - eps)

cal_curve_loess_one <- function(y, p, grid = seq(0.01, 0.99, by=0.01), span=0.75){
  y <- as.numeric(as.integer(y == 1L))
  p <- as.numeric(p)
  
  ok <- !is.na(y) & !is.na(p) & is.finite(p)
  y <- y[ok]; p <- p[ok]
  
  if(length(y) < 30) return(NULL)
  if(length(unique(y)) < 2) return(NULL)
  
  p <- clamp01(p)
  if(length(unique(p)) < 5) return(NULL)
  
  fit <- try(
    loess(y ~ p, span = span, degree = 1,
          control = loess.control(surface = "direct")),
    silent = TRUE
  )
  if(inherits(fit, "try-error")) return(NULL)
  
  pred <- try(predict(fit, newdata = data.frame(p = grid)), silent = TRUE)
  if(inherits(pred, "try-error")) return(NULL)
  
  pred <- as.numeric(pred)
  pred[!is.finite(pred)] <- NA_real_
  pmin(pmax(pred, 0), 1)
}

cal_curve_bin_one <- function(y, p, n_bins = 10){
  y <- as.integer(y == 1L)
  p <- clamp01(as.numeric(p))
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]; p <- p[ok]
  if(length(y) < 50 || length(unique(y)) < 2) return(NULL)
  
  br <- quantile(p, probs = seq(0, 1, length.out = n_bins + 1), na.rm = TRUE, type = 7)
  br <- unique(as.numeric(br))
  if(length(br) < 3) return(NULL)
  
  g <- cut(p, breaks = br, include.lowest = TRUE, right = TRUE)
  obs <- tapply(y, g, mean, na.rm = TRUE)
  pred <- tapply(p, g, mean, na.rm = TRUE)
  n <- tapply(y, g, length)
  
  data.frame(pred = as.numeric(pred), obs = as.numeric(obs), n = as.numeric(n))
}

get_pred_list <- function(data, phase = c("dur","aft"), scheme = c("raw","int","is")){
  phase <- match.arg(phase)
  scheme <- match.arg(scheme)
  nm <- paste0("pred_", scheme, "_", phase)
  out <- data[[nm]]
  if(is.null(out)) stop("Object not found in saved analysis results: ", nm)
  out
}

avg_cal_loess <- function(pred_list, model_name,
                          grid = seq(0.01, 0.99, by=0.01),
                          span=0.75,
                          verbose = FALSE){
  mats <- vector("list", length(pred_list))
  used <- logical(length(pred_list))
  
  for(i in seq_along(pred_list)){
    one <- pred_list[[i]]
    if(is.null(one) || is.null(one$y) || is.null(one$p) || is.null(one$p[[model_name]])){
      next
    }
    
    v <- cal_curve_loess_one(one$y, one$p[[model_name]], grid = grid, span = span)
    
    if(is.null(v)){
      if(verbose) message("skip: imp=", i, " model=", model_name)
      next
    }
    
    mats[[i]] <- v
    used[i] <- TRUE
  }
  
  mats <- mats[used]
  if(length(mats) == 0) return(NULL)
  
  M <- do.call(rbind, mats)
  list(
    grid = grid,
    mean = colMeans(M, na.rm = TRUE),
    sd   = apply(M, 2, sd, na.rm = TRUE),
    m_used = nrow(M)
  )
}

plot_calibration_panel <- function(data,
                                   phase = c("dur","aft"),
                                   scheme = c("raw","int","is"),
                                   models = NULL,
                                   grid = seq(0.01, 0.99, by=0.01),
                                   span = 0.75,
                                   show_sd = TRUE,
                                   legend_pos = "bottomright"){
  phase <- match.arg(phase)
  scheme <- match.arg(scheme)
  if(is.null(models)) models <- data$models
  
  pred_list <- get_pred_list(data, phase = phase, scheme = scheme)
  
  title_phase <- if(phase == "dur") "During-COVID" else "After-COVID"
  title_scheme <- switch(scheme,
                         raw = "RAW",
                         int = "Intercept-only recalibration",
                         is  = "Intercept + slope recalibration")
  main_title <- paste0("Calibration: ", title_phase, " | ", title_scheme)
  
  plot(0, 0, type="n", xlim=c(0,1), ylim=c(0,1),
       xlab="Predicted risk", ylab="Observed risk",
       main=main_title)
  abline(0, 1, lty=2)
  
  cols <- rainbow(length(models))
  
  for(k in seq_along(models)){
    m <- models[k]
    tmp <- avg_cal_loess(pred_list, m, grid = grid, span = span)
    if(is.null(tmp)) next
    
    if(show_sd){
      upper <- pmin(pmax(tmp$mean + tmp$sd, 0), 1)
      lower <- pmin(pmax(tmp$mean - tmp$sd, 0), 1)
      polygon(c(tmp$grid, rev(tmp$grid)),
              c(upper, rev(lower)),
              col = adjustcolor(cols[k], alpha.f = 0.15),
              border = NA)
    }
    lines(tmp$grid, tmp$mean, col = cols[k], lwd = 2)
  }
  
  legend(legend_pos, legend = models, col = cols, lwd = 1.5, inset = -0.05,bty = "n")
  invisible(TRUE)
}

plot_calibration_panel(data, phase="dur", scheme="raw")
plot_calibration_panel(data, phase="aft", scheme="raw")

plot_calibration_panel(data, phase="dur", scheme="int")
plot_calibration_panel(data, phase="aft", scheme="int")

plot_calibration_panel(data, phase="dur", scheme="is")
plot_calibration_panel(data, phase="aft", scheme="is")


#####  Random forest outputs #####
library(mice)
library(randomForest)
library(pROC)

## Extract RF results directly from saved RDS  

data <- readRDS(
  file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

dir.create(
  file.path(project_dir, "IVIGR", "RF"),
  recursive = TRUE,
  showWarnings = FALSE
)

# 1. RF tuned mtry by imputation
rf_tune <- data$rf_tune_df

print(rf_tune)

write.csv(
  rf_tune,
  file.path(project_dir, "IVIGR", "RF", "rf_tuned_mtry_by_imputation_extracted.csv"),
  row.names = FALSE
)

# 2. RF raw and apparent recalibration results
rf_phase_summary <- subset(data$phase_summary, Model == "rf")

print(rf_phase_summary)

write.csv(
  rf_phase_summary,
  file.path(project_dir, "IVIGR", "RF", "rf_phase_raw_apparent_recalibration_summary_extracted.csv"),
  row.names = FALSE
)

# 3. RF time-separated recalibration results
rf_time_sep_summary <- subset(data$time_sep_summary, Model == "rf")

print(rf_time_sep_summary)

write.csv(
  rf_time_sep_summary,
  file.path(project_dir, "IVIGR", "RF", "rf_time_separated_recalibration_summary_extracted.csv"),
  row.names = FALSE
)

# 4. RF point estimates by imputation: raw/apparent recalibration
rf_phase_point <- subset(data$phase_point_df, Model == "rf")

print(rf_phase_point)

write.csv(
  rf_phase_point,
  file.path(project_dir, "IVIGR", "RF", "rf_phase_point_estimates_by_imputation_extracted.csv"),
  row.names = FALSE
)

# 5. RF point estimates by imputation: time-separated recalibration
rf_time_sep_point <- subset(data$time_sep_point_df, Model == "rf")

print(rf_time_sep_point)

write.csv(
  rf_time_sep_point,
  file.path(project_dir, "IVIGR", "RF", "rf_time_separated_point_estimates_by_imputation_extracted.csv"),
  row.names = FALSE
)

# 6. RF AUC from saved RDS
rf_auc <- data.frame(
  Model = "rf",
  During_COVID_AUC = as.numeric(data$auc_dur["rf"]),
  After_COVID_AUC  = as.numeric(data$auc_aft["rf"])
)

print(rf_auc)

write.csv(
  rf_auc,
  file.path(project_dir, "IVIGR", "RF", "rf_auc_extracted.csv"),
  row.names = FALSE
)

#####  Decision curve analysis #####

data <- readRDS(
  file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

dir.create(
  file.path(project_dir, "IVIGR", "RF", "DCA"),
  recursive = TRUE,
  showWarnings = FALSE
)

eps <- 1e-6

clamp01 <- function(p){
  pmin(pmax(as.numeric(p), eps), 1 - eps)
}

get_pred_list <- function(data, phase = c("dur", "aft"), scheme = c("raw", "int", "is")){
  phase <- match.arg(phase)
  scheme <- match.arg(scheme)
  nm <- paste0("pred_", scheme, "_", phase)
  out <- data[[nm]]
  if(is.null(out)) stop("Object not found in saved analysis results: ", nm)
  out
}

to_eval_df <- function(one, model_name = "rf"){
  if(is.null(one) || is.null(one$y) || is.null(one$p) || is.null(one$p[[model_name]])){
    return(NULL)
  }
  
  y <- as.integer(one$y == 1L)
  p <- clamp01(one$p[[model_name]])
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  if(length(y) < 50 || length(unique(y)) < 2){
    return(NULL)
  }
  
  data.frame(y = y, p = p)
}

net_benefit_one <- function(y, p, thresholds){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  n <- length(y)
  prev <- mean(y == 1)
  
  nb_model <- numeric(length(thresholds))
  nb_all   <- numeric(length(thresholds))
  nb_none  <- rep(0, length(thresholds))
  
  for(j in seq_along(thresholds)){
    pt <- thresholds[j]
    
    pred_pos <- p >= pt
    
    TP <- sum(pred_pos & y == 1)
    FP <- sum(pred_pos & y == 0)
    
    nb_model[j] <- TP / n - FP / n * pt / (1 - pt)
    nb_all[j]   <- prev - (1 - prev) * pt / (1 - pt)
  }
  
  data.frame(
    threshold = thresholds,
    model = nb_model,
    all = nb_all,
    none = nb_none
  )
}

boot_dca_one <- function(y, p, thresholds, B = 500, seed = 123){
  set.seed(seed)
  
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  n <- length(y)
  
  boot_model <- matrix(NA_real_, nrow = length(thresholds), ncol = B)
  boot_all   <- matrix(NA_real_, nrow = length(thresholds), ncol = B)
  boot_none  <- matrix(NA_real_, nrow = length(thresholds), ncol = B)
  
  for(b in seq_len(B)){
    idx <- sample(seq_len(n), size = n, replace = TRUE)
    
    tmp <- net_benefit_one(
      y = y[idx],
      p = p[idx],
      thresholds = thresholds
    )
    
    boot_model[, b] <- tmp$model
    boot_all[, b]   <- tmp$all
    boot_none[, b]  <- tmp$none
  }
  
  list(
    model = boot_model,
    all = boot_all,
    none = boot_none
  )
}

dca_over_mi <- function(pred_list,
                        model_name = "rf",
                        thresholds = seq(0.01, 0.30, by = 0.01),
                        B = 500,
                        seed_base = 123){
  
  m <- length(pred_list)
  
  point_model <- matrix(NA_real_, nrow = length(thresholds), ncol = m)
  point_all   <- matrix(NA_real_, nrow = length(thresholds), ncol = m)
  point_none  <- matrix(NA_real_, nrow = length(thresholds), ncol = m)
  
  boot_model_list <- list()
  boot_all_list   <- list()
  boot_none_list  <- list()
  
  used <- rep(FALSE, m)
  
  for(i in seq_len(m)){
    df <- to_eval_df(pred_list[[i]], model_name = model_name)
    if(is.null(df)) next
    
    point <- net_benefit_one(
      y = df$y,
      p = df$p,
      thresholds = thresholds
    )
    
    point_model[, i] <- point$model
    point_all[, i]   <- point$all
    point_none[, i]  <- point$none
    
    boot <- boot_dca_one(
      y = df$y,
      p = df$p,
      thresholds = thresholds,
      B = B,
      seed = seed_base + i
    )
    
    boot_model_list[[length(boot_model_list) + 1]] <- boot$model
    boot_all_list[[length(boot_all_list) + 1]]     <- boot$all
    boot_none_list[[length(boot_none_list) + 1]]   <- boot$none
    
    used[i] <- TRUE
  }
  
  keep <- which(used)
  if(length(keep) == 0){
    stop("No valid imputed dataset is available for DCA.")
  }
  
  point_model <- point_model[, keep, drop = FALSE]
  point_all   <- point_all[, keep, drop = FALSE]
  point_none  <- point_none[, keep, drop = FALSE]
  
  boot_model_all <- do.call(cbind, boot_model_list)
  boot_all_all   <- do.call(cbind, boot_all_list)
  boot_none_all  <- do.call(cbind, boot_none_list)
  
  out <- data.frame(
    threshold = thresholds,
    
    nb_model_mean = rowMeans(point_model, na.rm = TRUE),
    nb_model_ci_l = apply(boot_model_all, 1, quantile, probs = 0.025, na.rm = TRUE),
    nb_model_ci_u = apply(boot_model_all, 1, quantile, probs = 0.975, na.rm = TRUE),
    
    nb_all_mean = rowMeans(point_all, na.rm = TRUE),
    nb_all_ci_l = apply(boot_all_all, 1, quantile, probs = 0.025, na.rm = TRUE),
    nb_all_ci_u = apply(boot_all_all, 1, quantile, probs = 0.975, na.rm = TRUE),
    
    nb_none_mean = rowMeans(point_none, na.rm = TRUE),
    nb_none_ci_l = apply(boot_none_all, 1, quantile, probs = 0.025, na.rm = TRUE),
    nb_none_ci_u = apply(boot_none_all, 1, quantile, probs = 0.975, na.rm = TRUE),
    
    m_used = length(keep),
    B = B
  )
  
  list(
    summary = out,
    point_model = point_model,
    point_all = point_all,
    point_none = point_none,
    boot_model = boot_model_all,
    boot_all = boot_all_all,
    boot_none = boot_none_all,
    m_used = length(keep),
    B = B
  )
}

#####  Plot as editable vector PDF

plot_dca_3schemes <- function(res_raw,
                              res_int,
                              res_is,
                              main = "DCA",
                              ylim = c(-0.05, 0.20),
                              file){
  
  ths <- res_raw$summary$threshold
  
  pdf(
    file = file,
    width = 7.2,
    height = 5.6,
    family = "Helvetica",
    useDingbats = FALSE
  )
  
  par(
    mar = c(5.2, 5.2, 4.2, 2),
    mgp = c(3.0, 0.9, 0),
    las = 1
  )
  
  plot(
    ths,
    res_raw$summary$nb_model_mean,
    type = "n",
    xlab = "Threshold probability",
    ylab = "Net benefit",
    main = main,
    ylim = ylim,
    xlim = range(ths),
    cex.lab = 1.2,
    cex.axis = 1.05,
    cex.main = 1.25,
    font.main = 2
  )
  
  abline(h = 0, lty = 2, col = "grey40", lwd = 1.2)
  
  lines(ths, res_raw$summary$nb_all_mean,  lwd = 1.2, lty = 3, col = "black")
  lines(ths, res_raw$summary$nb_none_mean, lwd = 1.2, lty = 2, col = "grey40")
  
  lines(ths, res_raw$summary$nb_model_mean, lwd = 2.5, lty = 1, col = "#276FAF")
  lines(ths, res_int$summary$nb_model_mean, lwd = 2.5, lty = 2, col = "#B5202E")
  lines(ths, res_is$summary$nb_model_mean,  lwd = 2.5, lty = 3, col = "#2CA02C")
  
  legend(
    "topright",
    legend = c(
      "RF raw",
      "RF intercept-only recalibration",
      "RF intercept+slope recalibration",
      "Treat all",
      "Treat none"
    ),
    col = c("#276FAF", "#B5202E", "#2CA02C", "black", "grey40"),
    lty = c(1, 2, 3, 3, 2),
    lwd = c(2.5, 2.5, 2.5, 1.2, 1.2),
    bty = "n",
    cex = 0.95
  )
  
  dev.off()
  
  invisible(TRUE)
}

export_dca_3schemes <- function(res_raw, res_int, res_is, file){
  ths <- res_raw$summary$threshold
  
  out <- data.frame(
    threshold = ths,
    
    rf_raw_mean = res_raw$summary$nb_model_mean,
    rf_raw_ci_l = res_raw$summary$nb_model_ci_l,
    rf_raw_ci_u = res_raw$summary$nb_model_ci_u,
    
    rf_int_mean = res_int$summary$nb_model_mean,
    rf_int_ci_l = res_int$summary$nb_model_ci_l,
    rf_int_ci_u = res_int$summary$nb_model_ci_u,
    
    rf_is_mean = res_is$summary$nb_model_mean,
    rf_is_ci_l = res_is$summary$nb_model_ci_l,
    rf_is_ci_u = res_is$summary$nb_model_ci_u,
    
    treat_all_mean = res_raw$summary$nb_all_mean,
    treat_all_ci_l = res_raw$summary$nb_all_ci_l,
    treat_all_ci_u = res_raw$summary$nb_all_ci_u,
    
    treat_none_mean = res_raw$summary$nb_none_mean,
    treat_none_ci_l = res_raw$summary$nb_none_ci_l,
    treat_none_ci_u = res_raw$summary$nb_none_ci_u,
    
    m_used = res_raw$summary$m_used,
    B = res_raw$summary$B
  )
  
  write.csv(out, file, row.names = FALSE)
  invisible(out)
}

#####  1. Apparent period-specific DCA: during-COVID  

thresholds <- seq(0.01, 0.30, by = 0.01)

res_dur_raw <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "dur", scheme = "raw"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 11000
)

res_dur_int <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "dur", scheme = "int"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 12000
)

res_dur_is <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "dur", scheme = "is"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 13000
)

plot_dca_3schemes(
  res_dur_raw,
  res_dur_int,
  res_dur_is,
  main = "DCA: During-COVID validation | Random forest",
  ylim = c(-0.05, 0.25),
  file = file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_during_3schemes.pdf")
)

export_dca_3schemes(
  res_dur_raw,
  res_dur_int,
  res_dur_is,
  file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_during_3schemes_B500.csv")
)

#####  2. Apparent period-specific DCA: after-COVID  

res_aft_raw <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "aft", scheme = "raw"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 21000
)

res_aft_int <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "aft", scheme = "int"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 22000
)

res_aft_is <- dca_over_mi(
  pred_list = get_pred_list(data, phase = "aft", scheme = "is"),
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 23000
)

plot_dca_3schemes(
  res_aft_raw,
  res_aft_int,
  res_aft_is,
  main = "DCA: After-COVID validation | Random forest",
  ylim = c(-0.05, 0.20),
  file = file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_after_3schemes.pdf")
)

export_dca_3schemes(
  res_aft_raw,
  res_aft_int,
  res_aft_is,
  file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_after_3schemes_B500.csv")
)

#####  3. Time-separated recalibration DCA  
#####  Parameters estimated in during-COVID and evaluated in after-COVID 

make_time_separated_aft_pred_list <- function(data, model_name = "rf"){
  
  pred_raw_aft <- data$pred_raw_aft
  ab_df <- data$time_sep_ab_df
  
  if(is.null(pred_raw_aft)) stop("pred_raw_aft is absent from saved analysis results.")
  if(is.null(ab_df)) stop("time_sep_ab_df is absent from saved analysis results.")
  
  ab_df <- subset(ab_df, Model == model_name)
  
  pred_int_from_dur_aft <- vector("list", length(pred_raw_aft))
  pred_is_from_dur_aft  <- vector("list", length(pred_raw_aft))
  
  for(i in seq_along(pred_raw_aft)){
    
    one <- pred_raw_aft[[i]]
    if(is.null(one) || is.null(one$y) || is.null(one$p) || is.null(one$p[[model_name]])){
      next
    }
    
    ab_i <- subset(ab_df, Imputation == i)
    if(nrow(ab_i) != 1){
      next
    }
    
    p_raw <- clamp01(one$p[[model_name]])
    lp <- qlogis(p_raw)
    
    p_int <- plogis(ab_i$alpha_intercept_only + lp)
    p_is  <- plogis(ab_i$alpha_intercept_slope + ab_i$beta_intercept_slope * lp)
    
    pred_int_from_dur_aft[[i]] <- list(
      y = one$y,
      p = list(rf = p_int)
    )
    
    pred_is_from_dur_aft[[i]] <- list(
      y = one$y,
      p = list(rf = p_is)
    )
  }
  
  list(
    raw_after = pred_raw_aft,
    int_from_during_after = pred_int_from_dur_aft,
    is_from_during_after = pred_is_from_dur_aft
  )
}

ts_pred <- make_time_separated_aft_pred_list(data, model_name = "rf")

res_ts_raw <- dca_over_mi(
  pred_list = ts_pred$raw_after,
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 31000
)

res_ts_int <- dca_over_mi(
  pred_list = ts_pred$int_from_during_after,
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 32000
)

res_ts_is <- dca_over_mi(
  pred_list = ts_pred$is_from_during_after,
  model_name = "rf",
  thresholds = thresholds,
  B = 500,
  seed_base = 33000
)

plot_dca_3schemes(
  res_ts_raw,
  res_ts_int,
  res_ts_is,
  main = "DCA: Time-separated recalibration | RF after-COVID",
  ylim = c(-0.05, 0.20),
  file = file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_time_separated_after_3schemes.pdf")
)

export_dca_3schemes(
  res_ts_raw,
  res_ts_int,
  res_ts_is,
  file.path(project_dir, "IVIGR", "RF", "DCA", "DCA_RF_time_separated_after_3schemes_B500.csv")
)

#####  4. Quick check 

cat("\nDCA completed.\n")

cat("\nDuring-COVID DCA m_used:\n")
print(c(
  raw = res_dur_raw$m_used,
  int = res_dur_int$m_used,
  is  = res_dur_is$m_used
))

cat("\nAfter-COVID apparent DCA m_used:\n")
print(c(
  raw = res_aft_raw$m_used,
  int = res_aft_int$m_used,
  is  = res_aft_is$m_used
))

cat("\nAfter-COVID time-separated DCA m_used:\n")
print(c(
  raw = res_ts_raw$m_used,
  int_from_during = res_ts_int$m_used,
  is_from_during  = res_ts_is$m_used
))

cat("\nOutputs saved under:\n")
cat(file.path(project_dir, "IVIGR", "RF", "DCA"), "\n")

#####  RF with-center vs no-center sensitivity  #####

GLOBAL_SEED <- 123

try(
  RNGkind(kind = "Mersenne-Twister",
          normal.kind = "Inversion",
          sample.kind = "Rejection"),
  silent = TRUE
)

set.seed(GLOBAL_SEED)

Sys.setenv(
  OMP_NUM_THREADS = "1",
  MKL_NUM_THREADS = "1",
  OPENBLAS_NUM_THREADS = "1",
  VECLIB_MAXIMUM_THREADS = "1"
)

required_pkgs <- c(
  "mice", "pROC", "caret", "randomForest", "doParallel", "foreach"
)

missing_pkgs <- required_pkgs[!sapply(required_pkgs, requireNamespace, quietly = TRUE)]

if(length(missing_pkgs) > 0){
  stop(
    "Please install missing packages first: ",
    paste(missing_pkgs, collapse = ", ")
  )
}

suppressPackageStartupMessages({
  library(mice)
  library(pROC)
  library(caret)
  library(randomForest)
  library(doParallel)
  library(foreach)
})

dir.create(
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity"),
  recursive = TRUE,
  showWarnings = FALSE
)

cat("\nRF with-center vs no-center sensitivity started\n")

n_cores <- suppressWarnings(as.integer(Sys.getenv(
  "IVIGR_N_CORES",
  unset = as.character(max(1L, parallel::detectCores() - 2L))
)))
if(!is.finite(n_cores) || n_cores < 1L) n_cores <- 1L
cl <- parallel::makeCluster(n_cores)
doParallel::registerDoParallel(cl)
parallel_backend_created <- TRUE

# The parallel backend is closed explicitly at the end of this section.

cat("Parallel backend registered with", n_cores, "cores.\n")

#####  1. Load saved RF with-center results and imputation object

data <- readRDS(
  file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

imp <- readRDS(
  file.path(project_dir, "imp_byTime_m10.rds")
)

imp_bef <- imp$bef
imp_dur <- imp$dur
imp_aft <- imp$aft

outcome <- "IVIGR"

bin_cols <- c(
  "Cervical_Lymphadenopathy",
  "Rash",
  "Oral_Mucosal_Change",
  "Edema_of_the_Hands_and_Feet",
  "Conjunctival_Injection"
)

cont_cols <- c(
  "Age_months", "WBC", "Neu_percent", "Hb", "PLT",
  "AST", "ALT", "ALB", "CRP"
)

xvars_with_center <- c("Center", "Gender", cont_cols, bin_cols)
xvars_no_center   <- c("Gender", cont_cols, bin_cols)

models <- c("rf_no_center")
B_boot <- 500

cat("\nBootstrap resamples:", B_boot, "\n")

#####  2. Helper functions

as01_2to0 <- function(x){
  if(is.factor(x)) x <- as.character(x)
  x <- trimws(as.character(x))
  x_num <- suppressWarnings(as.integer(x))
  out <- rep(NA_integer_, length(x_num))
  out[x_num %in% c(0L, 2L)] <- 0L
  out[x_num == 1L] <- 1L
  out
}

drop_nzv <- function(train_df, xvars){
  keep <- sapply(xvars, function(v){
    if(!v %in% names(train_df)) return(FALSE)
    ux <- unique(train_df[[v]][!is.na(train_df[[v]])])
    length(ux) >= 2
  })
  xvars[keep]
}

eps <- 1e-6

clamp01 <- function(p){
  pmin(pmax(as.numeric(p), eps), 1 - eps)
}

metric_names_all <- c(
  "AUC", "Brier", "Cal_Int", "Cal_Slope", "OE",
  "Sens", "Spec", "PPV", "NPV", "F1", "Acc", "Threshold"
)

empty_metrics <- function(thr = NA_real_){
  out <- rep(NA_real_, length(metric_names_all))
  names(out) <- metric_names_all
  out["Threshold"] <- thr
  out
}

get_metrics <- function(y, p, thr){
  y <- as.integer(y == 1L)
  p <- as.numeric(p)
  
  ok <- !is.na(y) & !is.na(p)
  y <- y[ok]
  p <- clamp01(p[ok])
  
  if(length(y) == 0 || length(unique(y)) < 2){
    return(empty_metrics(thr))
  }
  
  aucv <- tryCatch(
    as.numeric(pROC::auc(pROC::roc(y, p, quiet = TRUE, direction = "<"))),
    error = function(e) NA_real_
  )
  
  brier <- mean((p - y)^2, na.rm = TRUE)
  
  lp <- qlogis(p)
  
  cal_fit <- tryCatch(
    suppressWarnings(glm(y ~ lp, family = binomial())),
    error = function(e) NULL
  )
  
  if(is.null(cal_fit)){
    cal_int <- NA_real_
    cal_slope <- NA_real_
  } else {
    co <- coef(cal_fit)
    cal_int <- unname(co[1])
    cal_slope <- unname(co[2])
  }
  
  O <- sum(y, na.rm = TRUE)
  E <- sum(p, na.rm = TRUE)
  OE <- ifelse(E > 0, O / E, NA_real_)
  
  pred <- as.integer(p >= thr)
  
  TP <- sum(pred == 1 & y == 1, na.rm = TRUE)
  TN <- sum(pred == 0 & y == 0, na.rm = TRUE)
  FP <- sum(pred == 1 & y == 0, na.rm = TRUE)
  FN <- sum(pred == 0 & y == 1, na.rm = TRUE)
  
  sens <- ifelse((TP + FN) > 0, TP / (TP + FN), NA_real_)
  spec <- ifelse((TN + FP) > 0, TN / (TN + FP), NA_real_)
  ppv  <- ifelse((TP + FP) > 0, TP / (TP + FP), NA_real_)
  npv  <- ifelse((TN + FN) > 0, TN / (TN + FN), NA_real_)
  acc  <- ifelse((TP + TN + FP + FN) > 0,
                 (TP + TN) / (TP + TN + FP + FN),
                 NA_real_)
  
  f1 <- if(!is.na(ppv) && !is.na(sens) && (ppv + sens) > 0){
    2 * ppv * sens / (ppv + sens)
  } else {
    NA_real_
  }
  
  c(
    AUC = aucv,
    Brier = brier,
    Cal_Int = cal_int,
    Cal_Slope = cal_slope,
    OE = OE,
    Sens = sens,
    Spec = spec,
    PPV = ppv,
    NPV = npv,
    F1 = f1,
    Acc = acc,
    Threshold = thr
  )
}

boot_metrics <- function(y, p, thr, B = 500, seed = 123){
  set.seed(seed)
  
  y <- as.integer(y == 1L)
  p <- clamp01(as.numeric(p))
  
  ok <- !is.na(y) & !is.na(p)
  y <- y[ok]
  p <- p[ok]
  
  n <- length(y)
  
  boot_mat <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(metric_names_all),
    dimnames = list(NULL, metric_names_all)
  )
  
  if(n == 0){
    return(as.data.frame(boot_mat))
  }
  
  for(b in seq_len(B)){
    idx <- sample(seq_len(n), size = n, replace = TRUE)
    y_b <- y[idx]
    p_b <- p[idx]
    
    if(length(unique(y_b)) < 2){
      boot_mat[b, ] <- empty_metrics(thr)
    } else {
      boot_mat[b, ] <- tryCatch(
        get_metrics(y_b, p_b, thr),
        error = function(e) empty_metrics(thr)
      )
    }
  }
  
  out <- as.data.frame(boot_mat)
  out$Bootstrap <- seq_len(B)
  out
}

add_boot_meta <- function(df, model, period, strategy, imputation){
  df$Model <- model
  df$Period <- period
  df$Strategy <- strategy
  df$Imputation <- imputation
  df
}

res_list_to_df <- function(res_list, strategy){
  out_list <- list()
  
  for(i in seq_along(res_list)){
    if(is.null(res_list[[i]])) next
    
    mat <- res_list[[i]]
    df <- as.data.frame(mat)
    df$Row <- rownames(mat)
    
    split_row <- strsplit(df$Row, "_")
    df$Period <- sapply(split_row, function(z) z[1])
    df$Model  <- sapply(split_row, function(z) paste(z[-1], collapse = "_"))
    df$Strategy <- strategy
    df$Imputation <- i
    
    rownames(df) <- NULL
    
    out_list[[length(out_list) + 1]] <- df
  }
  
  do.call(rbind, out_list)
}

make_summary_table <- function(point_df, boot_df,
                               group_cols,
                               metrics_show = c("AUC", "Brier", "Cal_Int", "Cal_Slope", "OE")){
  
  groups <- unique(point_df[, group_cols, drop = FALSE])
  out_list <- list()
  
  for(g in seq_len(nrow(groups))){
    group_now <- groups[g, , drop = FALSE]
    
    idx_point <- rep(TRUE, nrow(point_df))
    idx_boot <- rep(TRUE, nrow(boot_df))
    
    for(gc in group_cols){
      idx_point <- idx_point & point_df[[gc]] == group_now[[gc]][1]
      idx_boot  <- idx_boot  & boot_df[[gc]]  == group_now[[gc]][1]
    }
    
    for(metric in metrics_show){
      est <- mean(point_df[[metric]][idx_point], na.rm = TRUE)
      vals <- boot_df[[metric]][idx_boot]
      
      ci_l <- as.numeric(quantile(vals, 0.025, na.rm = TRUE))
      ci_u <- as.numeric(quantile(vals, 0.975, na.rm = TRUE))
      
      tmp <- data.frame(
        group_now,
        Metric = metric,
        Estimate = est,
        CI_L = ci_l,
        CI_U = ci_u,
        Formatted = sprintf("%.4f (%.4f to %.4f)", est, ci_l, ci_u),
        stringsAsFactors = FALSE
      )
      
      out_list[[length(out_list) + 1]] <- tmp
    }
  }
  
  do.call(rbind, out_list)
}

make_caret_seeds <- function(n_resamples = 10, tune_max, seed = 1){
  set.seed(seed)
  
  seeds <- vector("list", n_resamples + 1)
  
  for(j in seq_len(n_resamples)){
    seeds[[j]] <- sample.int(10000000, tune_max)
  }
  
  seeds[[n_resamples + 1]] <- sample.int(10000000, 1)
  seeds
}

make_fit_control <- function(seed, tune_max){
  caret::trainControl(
    method = "cv",
    number = 10,
    classProbs = TRUE,
    summaryFunction = caret::twoClassSummary,
    savePredictions = "final",
    allowParallel = TRUE,
    seeds = make_caret_seeds(n_resamples = 10, tune_max = tune_max, seed = seed)
  )
}

#####  3. Train RF without Center across imputations

m_use <- min(imp_bef$m, imp_dur$m, imp_aft$m)

cat("\nNumber of imputations used:", m_use, "\n")

res_no_center <- vector("list", m_use)
boot_no_center <- vector("list", m_use)

pred_no_center_dur <- vector("list", m_use)
pred_no_center_aft <- vector("list", m_use)

best_rf_no_center <- vector("list", m_use)
train_spec_no_center <- vector("list", m_use)

for(i in seq_len(m_use)){
  
  cat("\nRunning no-center RF, imputation", i, "of", m_use, "\n")
  
  set.seed(GLOBAL_SEED + 1000 + i)
  
  train <- mice::complete(imp_bef, i)
  dur   <- mice::complete(imp_dur, i)
  aft   <- mice::complete(imp_aft, i)
  
  train$Gender <- factor(train$Gender)
  dur$Gender   <- factor(dur$Gender, levels = levels(train$Gender))
  aft$Gender   <- factor(aft$Gender, levels = levels(train$Gender))
  
  for(v in bin_cols){
    if(v %in% names(train)) train[[v]] <- as01_2to0(train[[v]])
    if(v %in% names(dur))   dur[[v]]   <- as01_2to0(dur[[v]])
    if(v %in% names(aft))   aft[[v]]   <- as01_2to0(aft[[v]])
  }
  
  train[[outcome]] <- as01_2to0(train[[outcome]])
  dur[[outcome]]   <- as01_2to0(dur[[outcome]])
  aft[[outcome]]   <- as01_2to0(aft[[outcome]])
  
  xvars <- drop_nzv(train, xvars_no_center)
  
  keep_tr <- complete.cases(train[, xvars, drop = FALSE]) & !is.na(train[[outcome]])
  keep_du <- complete.cases(dur[,   xvars, drop = FALSE]) & !is.na(dur[[outcome]])
  keep_af <- complete.cases(aft[,   xvars, drop = FALSE]) & !is.na(aft[[outcome]])
  
  train <- train[keep_tr, , drop = FALSE]
  dur   <- dur[keep_du,   , drop = FALSE]
  aft   <- aft[keep_af,   , drop = FALSE]
  
  if(nrow(train) < 80 || nrow(dur) < 40 || nrow(aft) < 40){
    cat("[SKIP] Too small sample after filtering in imputation", i, "\n")
    next
  }
  
  if(length(unique(train[[outcome]])) < 2 ||
     length(unique(dur[[outcome]]))   < 2 ||
     length(unique(aft[[outcome]]))   < 2){
    cat("[SKIP] Outcome has only one class in imputation", i, "\n")
    next
  }
  
  thr_i <- mean(train[[outcome]] == 1, na.rm = TRUE)
  thr_i <- pmin(pmax(thr_i, 0.01), 0.99)
  
  cat("n train =", nrow(train),
      "; n during =", nrow(dur),
      "; n after =", nrow(aft),
      "; train event rate =", round(thr_i, 4), "\n")
  
  train_c <- train[, c(outcome, xvars), drop = FALSE]
  dur_c   <- dur[,   c(outcome, xvars), drop = FALSE]
  aft_c   <- aft[,   c(outcome, xvars), drop = FALSE]
  
  train_c[[outcome]] <- factor(
    ifelse(train_c[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  dur_c[[outcome]] <- factor(
    ifelse(dur_c[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  aft_c[[outcome]] <- factor(
    ifelse(aft_c[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  y_du <- as.integer(dur_c[[outcome]] == "Yes")
  y_af <- as.integer(aft_c[[outcome]] == "Yes")
  
  p_eff <- ncol(model.matrix(
    as.formula(paste("~", paste(xvars, collapse = "+"), "-1")),
    data = train_c
  ))
  
  mtry_max <- min(p_eff, max(2, floor(sqrt(p_eff)) * 2))
  
  rf_grid <- expand.grid(
    mtry = unique(pmin(seq(2, mtry_max, by = 2), p_eff))
  )
  
  fitControl_rf <- make_fit_control(
    seed = GLOBAL_SEED + 5000 + i,
    tune_max = nrow(rf_grid)
  )
  
  set.seed(GLOBAL_SEED + 6000 + i)
  
  rf_fit_no_center <- caret::train(
    as.formula(paste(outcome, "~", paste(xvars, collapse = "+"))),
    data = train_c,
    method = "rf",
    metric = "ROC",
    trControl = fitControl_rf,
    tuneGrid = rf_grid,
    ntree = 500
  )
  
  best_rf_no_center[[i]] <- rf_fit_no_center$bestTune
  
  p_du_rf <- predict(rf_fit_no_center, newdata = dur_c, type = "prob")[, "Yes"]
  p_af_rf <- predict(rf_fit_no_center, newdata = aft_c, type = "prob")[, "Yes"]
  
  pred_no_center_dur[[i]] <- list(
    y = y_du,
    p = list(rf_no_center = p_du_rf)
  )
  
  pred_no_center_aft[[i]] <- list(
    y = y_af,
    p = list(rf_no_center = p_af_rf)
  )
  
  res_no_center[[i]] <- rbind(
    dur_rf_no_center = get_metrics(y_du, p_du_rf, thr_i),
    aft_rf_no_center = get_metrics(y_af, p_af_rf, thr_i)
  )
  
  boot_du <- boot_metrics(
    y = y_du,
    p = p_du_rf,
    thr = thr_i,
    B = B_boot,
    seed = GLOBAL_SEED + 200000 + i * 1000 + 1
  )
  
  boot_du <- add_boot_meta(
    boot_du,
    model = "rf_no_center",
    period = "dur",
    strategy = "raw",
    imputation = i
  )
  
  boot_af <- boot_metrics(
    y = y_af,
    p = p_af_rf,
    thr = thr_i,
    B = B_boot,
    seed = GLOBAL_SEED + 200000 + i * 1000 + 2
  )
  
  boot_af <- add_boot_meta(
    boot_af,
    model = "rf_no_center",
    period = "aft",
    strategy = "raw",
    imputation = i
  )
  
  boot_no_center[[i]] <- rbind(boot_du, boot_af)
  
  train_spec_no_center[[i]] <- list(
    outcome = outcome,
    xvars = xvars,
    n_train = nrow(train_c),
    n_dur = nrow(dur_c),
    n_aft = nrow(aft_c),
    event_train = sum(train_c[[outcome]] == "Yes"),
    event_dur = sum(dur_c[[outcome]] == "Yes"),
    event_aft = sum(aft_c[[outcome]] == "Yes"),
    event_rate_train = mean(train_c[[outcome]] == "Yes"),
    best_mtry = rf_fit_no_center$bestTune$mtry,
    ntree = 500
  )
  
  cat("Completed no-center RF, imputation", i, "\n")
}

#####  4. Summarize no-center RF

phase_no_center_point_df <- res_list_to_df(
  res_no_center,
  strategy = "raw"
)

phase_no_center_boot_df <- do.call(
  rbind,
  boot_no_center[!sapply(boot_no_center, is.null)]
)

metrics_show <- c("AUC", "Brier", "Cal_Int", "Cal_Slope", "OE")

phase_no_center_summary <- make_summary_table(
  point_df = phase_no_center_point_df,
  boot_df = phase_no_center_boot_df,
  group_cols = c("Model", "Period", "Strategy"),
  metrics_show = metrics_show
)

cat("\nNo-center RF summary:\n")
print(
  phase_no_center_summary[
    order(phase_no_center_summary$Period,
          phase_no_center_summary$Metric),
  ],
  row.names = FALSE
)

#####  5. Extract existing with-center RF results

phase_with_center_summary <- subset(
  data$phase_summary,
  Model == "rf" & Strategy == "raw" & Metric %in% metrics_show
)

phase_with_center_point_df <- subset(
  data$phase_point_df,
  Model == "rf" & Strategy == "raw"
)

phase_with_center_summary$Model_Spec <- "RF with Center"
phase_no_center_summary$Model_Spec <- "RF without Center"

combined_summary <- rbind(
  phase_with_center_summary[, c(
    "Model_Spec", "Model", "Period", "Strategy",
    "Metric", "Estimate", "CI_L", "CI_U", "Formatted"
  )],
  phase_no_center_summary[, c(
    "Model_Spec", "Model", "Period", "Strategy",
    "Metric", "Estimate", "CI_L", "CI_U", "Formatted"
  )]
)

combined_summary <- combined_summary[
  order(combined_summary$Period,
        combined_summary$Metric,
        combined_summary$Model_Spec),
]

cat("\nCombined with-center vs no-center RF summary:\n")
print(combined_summary, row.names = FALSE)

#####  6. Delta table: no-center minus with-center

with_tmp <- phase_with_center_summary[, c("Period", "Metric", "Estimate")]
names(with_tmp)[3] <- "Estimate_with_center"

no_tmp <- phase_no_center_summary[, c("Period", "Metric", "Estimate")]
names(no_tmp)[3] <- "Estimate_no_center"

delta_summary <- merge(
  with_tmp,
  no_tmp,
  by = c("Period", "Metric"),
  all = TRUE
)

delta_summary$Delta_no_center_minus_with_center <-
  delta_summary$Estimate_no_center - delta_summary$Estimate_with_center

delta_summary <- delta_summary[
  order(delta_summary$Period,
        delta_summary$Metric),
]

cat("\nDelta summary: no-center minus with-center\n")
print(delta_summary, row.names = FALSE)

#####  7. RF tuning summary for no-center model

rf_no_center_tune_df <- do.call(
  rbind,
  lapply(seq_along(best_rf_no_center), function(i){
    if(is.null(best_rf_no_center[[i]])) return(NULL)
    data.frame(
      Imputation = i,
      mtry = best_rf_no_center[[i]]$mtry
    )
  })
)

rf_no_center_tune_frequency <- as.data.frame(
  table(rf_no_center_tune_df$mtry)
)

names(rf_no_center_tune_frequency) <- c("mtry", "frequency")

cat("\nNo-center RF best mtry by imputation:\n")
print(rf_no_center_tune_df)

cat("\nNo-center RF mtry frequency:\n")
print(rf_no_center_tune_frequency)

#####  8. Save outputs

write.csv(
  phase_no_center_point_df,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_no_center_point_estimates_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  phase_no_center_boot_df,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_no_center_bootstrap_B500_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  phase_no_center_summary,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_no_center_summary_B500.csv"),
  row.names = FALSE
)

write.csv(
  phase_with_center_summary,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_with_center_summary_extracted.csv"),
  row.names = FALSE
)

write.csv(
  combined_summary,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_with_vs_without_center_summary_B500.csv"),
  row.names = FALSE
)

write.csv(
  delta_summary,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_with_vs_without_center_delta.csv"),
  row.names = FALSE
)

write.csv(
  rf_no_center_tune_df,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_no_center_best_mtry_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  rf_no_center_tune_frequency,
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_no_center_mtry_frequency.csv"),
  row.names = FALSE
)

saveRDS(
  list(
    reproducibility = list(
      GLOBAL_SEED = GLOBAL_SEED,
      B_boot = B_boot,
      ntree = 500,
      analysis = "RF without Center sensitivity; with-center RF extracted from saved RDS"
    ),
    pred_no_center_dur = pred_no_center_dur,
    pred_no_center_aft = pred_no_center_aft,
    res_no_center = res_no_center,
    phase_no_center_point_df = phase_no_center_point_df,
    phase_no_center_boot_df = phase_no_center_boot_df,
    phase_no_center_summary = phase_no_center_summary,
    phase_with_center_summary = phase_with_center_summary,
    combined_summary = combined_summary,
    delta_summary = delta_summary,
    best_rf_no_center = best_rf_no_center,
    rf_no_center_tune_df = rf_no_center_tune_df,
    rf_no_center_tune_frequency = rf_no_center_tune_frequency,
    train_spec_no_center = train_spec_no_center
  ),
  file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "rf_with_vs_without_center_sensitivity_outputs.rds"),
  compress = "xz"
)

writeLines(
  capture.output(sessionInfo()),
  con = file.path(project_dir, "IVIGR", "RF", "CenterSensitivity", "sessionInfo_rf_center_sensitivity.txt")
)

cat("\nRF with-center vs no-center sensitivity completed.\n")
cat("Outputs saved under:\n")
cat(file.path(project_dir, "IVIGR", "RF", "CenterSensitivity"), "\n")

if(exists("parallel_backend_created") && isTRUE(parallel_backend_created)){
  parallel::stopCluster(cl)
  foreach::registerDoSEQ()
  parallel_backend_created <- FALSE
  cat("\nParallel backend stopped.\n")
}

#####  Annual updating under multiple imputation: RF model  #####

GLOBAL_SEED <- 123
set.seed(GLOBAL_SEED)

required_pkgs <- c("mice", "randomForest", "pROC")

missing_pkgs <- required_pkgs[!sapply(required_pkgs, requireNamespace, quietly = TRUE)]
if(length(missing_pkgs) > 0){
  stop("Please install missing packages first: ", paste(missing_pkgs, collapse = ", "))
}

suppressPackageStartupMessages({
  library(mice)
  library(randomForest)
  library(pROC)
})

dir.create(
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating"),
  recursive = TRUE,
  showWarnings = FALSE
)

#####  1. Load MI data and primary RF tuning

imp <- readRDS(
  file.path(project_dir, "imp_byTime_m10.rds")
)

primary <- readRDS(
  file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

#####  Add Year back from corrected original data

alldata_year <- read.csv(
  file.path(project_dir, "alldata.csv"),
  fileEncoding = "GBK",
  header = TRUE,
  stringsAsFactors = FALSE
)

if(!"Year" %in% names(alldata_year)){
  alldata_year$Admission_Date <- as.Date(
    alldata_year$Admission_Date,
    tryFormats = c("%Y/%m/%d", "%Y-%m-%d")
  )
  alldata_year$Year <- as.integer(format(alldata_year$Admission_Date, "%Y"))
}

dat_bef_year <- subset(alldata_year, Time == "Before_COVID")
dat_dur_year <- subset(alldata_year, Time == "During_COVID")
dat_aft_year <- subset(alldata_year, Time == "After_COVID")

stopifnot(nrow(dat_bef_year) == nrow(imp$bef$data))
stopifnot(nrow(dat_dur_year) == nrow(imp$dur$data))
stopifnot(nrow(dat_aft_year) == nrow(imp$aft$data))

cat("\nYear added from alldata.csv.\n")
cat("Before:", nrow(dat_bef_year), "\n")
cat("During:", nrow(dat_dur_year), "\n")
cat("After:", nrow(dat_aft_year), "\n")

outcome <- "IVIGR"

bin_cols <- c(
  "Cervical_Lymphadenopathy",
  "Rash",
  "Oral_Mucosal_Change",
  "Edema_of_the_Hands_and_Feet",
  "Conjunctival_Injection"
)

cont_cols <- c(
  "Age_months", "WBC", "Neu_percent", "Hb", "PLT",
  "AST", "ALT", "ALB", "CRP"
)

xvars_base <- c("Center", "Gender", cont_cols, bin_cols)

years <- 2015:2024
B_boot <- 500
ntree_use <- 500

if(!is.null(primary$rf_tune_df)){
  fixed_mtry <- round(median(as.numeric(primary$rf_tune_df$mtry), na.rm = TRUE))
} else {
  fixed_mtry <- 4
}

cat("\nFixed RF mtry used for annual updating:", fixed_mtry, "\n")

#####  2. Helper functions

as01_2to0 <- function(x){
  if(is.factor(x)) x <- as.character(x)
  x <- trimws(as.character(x))
  x_num <- suppressWarnings(as.integer(x))
  out <- rep(NA_integer_, length(x_num))
  out[x_num %in% c(0L, 2L)] <- 0L
  out[x_num == 1L] <- 1L
  out
}

eps <- 1e-6

clamp01 <- function(p){
  pmin(pmax(as.numeric(p), eps), 1 - eps)
}

drop_nzv <- function(train_df, xvars){
  keep <- sapply(xvars, function(v){
    if(!v %in% names(train_df)) return(FALSE)
    ux <- unique(train_df[[v]][!is.na(train_df[[v]])])
    length(ux) >= 2
  })
  xvars[keep]
}

metric_names <- c("AUC", "Brier", "Cal_Int", "Cal_Slope", "OE")

empty_metrics <- function(){
  out <- rep(NA_real_, length(metric_names))
  names(out) <- metric_names
  out
}

get_metrics <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  if(length(y) < 20 || length(unique(y)) < 2){
    return(empty_metrics())
  }
  
  aucv <- tryCatch(
    as.numeric(pROC::auc(pROC::roc(y, p, quiet = TRUE, direction = "<"))),
    error = function(e) NA_real_
  )
  
  brier <- mean((p - y)^2)
  
  lp <- qlogis(p)
  
  cal_fit <- tryCatch(
    suppressWarnings(glm(y ~ lp, family = binomial())),
    error = function(e) NULL
  )
  
  if(is.null(cal_fit)){
    cal_int <- NA_real_
    cal_slope <- NA_real_
  } else {
    co <- coef(cal_fit)
    cal_int <- unname(co[1])
    cal_slope <- unname(co[2])
  }
  
  O <- sum(y == 1)
  E <- sum(p)
  OE <- ifelse(E > 0, O / E, NA_real_)
  
  c(
    AUC = aucv,
    Brier = brier,
    Cal_Int = cal_int,
    Cal_Slope = cal_slope,
    OE = OE
  )
}

boot_metrics <- function(y, p, B = 500, seed = 123){
  set.seed(seed)
  
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  n <- length(y)
  
  boot_mat <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(metric_names),
    dimnames = list(NULL, metric_names)
  )
  
  if(n == 0){
    return(as.data.frame(boot_mat))
  }
  
  for(b in seq_len(B)){
    idx <- sample(seq_len(n), size = n, replace = TRUE)
    boot_mat[b, ] <- tryCatch(
      get_metrics(y[idx], p[idx]),
      error = function(e) empty_metrics()
    )
  }
  
  out <- as.data.frame(boot_mat)
  out$Bootstrap <- seq_len(B)
  out
}

fit_alpha <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  lp <- qlogis(p)
  fit <- suppressWarnings(glm(y ~ 1 + offset(lp), family = binomial()))
  unname(coef(fit)[1])
}

fit_alpha_beta <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  lp <- qlogis(p)
  fit <- suppressWarnings(glm(y ~ lp, family = binomial()))
  co <- coef(fit)
  c(alpha = unname(co[1]), beta = unname(co[2]))
}

apply_alpha <- function(p, alpha){
  lp <- qlogis(clamp01(p))
  plogis(alpha + lp)
}

apply_alpha_beta <- function(p, alpha, beta){
  lp <- qlogis(clamp01(p))
  plogis(alpha + beta * lp)
}

prepare_dat <- function(dat, centers_all){
  dat[[outcome]] <- as01_2to0(dat[[outcome]])
  
  for(v in bin_cols){
    if(v %in% names(dat)){
      dat[[v]] <- as01_2to0(dat[[v]])
    }
  }
  
  if(!"Year" %in% names(dat)){
    stop("Year is missing. Please add Year before prepare_dat().")
  }
  
  dat$Year <- as.integer(dat$Year)
  dat$Center <- factor(dat$Center, levels = centers_all)
  dat$Gender <- factor(dat$Gender)
  
  dat
}

fit_rf_model <- function(train_dat, xvars, fixed_mtry){
  
  xvars <- drop_nzv(train_dat, xvars)
  
  train_dat <- train_dat[
    complete.cases(train_dat[, c(outcome, xvars), drop = FALSE]),
    c(outcome, xvars),
    drop = FALSE
  ]
  
  if(nrow(train_dat) < 80){
    return(NULL)
  }
  
  if(length(unique(train_dat[[outcome]])) < 2){
    return(NULL)
  }
  
  train_dat[[outcome]] <- factor(
    ifelse(train_dat[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  p_eff <- ncol(model.matrix(
    as.formula(paste("~", paste(xvars, collapse = "+"), "-1")),
    data = train_dat
  ))
  
  mtry_use <- max(1, min(fixed_mtry, p_eff))
  
  rf_fit <- randomForest::randomForest(
    as.formula(paste(outcome, "~", paste(xvars, collapse = "+"))),
    data = train_dat,
    ntree = ntree_use,
    mtry = mtry_use
  )
  
  list(
    fit = rf_fit,
    xvars = xvars,
    mtry = mtry_use,
    n_train = nrow(train_dat),
    events_train = sum(train_dat[[outcome]] == "Yes")
  )
}

predict_rf_model <- function(model_obj, test_dat){
  
  if(is.null(model_obj)){
    return(NULL)
  }
  
  xvars <- model_obj$xvars
  
  test_dat <- test_dat[
    complete.cases(test_dat[, c(outcome, xvars), drop = FALSE]),
    c(outcome, xvars),
    drop = FALSE
  ]
  
  if(nrow(test_dat) < 30){
    return(NULL)
  }
  
  y_test <- as.integer(test_dat[[outcome]] == 1)
  
  if(length(unique(y_test)) < 2){
    return(NULL)
  }
  
  test_dat[[outcome]] <- factor(
    ifelse(test_dat[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  p_test <- predict(model_obj$fit, newdata = test_dat, type = "prob")[, "Yes"]
  
  list(
    y = y_test,
    p = clamp01(p_test),
    n_test = nrow(test_dat),
    events_test = sum(y_test == 1)
  )
}

make_point_row <- function(imputation, year, strategy, met){
  data.frame(
    Imputation = imputation,
    Year = year,
    Strategy = strategy,
    AUC = unname(met["AUC"]),
    Brier = unname(met["Brier"]),
    Cal_Int = unname(met["Cal_Int"]),
    Cal_Slope = unname(met["Cal_Slope"]),
    OE = unname(met["OE"]),
    stringsAsFactors = FALSE
  )
}

make_summary <- function(point_df, boot_df){
  
  groups <- unique(point_df[, c("Year", "Strategy"), drop = FALSE])
  out_list <- list()
  
  for(i in seq_len(nrow(groups))){
    
    yr <- groups$Year[i]
    st <- groups$Strategy[i]
    
    idx_p <- point_df$Year == yr & point_df$Strategy == st
    idx_b <- boot_df$Year == yr & boot_df$Strategy == st
    
    for(m in metric_names){
      
      est <- mean(point_df[[m]][idx_p], na.rm = TRUE)
      ci_l <- as.numeric(quantile(boot_df[[m]][idx_b], 0.025, na.rm = TRUE))
      ci_u <- as.numeric(quantile(boot_df[[m]][idx_b], 0.975, na.rm = TRUE))
      
      out_list[[length(out_list) + 1]] <- data.frame(
        Year = yr,
        Strategy = st,
        Metric = m,
        Estimate = est,
        CI_L = ci_l,
        CI_U = ci_u,
        Formatted = sprintf("%.4f (%.4f to %.4f)", est, ci_l, ci_u),
        stringsAsFactors = FALSE
      )
    }
  }
  
  do.call(rbind, out_list)
}

rbind_fill <- function(lst){
  lst <- lst[!sapply(lst, is.null)]
  if(length(lst) == 0) return(data.frame())
  
  all_names <- unique(unlist(lapply(lst, names)))
  
  lst2 <- lapply(lst, function(x){
    miss <- setdiff(all_names, names(x))
    if(length(miss) > 0){
      for(m in miss){
        x[[m]] <- NA
      }
    }
    x[, all_names, drop = FALSE]
  })
  
  do.call(rbind, lst2)
}

#####  3. Annual RF updating across imputations

m_use <- min(imp$bef$m, imp$dur$m, imp$aft$m)

centers_all <- sort(unique(c(
  as.character(imp$bef$data$Center),
  as.character(imp$dur$data$Center),
  as.character(imp$aft$data$Center)
)))

point_list <- list()
boot_list <- list()
detail_list <- list()

for(i in seq_len(m_use)){
  
  cat("\nRunning imputation", i, "of", m_use, "\n")
  
  dat_bef_i <- mice::complete(imp$bef, i)
  dat_dur_i <- mice::complete(imp$dur, i)
  dat_aft_i <- mice::complete(imp$aft, i)
  
  dat_bef_i$Year <- dat_bef_year$Year
  dat_dur_i$Year <- dat_dur_year$Year
  dat_aft_i$Year <- dat_aft_year$Year
  
  dat_i <- rbind(
    dat_bef_i,
    dat_dur_i,
    dat_aft_i
  )
  
  dat_i <- prepare_dat(dat_i, centers_all = centers_all)
  
  for(yr in years){
    
    cat("  Year", yr, "\n")
    
    test_dat <- dat_i[dat_i$Year == yr, , drop = FALSE]
    
    if(nrow(test_dat) < 30){
      next
    }
    
    ##### Strategy 1: cumulative refitting using all historical data #####
    
    train_hist <- dat_i[dat_i$Year < yr, , drop = FALSE]
    
    set.seed(GLOBAL_SEED + i * 10000 + yr * 100 + 1)
    
    model_cum <- tryCatch(
      fit_rf_model(
        train_dat = train_hist,
        xvars = xvars_base,
        fixed_mtry = fixed_mtry
      ),
      error = function(e) NULL
    )
    
    pred_cum <- tryCatch(
      predict_rf_model(
        model_obj = model_cum,
        test_dat = test_dat
      ),
      error = function(e) NULL
    )
    
    if(!is.null(model_cum) && !is.null(pred_cum)){
      
      met <- get_metrics(pred_cum$y, pred_cum$p)
      
      point_list[[length(point_list) + 1]] <- make_point_row(
        imputation = i,
        year = yr,
        strategy = "all_history",
        met = met
      )
      
      boot_tmp <- boot_metrics(
        y = pred_cum$y,
        p = pred_cum$p,
        B = B_boot,
        seed = GLOBAL_SEED + i * 10000 + yr * 10 + 1
      )
      
      boot_tmp$Imputation <- i
      boot_tmp$Year <- yr
      boot_tmp$Strategy <- "all_history"
      
      boot_list[[length(boot_list) + 1]] <- boot_tmp
      
      detail_list[[length(detail_list) + 1]] <- data.frame(
        Imputation = i,
        Year = yr,
        Strategy = "all_history",
        train_from = min(train_hist$Year, na.rm = TRUE),
        train_to = max(train_hist$Year, na.rm = TRUE),
        train_n = model_cum$n_train,
        train_events = model_cum$events_train,
        test_n = pred_cum$n_test,
        test_events = pred_cum$events_test,
        mtry = model_cum$mtry,
        ntree = ntree_use,
        stringsAsFactors = FALSE
      )
    }
    
    ##### Strategy 2 and 3: prior-year recalibration #####
    ##### Fit base RF before previous year, estimate recalibration in previous year, evaluate in target year #####
    
    prev_year <- yr - 1
    
    train_pre_prev <- dat_i[dat_i$Year < prev_year, , drop = FALSE]
    calib_prev <- dat_i[dat_i$Year == prev_year, , drop = FALSE]
    
    if(nrow(train_pre_prev) >= 80 && nrow(calib_prev) >= 30){
      
      model_old <- tryCatch(
        fit_rf_model(
          train_dat = train_pre_prev,
          xvars = xvars_base,
          fixed_mtry = fixed_mtry
        ),
        error = function(e) NULL
      )
      
      pred_calib <- tryCatch(
        predict_rf_model(
          model_obj = model_old,
          test_dat = calib_prev
        ),
        error = function(e) NULL
      )
      
      pred_test_old <- tryCatch(
        predict_rf_model(
          model_obj = model_old,
          test_dat = test_dat
        ),
        error = function(e) NULL
      )
      
      if(!is.null(model_old) && !is.null(pred_calib) && !is.null(pred_test_old)){
        
        alpha_prev <- tryCatch(
          fit_alpha(pred_calib$y, pred_calib$p),
          error = function(e) NA_real_
        )
        
        ab_prev <- tryCatch(
          fit_alpha_beta(pred_calib$y, pred_calib$p),
          error = function(e) c(alpha = NA_real_, beta = NA_real_)
        )
        
        p_int <- apply_alpha(pred_test_old$p, alpha_prev)
        p_is  <- apply_alpha_beta(pred_test_old$p, ab_prev["alpha"], ab_prev["beta"])
        
        for(st in c("prior_year_intercept", "prior_year_intercept_slope")){
          
          p_now <- if(st == "prior_year_intercept") p_int else p_is
          
          met <- get_metrics(pred_test_old$y, p_now)
          
          point_list[[length(point_list) + 1]] <- make_point_row(
            imputation = i,
            year = yr,
            strategy = st,
            met = met
          )
          
          boot_tmp <- boot_metrics(
            y = pred_test_old$y,
            p = p_now,
            B = B_boot,
            seed = GLOBAL_SEED + i * 10000 + yr * 10 + ifelse(st == "prior_year_intercept", 2, 3)
          )
          
          boot_tmp$Imputation <- i
          boot_tmp$Year <- yr
          boot_tmp$Strategy <- st
          
          boot_list[[length(boot_list) + 1]] <- boot_tmp
          
          detail_list[[length(detail_list) + 1]] <- data.frame(
            Imputation = i,
            Year = yr,
            Strategy = st,
            train_from = min(train_pre_prev$Year, na.rm = TRUE),
            train_to = max(train_pre_prev$Year, na.rm = TRUE),
            calibration_year = prev_year,
            train_n = model_old$n_train,
            train_events = model_old$events_train,
            calibration_n = pred_calib$n_test,
            calibration_events = pred_calib$events_test,
            test_n = pred_test_old$n_test,
            test_events = pred_test_old$events_test,
            alpha = alpha_prev,
            beta = ab_prev["beta"],
            mtry = model_old$mtry,
            ntree = ntree_use,
            stringsAsFactors = FALSE
          )
        }
      }
    }
  }
}

annual_point_df <- rbind_fill(point_list)
annual_boot_df <- rbind_fill(boot_list)
annual_detail_df <- rbind_fill(detail_list)

annual_summary <- make_summary(
  point_df = annual_point_df,
  boot_df = annual_boot_df
)

annual_summary <- annual_summary[
  order(annual_summary$Year, annual_summary$Strategy, annual_summary$Metric),
]

#####  4. Save outputs

write.csv(
  annual_point_df,
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "annual_rf_mi_point_estimates_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  annual_boot_df,
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "annual_rf_mi_bootstrap_B500.csv"),
  row.names = FALSE
)

write.csv(
  annual_summary,
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "annual_rf_mi_summary_B500.csv"),
  row.names = FALSE
)

write.csv(
  annual_detail_df,
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "annual_rf_mi_model_detail.csv"),
  row.names = FALSE
)

saveRDS(
  list(
    annual_point_df = annual_point_df,
    annual_boot_df = annual_boot_df,
    annual_summary = annual_summary,
    annual_detail_df = annual_detail_df,
    fixed_mtry = fixed_mtry,
    ntree = ntree_use,
    B_boot = B_boot,
    years = years
  ),
  file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "annual_rf_mi_updating_outputs.rds"),
  compress = "xz"
)

writeLines(
  capture.output(sessionInfo()),
  con = file.path(project_dir, "IVIGR", "RF", "AnnualUpdating", "sessionInfo_annual_rf_mi_updating.txt")
)

#####  5. Quick check

cat("\nAnnual RF MI updating completed.\n")
cat("Outputs saved under:\n")
cat(file.path(project_dir, "IVIGR", "RF", "AnnualUpdating"), "\n")

cat("\nAnnual summary:\n")
print(annual_summary, row.names = FALSE)

#####  Half-life weighted RF updating under multiple imputation  #####
GLOBAL_SEED <- 123

try(
  RNGkind(
    kind = "Mersenne-Twister",
    normal.kind = "Inversion",
    sample.kind = "Rejection"
  ),
  silent = TRUE
)

set.seed(GLOBAL_SEED)

Sys.setenv(
  OMP_NUM_THREADS = "1",
  MKL_NUM_THREADS = "1",
  OPENBLAS_NUM_THREADS = "1",
  VECLIB_MAXIMUM_THREADS = "1"
)

required_pkgs <- c("mice", "randomForest", "pROC")

missing_pkgs <- required_pkgs[!sapply(required_pkgs, requireNamespace, quietly = TRUE)]

if(length(missing_pkgs) > 0){
  stop(
    "Please install missing packages first: ",
    paste(missing_pkgs, collapse = ", ")
  )
}

suppressPackageStartupMessages({
  library(mice)
  library(randomForest)
  library(pROC)
})

dir.create(
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating"),
  recursive = TRUE,
  showWarnings = FALSE
)

cat("\nHalf-life weighted RF updating under multiple imputation started.\n")
cat("RF engine: randomForest\n")
cat("Half-life implementation: weighted resampling\n")

#####  1. Load MI data and primary RF tuning

imp <- readRDS(
  file.path(project_dir, "imp_byTime_m10.rds")
)

primary <- readRDS(
  file.path(project_dir, "reviewer_recalibration_outputs", "IVIGR_mi_recalibration_reviewer_B500_reproducible_multicore.rds")
)

#####  2. Add Year back from corrected original data

alldata_year <- read.csv(
  file.path(project_dir, "alldata.csv"),
  fileEncoding = "GBK",
  header = TRUE,
  stringsAsFactors = FALSE
)

if(!"Year" %in% names(alldata_year)){
  alldata_year$Admission_Date <- as.Date(
    alldata_year$Admission_Date,
    tryFormats = c("%Y/%m/%d", "%Y-%m-%d")
  )
  
  alldata_year$Year <- as.integer(
    format(alldata_year$Admission_Date, "%Y")
  )
}

dat_bef_year <- subset(alldata_year, Time == "Before_COVID")
dat_dur_year <- subset(alldata_year, Time == "During_COVID")
dat_aft_year <- subset(alldata_year, Time == "After_COVID")

stopifnot(nrow(dat_bef_year) == nrow(imp$bef$data))
stopifnot(nrow(dat_dur_year) == nrow(imp$dur$data))
stopifnot(nrow(dat_aft_year) == nrow(imp$aft$data))

cat("\nYear added from alldata.csv.\n")
cat("Before:", nrow(dat_bef_year), "\n")
cat("During:", nrow(dat_dur_year), "\n")
cat("After:", nrow(dat_aft_year), "\n")

#####  3. Analysis settings

outcome <- "IVIGR"

bin_cols <- c(
  "Cervical_Lymphadenopathy",
  "Rash",
  "Oral_Mucosal_Change",
  "Edema_of_the_Hands_and_Feet",
  "Conjunctival_Injection"
)

cont_cols <- c(
  "Age_months",
  "WBC",
  "Neu_percent",
  "Hb",
  "PLT",
  "AST",
  "ALT",
  "ALB",
  "CRP"
)

xvars_base <- c(
  "Center",
  "Gender",
  cont_cols,
  bin_cols
)

xvars_calendar <- c(
  "Year",
  xvars_base
)

years <- 2015:2024
B_boot <- 500
ntree_use <- 500

if(!is.null(primary$rf_tune_df)){
  fixed_mtry <- round(
    median(as.numeric(primary$rf_tune_df$mtry), na.rm = TRUE)
  )
} else {
  fixed_mtry <- 4
}

cat("\nFixed RF mtry:", fixed_mtry, "\n")

schemes <- data.frame(
  Strategy = c(
    "all_history",
    paste0("half_life_", 1:6, "y"),
    "rolling_3y",
    "rolling_5y",
    "calendar_year_adjusted"
  ),
  Scheme_Type = c(
    "all_history",
    rep("half_life", 6),
    "rolling",
    "rolling",
    "calendar_year_adjusted"
  ),
  Scheme_Parameter = c(
    "all_history",
    paste0("half_life_", 1:6, "y"),
    "rolling_3y",
    "rolling_5y",
    "Year_as_predictor"
  ),
  Half_Life = c(
    NA,
    1:6,
    NA,
    NA,
    NA
  ),
  Rolling_Window = c(
    NA,
    rep(NA, 6),
    3,
    5,
    NA
  ),
  Use_Year_As_Predictor = c(
    FALSE,
    rep(FALSE, 6),
    FALSE,
    FALSE,
    TRUE
  ),
  Use_Weighted_Resampling = c(
    FALSE,
    rep(TRUE, 6),
    FALSE,
    FALSE,
    FALSE
  ),
  stringsAsFactors = FALSE
)

cat("\nStrategies included:\n")
print(schemes)

#####  4. Helper functions

as01_2to0 <- function(x){
  if(is.factor(x)) x <- as.character(x)
  x <- trimws(as.character(x))
  x_num <- suppressWarnings(as.integer(x))
  
  out <- rep(NA_integer_, length(x_num))
  out[x_num %in% c(0L, 2L)] <- 0L
  out[x_num == 1L] <- 1L
  
  out
}

eps <- 1e-6

clamp01 <- function(p){
  pmin(pmax(as.numeric(p), eps), 1 - eps)
}

drop_nzv <- function(train_df, xvars){
  keep <- sapply(xvars, function(v){
    if(!v %in% names(train_df)) return(FALSE)
    ux <- unique(train_df[[v]][!is.na(train_df[[v]])])
    length(ux) >= 2
  })
  
  xvars[keep]
}

metric_names <- c(
  "AUC",
  "Brier",
  "Cal_Int",
  "Cal_Slope",
  "OE"
)

empty_metrics <- function(){
  out <- rep(NA_real_, length(metric_names))
  names(out) <- metric_names
  out
}

get_metrics <- function(y, p){
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  if(length(y) < 20 || length(unique(y)) < 2){
    return(empty_metrics())
  }
  
  aucv <- tryCatch(
    as.numeric(
      pROC::auc(
        pROC::roc(
          y,
          p,
          quiet = TRUE,
          direction = "<"
        )
      )
    ),
    error = function(e) NA_real_
  )
  
  brier <- mean((p - y)^2)
  
  lp <- qlogis(p)
  
  cal_fit <- tryCatch(
    suppressWarnings(
      glm(y ~ lp, family = binomial())
    ),
    error = function(e) NULL
  )
  
  if(is.null(cal_fit)){
    cal_int <- NA_real_
    cal_slope <- NA_real_
  } else {
    co <- coef(cal_fit)
    cal_int <- unname(co[1])
    cal_slope <- unname(co[2])
  }
  
  O <- sum(y == 1)
  E <- sum(p)
  OE <- ifelse(E > 0, O / E, NA_real_)
  
  c(
    AUC = aucv,
    Brier = brier,
    Cal_Int = cal_int,
    Cal_Slope = cal_slope,
    OE = OE
  )
}

boot_metrics <- function(y, p, B = 500, seed = 123){
  set.seed(seed)
  
  y <- as.integer(y == 1L)
  p <- clamp01(p)
  
  ok <- is.finite(y) & is.finite(p)
  y <- y[ok]
  p <- p[ok]
  
  n <- length(y)
  
  boot_mat <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(metric_names),
    dimnames = list(NULL, metric_names)
  )
  
  if(n == 0){
    return(as.data.frame(boot_mat))
  }
  
  for(b in seq_len(B)){
    idx <- sample(
      seq_len(n),
      size = n,
      replace = TRUE
    )
    
    boot_mat[b, ] <- tryCatch(
      get_metrics(y[idx], p[idx]),
      error = function(e) empty_metrics()
    )
  }
  
  out <- as.data.frame(boot_mat)
  out$Bootstrap <- seq_len(B)
  out
}

prepare_dat <- function(dat, centers_all){
  dat[[outcome]] <- as01_2to0(dat[[outcome]])
  
  for(v in bin_cols){
    if(v %in% names(dat)){
      dat[[v]] <- as01_2to0(dat[[v]])
    }
  }
  
  if(!"Year" %in% names(dat)){
    stop("Year is missing. Please add Year before prepare_dat().")
  }
  
  dat$Year <- as.integer(dat$Year)
  dat$Center <- factor(dat$Center, levels = centers_all)
  dat$Gender <- factor(dat$Gender)
  
  dat
}

make_training_data <- function(dat_i,
                               target_year,
                               scheme_type,
                               half_life = NA,
                               rolling_window = NA){
  
  train_dat <- dat_i[
    dat_i$Year < target_year,
    ,
    drop = FALSE
  ]
  
  if(scheme_type == "rolling"){
    train_dat <- train_dat[
      train_dat$Year >= target_year - rolling_window,
      ,
      drop = FALSE
    ]
  }
  
  if(nrow(train_dat) == 0){
    return(NULL)
  }
  
  if(scheme_type == "half_life"){
    dt <- target_year - train_dat$Year
    weights <- 0.5^(dt / half_life)
    weights <- weights / mean(weights, na.rm = TRUE)
  } else {
    weights <- rep(1, nrow(train_dat))
  }
  
  list(
    train_dat = train_dat,
    weights = weights
  )
}

fit_rf_predict <- function(train_dat,
                           test_dat,
                           weights,
                           xvars,
                           imputation_i,
                           use_weighted_resampling = FALSE,
                           seed = 123){
  
  xvars <- drop_nzv(train_dat, xvars)
  
  keep_train <- complete.cases(
    train_dat[, c(outcome, xvars), drop = FALSE]
  ) & !is.na(train_dat[[outcome]])
  
  keep_test <- complete.cases(
    test_dat[, c(".CaseID", outcome, xvars), drop = FALSE]
  ) & !is.na(test_dat[[outcome]])
  
  train_source <- train_dat[
    keep_train,
    c(outcome, xvars),
    drop = FALSE
  ]
  
  test_clean <- test_dat[
    keep_test,
    c(".CaseID", outcome, xvars),
    drop = FALSE
  ]
  
  weights_use <- weights[keep_train]
  
  if(nrow(train_source) < 80 || nrow(test_clean) < 30){
    return(NULL)
  }
  
  if(length(unique(train_source[[outcome]])) < 2 ||
     length(unique(test_clean[[outcome]])) < 2){
    return(NULL)
  }
  
  if(use_weighted_resampling){
    
    prob_use <- weights_use / sum(weights_use, na.rm = TRUE)
    
    set.seed(seed)
    
    idx_rs <- sample(
      seq_len(nrow(train_source)),
      size = nrow(train_source),
      replace = TRUE,
      prob = prob_use
    )
    
    train_fit <- train_source[
      idx_rs,
      ,
      drop = FALSE
    ]
    
  } else {
    
    train_fit <- train_source
  }
  
  if(length(unique(train_fit[[outcome]])) < 2){
    return(NULL)
  }
  
  train_fit[[outcome]] <- factor(
    ifelse(train_fit[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  y_test <- as.integer(test_clean[[outcome]] == 1)
  case_id_test <- test_clean$.CaseID
  
  test_clean[[outcome]] <- factor(
    ifelse(test_clean[[outcome]] == 1, "Yes", "No"),
    levels = c("Yes", "No")
  )
  
  p_eff <- ncol(
    model.matrix(
      as.formula(
        paste("~", paste(xvars, collapse = "+"), "-1")
      ),
      data = train_fit
    )
  )
  
  mtry_use <- max(
    1,
    min(fixed_mtry, p_eff)
  )
  
  set.seed(seed)
  
  rf_fit <- randomForest::randomForest(
    as.formula(
      paste(outcome, "~", paste(xvars, collapse = "+"))
    ),
    data = train_fit,
    ntree = ntree_use,
    mtry = mtry_use
  )
  
  p_test <- predict(
    rf_fit,
    newdata = test_clean,
    type = "prob"
  )[, "Yes"]
  
  list(
    CaseID = case_id_test,
    y = y_test,
    p = clamp01(p_test),
    mtry = mtry_use,
    n_train_source = nrow(train_source),
    n_train_fit = nrow(train_fit),
    n_test = nrow(test_clean),
    events_train_source = sum(train_source[[outcome]] == 1),
    events_train_fit = sum(train_fit[[outcome]] == "Yes"),
    events_test = sum(y_test == 1),
    weight_min = min(weights_use, na.rm = TRUE),
    weight_median = median(weights_use, na.rm = TRUE),
    weight_max = max(weights_use, na.rm = TRUE),
    use_weighted_resampling = use_weighted_resampling,
    xvars_used = paste(xvars, collapse = ";")
  )
}

make_point_row <- function(imputation,
                           year,
                           strategy,
                           scheme_type,
                           scheme_parameter,
                           half_life,
                           rolling_window,
                           use_year_as_predictor,
                           use_weighted_resampling,
                           met){
  data.frame(
    Imputation = imputation,
    Year = year,
    Strategy = strategy,
    Scheme_Type = scheme_type,
    Scheme_Parameter = scheme_parameter,
    Half_Life = half_life,
    Rolling_Window = rolling_window,
    Use_Year_As_Predictor = use_year_as_predictor,
    Use_Weighted_Resampling = use_weighted_resampling,
    AUC = unname(met["AUC"]),
    Brier = unname(met["Brier"]),
    Cal_Int = unname(met["Cal_Int"]),
    Cal_Slope = unname(met["Cal_Slope"]),
    OE = unname(met["OE"]),
    stringsAsFactors = FALSE
  )
}

rbind_fill <- function(lst){
  lst <- lst[!sapply(lst, is.null)]
  
  if(length(lst) == 0){
    return(data.frame())
  }
  
  all_names <- unique(
    unlist(
      lapply(lst, names)
    )
  )
  
  lst2 <- lapply(lst, function(x){
    miss <- setdiff(all_names, names(x))
    
    if(length(miss) > 0){
      for(m in miss){
        x[[m]] <- NA
      }
    }
    
    x[, all_names, drop = FALSE]
  })
  
  do.call(rbind, lst2)
}

make_summary <- function(point_df, boot_df){
  
  group_cols <- c(
    "Year",
    "Strategy",
    "Scheme_Type",
    "Scheme_Parameter",
    "Use_Year_As_Predictor",
    "Use_Weighted_Resampling"
  )
  
  groups <- unique(
    point_df[, group_cols, drop = FALSE]
  )
  
  out_list <- list()
  
  for(i in seq_len(nrow(groups))){
    
    idx_p <- rep(TRUE, nrow(point_df))
    idx_b <- rep(TRUE, nrow(boot_df))
    
    for(gc in group_cols){
      idx_p <- idx_p & point_df[[gc]] == groups[[gc]][i]
      idx_b <- idx_b & boot_df[[gc]] == groups[[gc]][i]
    }
    
    for(m in metric_names){
      
      est <- mean(
        point_df[[m]][idx_p],
        na.rm = TRUE
      )
      
      ci_l <- as.numeric(
        quantile(
          boot_df[[m]][idx_b],
          0.025,
          na.rm = TRUE
        )
      )
      
      ci_u <- as.numeric(
        quantile(
          boot_df[[m]][idx_b],
          0.975,
          na.rm = TRUE
        )
      )
      
      out_list[[length(out_list) + 1]] <- data.frame(
        groups[i, , drop = FALSE],
        Metric = m,
        Estimate = est,
        CI_L = ci_l,
        CI_U = ci_u,
        Formatted = sprintf(
          "%.4f (%.4f to %.4f)",
          est,
          ci_l,
          ci_u
        ),
        stringsAsFactors = FALSE
      )
    }
  }
  
  do.call(rbind, out_list)
}

#####  5. Run analyses across imputations and years

m_use <- min(
  imp$bef$m,
  imp$dur$m,
  imp$aft$m
)

cat("\nNumber of imputations used:", m_use, "\n")

centers_all <- sort(
  unique(
    c(
      as.character(imp$bef$data$Center),
      as.character(imp$dur$data$Center),
      as.character(imp$aft$data$Center)
    )
  )
)

point_list <- list()
boot_list <- list()
detail_list <- list()
pred_list <- list()

for(i in seq_len(m_use)){
  
  cat("\nRunning imputation", i, "of", m_use, "\n")
  
  dat_bef_i <- mice::complete(imp$bef, i)
  dat_dur_i <- mice::complete(imp$dur, i)
  dat_aft_i <- mice::complete(imp$aft, i)
  
  dat_bef_i$Year <- dat_bef_year$Year
  dat_dur_i$Year <- dat_dur_year$Year
  dat_aft_i$Year <- dat_aft_year$Year
  
  dat_i <- rbind(
    dat_bef_i,
    dat_dur_i,
    dat_aft_i
  )
  
  dat_i$.CaseID <- seq_len(nrow(dat_i))
  
  dat_i <- prepare_dat(
    dat_i,
    centers_all = centers_all
  )
  
  for(yr in years){
    
    cat("  Year", yr, "\n")
    
    test_dat <- dat_i[
      dat_i$Year == yr,
      ,
      drop = FALSE
    ]
    
    if(nrow(test_dat) < 30){
      next
    }
    
    for(s in seq_len(nrow(schemes))){
      
      strategy_now <- schemes$Strategy[s]
      scheme_type_now <- schemes$Scheme_Type[s]
      scheme_parameter_now <- schemes$Scheme_Parameter[s]
      half_life_now <- schemes$Half_Life[s]
      rolling_window_now <- schemes$Rolling_Window[s]
      use_year_now <- schemes$Use_Year_As_Predictor[s]
      use_rs_now <- schemes$Use_Weighted_Resampling[s]
      
      train_obj <- make_training_data(
        dat_i = dat_i,
        target_year = yr,
        scheme_type = scheme_type_now,
        half_life = half_life_now,
        rolling_window = rolling_window_now
      )
      
      if(is.null(train_obj)){
        next
      }
      
      xvars_now <- if(isTRUE(use_year_now)){
        xvars_calendar
      } else {
        xvars_base
      }
      
      res_now <- tryCatch(
        fit_rf_predict(
          train_dat = train_obj$train_dat,
          test_dat = test_dat,
          weights = train_obj$weights,
          xvars = xvars_now,
          imputation_i = i,
          use_weighted_resampling = use_rs_now,
          seed = GLOBAL_SEED + i * 10000 + yr * 100 + s
        ),
        error = function(e){
          cat(
            "\n[SKIP]",
            "imputation =", i,
            "year =", yr,
            "strategy =", strategy_now,
            "error =", conditionMessage(e),
            "\n"
          )
          NULL
        }
      )
      
      if(is.null(res_now)){
        next
      }
      
      pred_list[[length(pred_list) + 1]] <- data.frame(
        Imputation = i,
        Year = yr,
        Strategy = strategy_now,
        Scheme_Type = scheme_type_now,
        Scheme_Parameter = scheme_parameter_now,
        Half_Life = half_life_now,
        Rolling_Window = rolling_window_now,
        Use_Year_As_Predictor = use_year_now,
        Use_Weighted_Resampling = use_rs_now,
        CaseID = res_now$CaseID,
        y = res_now$y,
        p = res_now$p,
        stringsAsFactors = FALSE
      )
      
      met <- get_metrics(
        y = res_now$y,
        p = res_now$p
      )
      
      point_list[[length(point_list) + 1]] <- make_point_row(
        imputation = i,
        year = yr,
        strategy = strategy_now,
        scheme_type = scheme_type_now,
        scheme_parameter = scheme_parameter_now,
        half_life = half_life_now,
        rolling_window = rolling_window_now,
        use_year_as_predictor = use_year_now,
        use_weighted_resampling = use_rs_now,
        met = met
      )
      
      boot_tmp <- boot_metrics(
        y = res_now$y,
        p = res_now$p,
        B = B_boot,
        seed = GLOBAL_SEED + i * 10000 + yr * 100 + s
      )
      
      boot_tmp$Imputation <- i
      boot_tmp$Year <- yr
      boot_tmp$Strategy <- strategy_now
      boot_tmp$Scheme_Type <- scheme_type_now
      boot_tmp$Scheme_Parameter <- scheme_parameter_now
      boot_tmp$Half_Life <- half_life_now
      boot_tmp$Rolling_Window <- rolling_window_now
      boot_tmp$Use_Year_As_Predictor <- use_year_now
      boot_tmp$Use_Weighted_Resampling <- use_rs_now
      
      boot_list[[length(boot_list) + 1]] <- boot_tmp
      
      detail_list[[length(detail_list) + 1]] <- data.frame(
        Imputation = i,
        Year = yr,
        Strategy = strategy_now,
        Scheme_Type = scheme_type_now,
        Scheme_Parameter = scheme_parameter_now,
        Half_Life = half_life_now,
        Rolling_Window = rolling_window_now,
        Use_Year_As_Predictor = use_year_now,
        Use_Weighted_Resampling = use_rs_now,
        train_from = min(train_obj$train_dat$Year, na.rm = TRUE),
        train_to = max(train_obj$train_dat$Year, na.rm = TRUE),
        train_n_source = res_now$n_train_source,
        train_n_fit = res_now$n_train_fit,
        train_events_source = res_now$events_train_source,
        train_events_fit = res_now$events_train_fit,
        test_n = res_now$n_test,
        test_events = res_now$events_test,
        mtry = res_now$mtry,
        ntree = ntree_use,
        weight_min = res_now$weight_min,
        weight_median = res_now$weight_median,
        weight_max = res_now$weight_max,
        xvars_used = res_now$xvars_used,
        stringsAsFactors = FALSE
      )
    }
  }
}

half_life_point_df <- rbind_fill(point_list)
half_life_boot_df <- rbind_fill(boot_list)
half_life_detail_df <- rbind_fill(detail_list)
half_life_pred_df <- rbind_fill(pred_list)

half_life_summary <- make_summary(
  point_df = half_life_point_df,
  boot_df = half_life_boot_df
)

half_life_summary <- half_life_summary[
  order(
    half_life_summary$Year,
    half_life_summary$Strategy,
    half_life_summary$Metric
  ),
]

#####  6. Delta versus all-history

point_mean <- aggregate(
  cbind(
    AUC,
    Brier,
    Cal_Int,
    Cal_Slope,
    OE
  ) ~
    Year +
    Strategy +
    Scheme_Type +
    Scheme_Parameter +
    Use_Year_As_Predictor +
    Use_Weighted_Resampling,
  data = half_life_point_df,
  FUN = mean,
  na.rm = TRUE
)

base_mean <- subset(
  point_mean,
  Strategy == "all_history"
)

delta_list <- list()

for(st in unique(point_mean$Strategy)){
  
  if(st == "all_history"){
    next
  }
  
  tmp <- merge(
    subset(point_mean, Strategy == st),
    base_mean[, c(
      "Year",
      "AUC",
      "Brier",
      "Cal_Int",
      "Cal_Slope",
      "OE"
    )],
    by = "Year",
    suffixes = c("", "_all_history")
  )
  
  tmp$Delta_AUC <- tmp$AUC - tmp$AUC_all_history
  tmp$Delta_Brier <- tmp$Brier - tmp$Brier_all_history
  tmp$Delta_Cal_Int_abs <- abs(tmp$Cal_Int) - abs(tmp$Cal_Int_all_history)
  tmp$Delta_Cal_Slope_abs <- abs(tmp$Cal_Slope - 1) - abs(tmp$Cal_Slope_all_history - 1)
  tmp$Delta_OE_abs <- abs(tmp$OE - 1) - abs(tmp$OE_all_history - 1)
  
  delta_list[[length(delta_list) + 1]] <- tmp
}

delta_vs_all_history <- rbind_fill(delta_list)

#####  6b. Paired bootstrap 95% CI for Supplementary Table S7

strategies_s7 <- setdiff(
  sort(unique(half_life_pred_df$Strategy)),
  "all_history"
)

paired_s7_list <- list()
s7_count <- 0L

for(i in sort(unique(half_life_pred_df$Imputation))){
  
  for(yr in sort(unique(half_life_pred_df$Year))){
    
    dat_now <- half_life_pred_df[
      half_life_pred_df$Imputation == i &
        half_life_pred_df$Year == yr,
      c("CaseID", "y", "Strategy", "p")
    ]
    
    if(nrow(dat_now) == 0){
      next
    }
    
    if(anyDuplicated(dat_now[, c("CaseID", "Strategy")])){
      stop(
        "Duplicate CaseID-Strategy rows: imputation ",
        i,
        ", year ",
        yr
      )
    }
    
    wide_now <- reshape(
      dat_now,
      idvar = c("CaseID", "y"),
      timevar = "Strategy",
      direction = "wide"
    )
    
    required_p <- paste0(
      "p.",
      c("all_history", strategies_s7)
    )
    
    if(!all(required_p %in% names(wide_now))){
      stop(
        "Missing strategy predictions: imputation ",
        i,
        ", year ",
        yr
      )
    }
    
    wide_now <- wide_now[
      complete.cases(
        wide_now[, c("y", required_p)]
      ),
    ]
    
    y_now <- as.integer(wide_now$y)
    n_now <- nrow(wide_now)
    
    if(n_now < 20 ||
       length(unique(y_now)) < 2){
      next
    }
    
    # One common set of bootstrap samples for all strategies
    set.seed(
      GLOBAL_SEED +
        i * 10000 +
        yr * 100
    )
    
    boot_now <- vector(
      "list",
      B_boot
    )
    
    for(b in seq_len(B_boot)){
      
      idx <- sample.int(
        n_now,
        size = n_now,
        replace = TRUE
      )
      
      y_b <- y_now[idx]
      
      met_base <- get_metrics(
        y = y_b,
        p = wide_now$p.all_history[idx]
      )
      
      boot_now[[b]] <- do.call(
        rbind,
        lapply(
          strategies_s7,
          function(st){
            
            met_st <- get_metrics(
              y = y_b,
              p = wide_now[
                [paste0("p.", st)]
              ][idx]
            )
            
            data.frame(
              Imputation = i,
              Year = yr,
              Bootstrap = b,
              Strategy = st,
              
              Delta_AUC =
                met_st["AUC"] -
                met_base["AUC"],
              
              Delta_Brier =
                met_st["Brier"] -
                met_base["Brier"],
              
              Delta_Cal_Int_abs =
                abs(met_st["Cal_Int"]) -
                abs(met_base["Cal_Int"]),
              
              Delta_Cal_Slope_abs =
                abs(met_st["Cal_Slope"] - 1) -
                abs(met_base["Cal_Slope"] - 1),
              
              Delta_OE_abs =
                abs(met_st["OE"] - 1) -
                abs(met_base["OE"] - 1),
              
              stringsAsFactors = FALSE
            )
          }
        )
      )
    }
    
    s7_count <- s7_count + 1L
    
    paired_s7_list[[s7_count]] <- do.call(
      rbind,
      boot_now
    )
  }
}

paired_s7_boot <- do.call(
  rbind,
  paired_s7_list
)

s7_quantile <- function(x, prob){
  
  x <- x[is.finite(x)]
  
  if(length(x) == 0){
    return(NA_real_)
  }
  
  unname(
    quantile(
      x,
      probs = prob,
      na.rm = TRUE
    )
  )
}

paired_s7_ci <- do.call(
  rbind,
  lapply(
    split(
      paired_s7_boot,
      list(
        paired_s7_boot$Year,
        paired_s7_boot$Strategy
      ),
      drop = TRUE
    ),
    function(d){
      
      data.frame(
        Year = d$Year[1],
        Strategy = d$Strategy[1],
        
        Delta_AUC_CI_low =
          s7_quantile(d$Delta_AUC, 0.025),
        Delta_AUC_CI_high =
          s7_quantile(d$Delta_AUC, 0.975),
        
        Delta_Brier_CI_low =
          s7_quantile(d$Delta_Brier, 0.025),
        Delta_Brier_CI_high =
          s7_quantile(d$Delta_Brier, 0.975),
        
        Delta_Cal_Int_abs_CI_low =
          s7_quantile(
            d$Delta_Cal_Int_abs,
            0.025
          ),
        Delta_Cal_Int_abs_CI_high =
          s7_quantile(
            d$Delta_Cal_Int_abs,
            0.975
          ),
        
        Delta_Cal_Slope_abs_CI_low =
          s7_quantile(
            d$Delta_Cal_Slope_abs,
            0.025
          ),
        Delta_Cal_Slope_abs_CI_high =
          s7_quantile(
            d$Delta_Cal_Slope_abs,
            0.975
          ),
        
        Delta_OE_abs_CI_low =
          s7_quantile(d$Delta_OE_abs, 0.025),
        Delta_OE_abs_CI_high =
          s7_quantile(d$Delta_OE_abs, 0.975),
        
        stringsAsFactors = FALSE
      )
    }
  )
)

rownames(paired_s7_ci) <- NULL

delta_vs_all_history <- merge(
  delta_vs_all_history,
  paired_s7_ci,
  by = c("Year", "Strategy"),
  all.x = TRUE,
  sort = FALSE
)

delta_vs_all_history <- delta_vs_all_history[
  order(
    delta_vs_all_history$Year,
    delta_vs_all_history$Strategy
  ),
]

#####  7. Overall scheme summary across years

overall_scheme_summary <- aggregate(
  cbind(
    AUC,
    Brier,
    Cal_Int,
    Cal_Slope,
    OE
  ) ~
    Strategy +
    Scheme_Type +
    Scheme_Parameter +
    Use_Year_As_Predictor +
    Use_Weighted_Resampling,
  data = point_mean,
  FUN = mean,
  na.rm = TRUE
)

overall_scheme_summary <- overall_scheme_summary[
  order(
    overall_scheme_summary$Scheme_Type,
    overall_scheme_summary$Strategy
  ),
]

#####  8. Save outputs

write.csv(
  half_life_point_df,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_point_estimates_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  half_life_boot_df,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_bootstrap_B500.csv"),
  row.names = FALSE
)

write.csv(
  half_life_summary,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_summary_B500.csv"),
  row.names = FALSE
)

write.csv(
  half_life_detail_df,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_model_detail.csv"),
  row.names = FALSE
)

write.csv(
  half_life_pred_df,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_predictions_for_DCA_Delong.csv"),
  row.names = FALSE
)

write.csv(
  point_mean,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_point_mean_by_year.csv"),
  row.names = FALSE
)

write.csv(
  delta_vs_all_history,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_delta_vs_all_history.csv"),
  row.names = FALSE
)

write.csv(
  overall_scheme_summary,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_overall_scheme_summary.csv"),
  row.names = FALSE
)

saveRDS(
  list(
    half_life_point_df = half_life_point_df,
    half_life_boot_df = half_life_boot_df,
    half_life_summary = half_life_summary,
    half_life_detail_df = half_life_detail_df,
    half_life_pred_df = half_life_pred_df,
    point_mean = point_mean,
    delta_vs_all_history = delta_vs_all_history,
    overall_scheme_summary = overall_scheme_summary,
    schemes = schemes,
    ntree = ntree_use,
    B_boot = B_boot,
    years = years,
    rf_engine = "randomForest",
    half_life_implementation = "weighted resampling",
    data_source = list(
      mi_object = file.path(project_dir, "imp_byTime_m10.rds"),
      year_source = file.path(project_dir, "alldata.csv")
    )
  ),
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_updating_outputs.rds"),
  compress = "xz"
)

writeLines(
  capture.output(sessionInfo()),
  con = file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "sessionInfo_half_life_rf_mi_updating.txt")
)

#####  9. Quick check

cat("\nHalf-life weighted RF MI updating completed.\n")
cat("RF engine: randomForest\n")
cat("Half-life implementation: weighted resampling\n")
cat("Outputs saved under:\n")
cat(file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating"), "\n")

cat("\nPrediction file for DeLong and DCA:\n")
cat(file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_predictions_for_DCA_Delong.csv"), "\n")

cat("\nOverall scheme summary:\n")
print(overall_scheme_summary, row.names = FALSE)

cat("\nHalf-life summary:\n")
print(half_life_summary, row.names = FALSE)


#####  Paired DeLong tests within each imputed dataset #####

library(pROC)

pred <- read.csv(
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_predictions_for_DCA_Delong.csv"),
  stringsAsFactors = FALSE
)

required_vars <- c(
  "Imputation", "Year", "Strategy",
  "CaseID", "y", "p"
)

if(!all(required_vars %in% names(pred))){
  stop(
    "Missing required variables: ",
    paste(setdiff(required_vars, names(pred)), collapse = ", ")
  )
}

pred$Imputation <- as.integer(pred$Imputation)
pred$Year <- as.integer(pred$Year)
pred$CaseID <- as.character(pred$CaseID)
pred$y <- as.integer(pred$y)
pred$p <- as.numeric(pred$p)

strategies <- sort(
  setdiff(unique(pred$Strategy), "all_history")
)

imputations <- sort(unique(pred$Imputation))


##### Function for one imputation and one strategy

one_test <- function(i, st){
  
  d0 <- subset(
    pred,
    Imputation == i & Strategy == "all_history",
    select = c("Year", "CaseID", "y", "p")
  )
  
  d1 <- subset(
    pred,
    Imputation == i & Strategy == st,
    select = c("Year", "CaseID", "y", "p")
  )
  
  # Check that each patient-year occurs only once
  key0 <- paste(d0$Year, d0$CaseID, sep = "_")
  key1 <- paste(d1$Year, d1$CaseID, sep = "_")
  
  if(anyDuplicated(key0)){
    stop(
      "Duplicated patient-year records in all_history: ",
      "imputation = ", i
    )
  }
  
  if(anyDuplicated(key1)){
    stop(
      "Duplicated patient-year records in strategy: ",
      st, ", imputation = ", i
    )
  }
  
  names(d0)[names(d0) == "y"] <- "y0"
  names(d0)[names(d0) == "p"] <- "p0"
  
  names(d1)[names(d1) == "y"] <- "y1"
  names(d1)[names(d1) == "p"] <- "p1"
  
  # Merge by patient and year, then verify outcomes
  dd <- merge(
    d0,
    d1,
    by = c("Year", "CaseID"),
    all = FALSE,
    sort = TRUE
  )
  
  dd <- dd[
    complete.cases(dd[, c("y0", "y1", "p0", "p1")]),
    ,
    drop = FALSE
  ]
  
  if(nrow(dd) < 30){
    return(NULL)
  }
  
  if(any(dd$y0 != dd$y1)){
    stop(
      "Outcome mismatch between strategies: ",
      "imputation = ", i,
      ", strategy = ", st
    )
  }
  
  y <- dd$y0
  
  if(length(unique(y)) < 2){
    return(NULL)
  }
  
  r0 <- pROC::roc(
    response = y,
    predictor = dd$p0,
    levels = c(0, 1),
    direction = "<",
    quiet = TRUE
  )
  
  r1 <- pROC::roc(
    response = y,
    predictor = dd$p1,
    levels = c(0, 1),
    direction = "<",
    quiet = TRUE
  )
  
  tt <- pROC::roc.test(
    r0,
    r1,
    paired = TRUE,
    method = "delong",
    alternative = "two.sided"
  )
  
  auc0 <- as.numeric(pROC::auc(r0))
  auc1 <- as.numeric(pROC::auc(r1))
  
  data.frame(
    Imputation = i,
    Strategy = st,
    N = nrow(dd),
    Events = sum(y == 1),
    AUC_all_history = auc0,
    AUC_strategy = auc1,
    Delta_AUC = auc1 - auc0,
    DeLong_P = as.numeric(tt$p.value),
    stringsAsFactors = FALSE
  )
}


##### Run analyses

res <- list()

for(i in imputations){
  
  for(st in strategies){
    
    tmp <- one_test(i, st)
    
    if(!is.null(tmp)){
      res[[length(res) + 1]] <- tmp
    }
  }
}

if(length(res) == 0){
  stop("No valid DeLong comparisons were generated.")
}

delong_by_imputation <- do.call(rbind, res)


##### Descriptive summary across imputations

summarize_strategy <- function(d){
  
  data.frame(
    Strategy = d$Strategy[1],
    M = nrow(d),
    
    AUC_all_history_mean =
      mean(d$AUC_all_history, na.rm = TRUE),
    
    AUC_strategy_mean =
      mean(d$AUC_strategy, na.rm = TRUE),
    
    Delta_AUC_mean =
      mean(d$Delta_AUC, na.rm = TRUE),
    
    Delta_AUC_SD =
      sd(d$Delta_AUC, na.rm = TRUE),
    
    DeLong_P_median =
      median(d$DeLong_P, na.rm = TRUE),
    
    DeLong_P_Q1 =
      unname(quantile(
        d$DeLong_P,
        probs = 0.25,
        na.rm = TRUE
      )),
    
    DeLong_P_Q3 =
      unname(quantile(
        d$DeLong_P,
        probs = 0.75,
        na.rm = TRUE
      )),
    
    stringsAsFactors = FALSE
  )
}

delong_summary <- do.call(
  rbind,
  lapply(
    split(
      delong_by_imputation,
      delong_by_imputation$Strategy
    ),
    summarize_strategy
  )
)

rownames(delong_summary) <- NULL

delong_summary$DeLong_P_median_IQR <- sprintf(
  "%.3f (%.3f to %.3f)",
  delong_summary$DeLong_P_median,
  delong_summary$DeLong_P_Q1,
  delong_summary$DeLong_P_Q3
)


##### Save results

write.csv(
  delong_by_imputation,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "DeLong_vs_all_history_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  delong_summary,
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "DeLong_vs_all_history_descriptive_summary.csv"),
  row.names = FALSE
)

print(delong_summary)

#####  Time-aware RF updating DCA  #####

pred <- read.csv(
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_predictions_for_DCA_Delong.csv"),
  stringsAsFactors = FALSE
)

pred$y <- as.integer(pred$y)
pred$p <- as.numeric(pred$p)

out_dir <- file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating")

thresholds <- seq(0.01, 0.30, by = 0.01)

##### 1. Strategies

strategies_full <- c(
  "all_history",
  "half_life_1y",
  "half_life_2y",
  "half_life_3y",
  "half_life_4y",
  "half_life_5y",
  "half_life_6y",
  "rolling_3y",
  "rolling_5y",
  "calendar_year_adjusted"
)

strategies_pub <- c(
  "all_history",
  "half_life_1y",
  "rolling_3y",
  "calendar_year_adjusted"
)

pred <- pred[pred$Strategy %in% strategies_full, ]

##### 2. Net benefit function

nb_model <- function(y, p, pt){
  pos <- p >= pt
  TP <- sum(pos & y == 1)
  FP <- sum(pos & y == 0)
  n <- length(y)
  TP / n - FP / n * pt / (1 - pt)
}

##### 3. DCA by imputation

dca_imp <- do.call(rbind, lapply(sort(unique(pred$Imputation)), function(i){
  
  dat_i <- pred[pred$Imputation == i, ]
  
  model_nb <- do.call(rbind, lapply(strategies_full, function(st){
    
    dat_st <- dat_i[dat_i$Strategy == st, ]
    
    data.frame(
      Imputation = i,
      Strategy = st,
      threshold = thresholds,
      NB = sapply(thresholds, function(pt){
        nb_model(dat_st$y, dat_st$p, pt)
      }),
      stringsAsFactors = FALSE
    )
  }))
  
  dat_unique <- dat_i[dat_i$Strategy == "all_history", ]
  prev <- mean(dat_unique$y == 1)
  
  ref_nb <- rbind(
    data.frame(
      Imputation = i,
      Strategy = "Treat all",
      threshold = thresholds,
      NB = prev - (1 - prev) * thresholds / (1 - thresholds),
      stringsAsFactors = FALSE
    ),
    data.frame(
      Imputation = i,
      Strategy = "Treat none",
      threshold = thresholds,
      NB = 0,
      stringsAsFactors = FALSE
    )
  )
  
  rbind(model_nb, ref_nb)
}))

##### 4. Average across imputations + paired bootstrap 95% CI

B_dca <- 500
set.seed(123)

imputations <- sort(unique(pred$Imputation))
all_labels <- c(strategies_full, "Treat all", "Treat none")

# Convert each imputed dataset to one row per case and one column per strategy
mi_wide <- lapply(imputations, function(i){
  
  dat_i <- pred[
    pred$Imputation == i,
    c("Year", "CaseID", "y", "Strategy", "p")
  ]
  
  if(anyDuplicated(dat_i[, c("Year", "CaseID", "Strategy")])){
    stop("Duplicate case-year-strategy rows in imputation ", i)
  }
  
  wide_i <- reshape(
    dat_i,
    idvar = c("Year", "CaseID", "y"),
    timevar = "Strategy",
    direction = "wide"
  )
  
  wide_i[order(wide_i$Year, wide_i$CaseID), ]
})

prob_cols <- paste0("p.", strategies_full)

if(any(sapply(mi_wide, function(x){
  any(!prob_cols %in% names(x)) || anyNA(x[, prob_cols, drop = FALSE])
}))){
  stop("Some strategies have missing or unmatched predictions.")
}

# Check that all imputations contain the same case-year rows
case_key <- lapply(mi_wide, function(x){
  paste(x$Year, x$CaseID, sep = "_")
})

if(length(case_key) > 1 &&
   any(sapply(case_key[-1], function(x) !identical(x, case_key[[1]])))){
  stop("Case-year rows are not aligned across imputations.")
}

y <- as.integer(mi_wide[[1]]$y)
year <- as.integer(mi_wide[[1]]$Year)

if(length(mi_wide) > 1 &&
   any(sapply(mi_wide[-1], function(x) any(as.integer(x$y) != y)))){
  stop("Outcomes are not aligned across imputations.")
}

n <- length(y)
M <- length(mi_wide)
S <- length(strategies_full)
Tn <- length(thresholds)

# Patient-level net-benefit contribution
threshold_odds <- thresholds / (1 - thresholds)

outcome_value <- outer(
  y,
  threshold_odds,
  FUN = function(y, odds) y - (1 - y) * odds
)

contribution <- array(
  0,
  dim = c(length(all_labels), Tn, n),
  dimnames = list(all_labels, NULL, NULL)
)

# Average patient-level contributions across imputations
for(m in seq_len(M)){
  for(s in seq_len(S)){
    
    predicted_positive <- outer(
      mi_wide[[m]][[prob_cols[s]]],
      thresholds,
      FUN = ">="
    )
    
    contribution[s, , ] <- contribution[s, , ] +
      t(predicted_positive * outcome_value) / M
  }
}

contribution["Treat all", , ] <- t(outcome_value)
contribution["Treat none", , ] <- 0

# Same bootstrap samples are used for every strategy and every imputation
bootstrap_counts <- matrix(0L, nrow = n, ncol = B_dca)
year_groups <- split(seq_len(n), year)

for(b in seq_len(B_dca)){
  for(ids in year_groups){
    sampled <- sample(ids, length(ids), replace = TRUE)
    bootstrap_counts[, b] <- bootstrap_counts[, b] +
      tabulate(sampled, nbins = n)
  }
}

flat_contribution <- matrix(
  contribution,
  nrow = length(all_labels) * Tn,
  ncol = n
)

point_nb <- array(
  rowMeans(flat_contribution),
  dim = c(length(all_labels), Tn)
)

bootstrap_nb <- array(
  flat_contribution %*% bootstrap_counts / n,
  dim = c(length(all_labels), Tn, B_dca)
)

reference_index <- match("all_history", all_labels)

delta_point <- sweep(
  point_nb,
  MARGIN = 2,
  STATS = point_nb[reference_index, ],
  FUN = "-"
)

delta_bootstrap <- sweep(
  bootstrap_nb,
  MARGIN = c(2, 3),
  STATS = bootstrap_nb[reference_index, , ],
  FUN = "-"
)

nb_ci <- apply(
  bootstrap_nb,
  c(1, 2),
  quantile,
  probs = c(0.025, 0.975),
  na.rm = TRUE
)

delta_ci <- apply(
  delta_bootstrap,
  c(1, 2),
  quantile,
  probs = c(0.025, 0.975),
  na.rm = TRUE
)

dca_summary <- expand.grid(
  Strategy = all_labels,
  threshold = thresholds,
  KEEP.OUT.ATTRS = FALSE,
  stringsAsFactors = FALSE
)

dca_summary$NB <- as.vector(point_nb)
dca_summary$NB_CI_lower <- as.vector(nb_ci[1, , ])
dca_summary$NB_CI_upper <- as.vector(nb_ci[2, , ])
dca_summary$Delta_NB_vs_all_history <- as.vector(delta_point)
dca_summary$Delta_CI_lower <- as.vector(delta_ci[1, , ])
dca_summary$Delta_CI_upper <- as.vector(delta_ci[2, , ])

clean_display_zero <- function(x){
  x[abs(x) < 0.0005] <- 0
  x
}

dca_summary$NB_95CI <- sprintf(
  "%.3f (%.3f to %.3f)",
  clean_display_zero(dca_summary$NB),
  clean_display_zero(dca_summary$NB_CI_lower),
  clean_display_zero(dca_summary$NB_CI_upper)
)

dca_summary$Delta_NB_95CI <- sprintf(
  "%.3f (%.3f to %.3f)",
  clean_display_zero(dca_summary$Delta_NB_vs_all_history),
  clean_display_zero(dca_summary$Delta_CI_lower),
  clean_display_zero(dca_summary$Delta_CI_upper)
)

write.csv(
  dca_imp,
  file.path(out_dir, "DCA_time_aware_RF_by_imputation.csv"),
  row.names = FALSE
)

write.csv(
  dca_summary,
  file.path(
    out_dir,
    "DCA_time_aware_RF_paired_bootstrap_B500.csv"
  ),
  row.names = FALSE
)

write.csv(
  dca_summary,
  file.path(out_dir, "DCA_time_aware_RF_summary_all_strategies.csv"),
  row.names = FALSE
)

##### 5. Simplified publication DCA data

dca_pub <- dca_summary[
  dca_summary$Strategy %in%
    c(strategies_pub, "Treat all", "Treat none"),
]

write.csv(
  dca_pub,
  file.path(
    out_dir,
    "DCA_time_aware_RF_summary_publication_simplified.csv"
  ),
  row.names = FALSE
)

##### 6. Plot function

plot_dca <- function(dca_dat,
                     strategies_use,
                     main_title,
                     legend_cex = 0.80){
  
  old_par <- par(no.readonly = TRUE)
  on.exit(par(old_par))
  
  par(mar = c(5, 4.5, 4, 2), xpd = FALSE)
  
  dca_model <- dca_dat[
    dca_dat$Strategy %in% strategies_use,
  ]
  
  ymax <- max(dca_model$NB, na.rm = TRUE) + 0.04
  
  plot(
    thresholds,
    rep(0, length(thresholds)),
    type = "n",
    xlim = c(0.01, 0.30),
    ylim = c(-0.05, ymax),
    xlab = "Threshold probability",
    ylab = "Net benefit",
    main = main_title
  )
  
  abline(h = 0, lty = 2, col = "grey50")
  
  cols <- c(
    "all_history" = "#276FAF",
    "half_life_1y" = "#B5202E",
    "half_life_2y" = "#D95F02",
    "half_life_3y" = "#E7298A",
    "half_life_4y" = "#A6761D",
    "half_life_5y" = "#666666",
    "half_life_6y" = "#66A61E",
    "rolling_3y" = "#1B9E77",
    "rolling_5y" = "#7570B3",
    "calendar_year_adjusted" = "#000000",
    "Treat all" = "grey30",
    "Treat none" = "grey50"
  )
  
  ltys <- c(
    "all_history" = 1,
    "half_life_1y" = 1,
    "half_life_2y" = 1,
    "half_life_3y" = 1,
    "half_life_4y" = 1,
    "half_life_5y" = 1,
    "half_life_6y" = 1,
    "rolling_3y" = 1,
    "rolling_5y" = 1,
    "calendar_year_adjusted" = 1,
    "Treat all" = 2,
    "Treat none" = 3
  )
  
  plot_order <- c(strategies_use, "Treat all", "Treat none")
  
  for(st in plot_order){
    
    dd <- dca_dat[dca_dat$Strategy == st, ]
    dd <- dd[order(dd$threshold), ]
    
    lines(
      dd$threshold,
      dd$NB,
      col = cols[st],
      lty = ltys[st],
      lwd = ifelse(st %in% c("Treat all", "Treat none"), 1.5, 1.5)
    )
  }
  
  legend(
    "topright",
    legend = plot_order,
    col = cols[plot_order],
    lty = ltys[plot_order],
    lwd = c(rep(2.8, length(strategies_use)), 1.5, 1.5),
    bty = "n",
    cex = legend_cex
  )
}

##### 7. Full strategy plot

pdf(
  file.path(out_dir, "DCA_time_aware_RF_all_strategies.pdf"),
  width = 10,
  height = 6
)

plot_dca(
  dca_dat = dca_summary,
  strategies_use = strategies_full,
  main_title = "DCA | Time-aware RF updating: all strategies",
  legend_cex = 0.58
)

dev.off()

##### 8. Simplified publication plot

pdf(
  file.path(out_dir, "DCA_time_aware_RF_publication_simplified.pdf"),
  width = 8,
  height = 6
)

plot_dca(
  dca_dat = dca_summary,
  strategies_use = strategies_pub,
  main_title = "DCA | Time-aware RF updating",
  legend_cex = 0.80
)

dev.off()

##### 9. Show simplified plot in RStudio

if(interactive()){
  plot_dca(
    dca_dat = dca_summary,
    strategies_use = strategies_pub,
    main_title = "DCA | Time-aware RF updating",
    legend_cex = 0.80
  )
}

##### 10. Quick check

cat("\nDCA completed.\n")
cat("All-strategy DCA PDF:\n")
cat(file.path(out_dir, "DCA_time_aware_RF_all_strategies.pdf"), "\n")

cat("Simplified publication DCA PDF:\n")
cat(file.path(out_dir, "DCA_time_aware_RF_publication_simplified.pdf"), "\n")

cat("Simplified DCA CSV:\n")
cat(file.path(out_dir, "DCA_time_aware_RF_summary_publication_simplified.csv"), "\n")







#####  Risk distribution plot | Time-aware RF updating #####

library(ggplot2)

pred <- read.csv(
  file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "half_life_rf_mi_predictions_for_DCA_Delong.csv"),
  stringsAsFactors = FALSE
)

out_dir <- file.path(project_dir, "IVIGR", "RF", "HalfLifeUpdating", "risk_distribution")
dir.create(out_dir, recursive = TRUE, showWarnings = FALSE)

schemes_use <- c(
  "all_history",
  "calendar_year_adjusted",
  "rolling_3y"
)

pred <- pred[pred$Strategy %in% schemes_use, ]

pred$y <- as.integer(pred$y)
pred$p <- as.numeric(pred$p)

##### Average predictions across imputations

pred_mean <- aggregate(
  p ~ Year + Strategy + CaseID + y,
  data = pred,
  FUN = mean,
  na.rm = TRUE
)

pred_mean$IVIGR <- factor(
  pred_mean$y,
  levels = c(0, 1),
  labels = c("IVIG Responsive", "IVIG Resistant")
)

pred_mean$Strategy_Label <- factor(
  pred_mean$Strategy,
  levels = c(
    "all_history",
    "calendar_year_adjusted",
    "rolling_3y"
  ),
  labels = c(
    "All-history refitting",
    "Calendar-year adjustment",
    "Rolling 3-year refitting"
  )
)

fill_cols <- c(
  "IVIG Responsive" = "#276FAF",
  "IVIG Resistant"  = "#B5202E"
)

median_iqr <- function(x){
  data.frame(
    y = median(x, na.rm = TRUE),
    ymin = unname(quantile(x, 0.25, na.rm = TRUE)),
    ymax = unname(quantile(x, 0.75, na.rm = TRUE))
  )
}

##### Plot function

make_risk_plot <- function(d, title_use){
  
  ggplot(d, aes(x = IVIGR, y = p, fill = IVIGR)) +
    geom_violin(trim = FALSE, alpha = 0.70) +
    stat_summary(
      fun.data = median_iqr,
      geom = "errorbar",
      width = 0.2,
      color = "black"
    ) +
    stat_summary(
      fun = median,
      geom = "point",
      size = 2.8,
      shape = 21,
      fill = "white",
      color = "black"
    ) +
    scale_fill_manual(values = fill_cols) +
    facet_wrap(~ Strategy_Label, nrow = 1) +
    labs(
      title = title_use,
      x = "IVIGR group",
      y = "Predicted probability",
      fill = "IVIGR group"
    ) +
    theme_minimal() +
    theme(
      legend.position = "right",
      legend.title = element_text(size = 12),
      legend.text  = element_text(size = 10),
      axis.text.x  = element_text(size = 11),
      axis.text.y  = element_text(size = 12),
      axis.title.x = element_text(size = 13),
      axis.title.y = element_text(size = 13),
      strip.text   = element_text(size = 12, face = "bold"),
      plot.title   = element_text(hjust = 0.5, size = 16, face = "bold")
    )
}

##### 1. Main figure: pooled across 2015-2024

d_main <- pred_mean[pred_mean$Year %in% 2015:2024, ]

p_main <- make_risk_plot(
  d_main,
  title_use = "Predicted IVIG resistance probability distribution"
)

ggsave(
  file.path(out_dir, "risk_distribution_pooled_2015_2024.pdf"),
  p_main,
  width = 11,
  height = 5.5,
  device = "pdf"
)

if(interactive()) print(p_main)

##### 2. Supplementary year-specific figures

for(yr in 2015:2024){
  
  d_yr <- pred_mean[pred_mean$Year == yr, ]
  
  if(nrow(d_yr) < 20) next
  
  p_yr <- make_risk_plot(
    d_yr,
    title_use = paste0("Predicted IVIG resistance probability distribution | ", yr)
  )
  
  ggsave(
    file.path(out_dir, paste0("risk_distribution_", yr, ".pdf")),
    p_yr,
    width = 11,
    height = 5.5,
    device = "pdf"
  )
}

write.csv(
  pred_mean,
  file.path(out_dir, "risk_distribution_prediction_mean_by_case.csv"),
  row.names = FALSE
)

cat("Done. Saved to: ", out_dir, "\n")


#####  Leave-one-center-out RF sensitivity analysis  #####

GLOBAL_SEED <- 123
loco_B_boot <- 500
loco_ntree <- 500
loco_mtry <- 3

set.seed(GLOBAL_SEED)

required_pkgs_loco <- c(
  "mice",
  "randomForest",
  "pROC"
)

missing_pkgs_loco <- required_pkgs_loco[
  !sapply(
    required_pkgs_loco,
    requireNamespace,
    quietly = TRUE
  )
]

if(length(missing_pkgs_loco) > 0){
  stop(
    "Please install missing packages first: ",
    paste(missing_pkgs_loco, collapse = ", ")
  )
}

suppressPackageStartupMessages({
  library(mice)
  library(randomForest)
  library(pROC)
})

dir.create(
  file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO"
  ),
  recursive = TRUE,
  showWarnings = FALSE
)

cat(
  "\nLeave-one-center-out RF sensitivity analysis started\n"
)

#####  1. Load multiply imputed data  #####

loco_imp <- readRDS(
  file.path(
    project_dir,
    "imp_byTime_m10.rds"
  )
)

loco_centers <- c(
  "FJSL",
  "FZFY",
  "Suzhou",
  "Yangzhou"
)

loco_period_labels <- c(
  pre = "Pre-COVID",
  during = "During-COVID",
  after = "After-COVID"
)

loco_outcome <- "IVIGR"

loco_bin_cols <- c(
  "Cervical_Lymphadenopathy",
  "Rash",
  "Oral_Mucosal_Change",
  "Edema_of_the_Hands_and_Feet",
  "Conjunctival_Injection"
)

loco_cont_cols <- c(
  "Age_months",
  "WBC",
  "Neu_percent",
  "Hb",
  "PLT",
  "AST",
  "ALT",
  "ALB",
  "CRP"
)

# Center is deliberately excluded from the predictor set.
loco_xvars <- c(
  "Gender",
  loco_cont_cols,
  loco_bin_cols
)

#####  2. Helper functions  #####

loco_to01 <- function(x){

  if(is.factor(x)){
    x <- as.character(x)
  }

  x <- trimws(as.character(x))
  x_num <- suppressWarnings(as.integer(x))

  result <- rep(
    NA_integer_,
    length(x_num)
  )

  result[
    x_num %in% c(0L, 2L)
  ] <- 0L

  result[
    x_num == 1L
  ] <- 1L

  result
}

loco_prepare_data <- function(d){

  d$Center <- as.character(
    d$Center
  )

  d$Gender <- factor(
    as.character(d$Gender),
    levels = c("1", "2")
  )

  for(v in loco_bin_cols){
    d[[v]] <- loco_to01(
      d[[v]]
    )
  }

  d[[loco_outcome]] <- loco_to01(
    d[[loco_outcome]]
  )

  d
}

loco_drop_constant <- function(d, predictors){

  keep <- sapply(
    predictors,
    function(v){

      if(!v %in% names(d)){
        return(FALSE)
      }

      values <- unique(
        d[[v]][!is.na(d[[v]])]
      )

      length(values) >= 2
    }
  )

  predictors[keep]
}

loco_clamp_probability <- function(p){

  p <- as.numeric(p)

  pmin(
    pmax(p, 1e-6),
    1 - 1e-6
  )
}

loco_empty_metrics <- function(){

  c(
    AUC = NA_real_,
    Brier = NA_real_,
    Cal_Int = NA_real_,
    Cal_Slope = NA_real_,
    OE = NA_real_
  )
}

loco_calculate_metrics <- function(y, p){

  y <- as.integer(y)
  p <- loco_clamp_probability(p)

  keep <- is.finite(y) &
    is.finite(p)

  y <- y[keep]
  p <- p[keep]

  if(
    length(y) < 20 ||
    length(unique(y)) < 2
  ){
    return(
      loco_empty_metrics()
    )
  }

  auc_value <- tryCatch(
    as.numeric(
      pROC::auc(
        pROC::roc(
          response = y,
          predictor = p,
          direction = "<",
          quiet = TRUE
        )
      )
    ),
    error = function(e){
      NA_real_
    }
  )

  brier_value <- mean(
    (p - y)^2
  )

  linear_predictor <- qlogis(p)

  calibration_model <- tryCatch(
    suppressWarnings(
      glm(
        y ~ linear_predictor,
        family = binomial()
      )
    ),
    error = function(e){
      NULL
    }
  )

  if(is.null(calibration_model)){

    calibration_intercept <- NA_real_
    calibration_slope <- NA_real_

  } else {

    calibration_coefficients <- coef(
      calibration_model
    )

    calibration_intercept <- unname(
      calibration_coefficients[1]
    )

    calibration_slope <- unname(
      calibration_coefficients[2]
    )
  }

  observed_events <- sum(y)
  expected_events <- sum(p)

  oe_value <- ifelse(
    expected_events > 0,
    observed_events / expected_events,
    NA_real_
  )

  c(
    AUC = auc_value,
    Brier = brier_value,
    Cal_Int = calibration_intercept,
    Cal_Slope = calibration_slope,
    OE = oe_value
  )
}

loco_bootstrap_metrics <- function(
    y,
    p,
    B = 500,
    seed = 123
){

  set.seed(seed)

  n <- length(y)

  bootstrap_result <- matrix(
    NA_real_,
    nrow = B,
    ncol = 5,
    dimnames = list(
      NULL,
      c(
        "AUC",
        "Brier",
        "Cal_Int",
        "Cal_Slope",
        "OE"
      )
    )
  )

  for(b in seq_len(B)){

    bootstrap_index <- sample(
      seq_len(n),
      size = n,
      replace = TRUE
    )

    bootstrap_result[b, ] <-
      loco_calculate_metrics(
        y = y[bootstrap_index],
        p = p[bootstrap_index]
      )
  }

  as.data.frame(
    bootstrap_result
  )
}

loco_mean_or_na <- function(x){

  if(all(is.na(x))){
    return(NA_real_)
  }

  mean(
    x,
    na.rm = TRUE
  )
}

#####  3. Run leave-one-center-out validation  #####

loco_point_results <- list()
loco_bootstrap_results <- list()

loco_m_use <- min(
  loco_imp$bef$m,
  loco_imp$dur$m,
  loco_imp$aft$m
)

cat(
  "Number of imputations:",
  loco_m_use,
  "\n"
)

for(i in seq_len(loco_m_use)){

  cat(
    "\nRunning LOCO imputation",
    i,
    "of",
    loco_m_use,
    "\n"
  )

  loco_data_by_period <- list(

    pre = loco_prepare_data(
      mice::complete(
        loco_imp$bef,
        i
      )
    ),

    during = loco_prepare_data(
      mice::complete(
        loco_imp$dur,
        i
      )
    ),

    after = loco_prepare_data(
      mice::complete(
        loco_imp$aft,
        i
      )
    )
  )

  for(k in seq_along(loco_centers)){

    held_out_center <- loco_centers[k]

    cat(
      "  Held-out center:",
      held_out_center,
      "\n"
    )

    # Model development uses only pre-COVID
    # patients from the other three centers.
    training_data <- loco_data_by_period$pre[
      loco_data_by_period$pre$Center !=
        held_out_center,
      ,
      drop = FALSE
    ]

    predictors_use <- loco_drop_constant(
      training_data,
      loco_xvars
    )

    training_data <- training_data[
      complete.cases(
        training_data[
          ,
          c(
            loco_outcome,
            predictors_use
          ),
          drop = FALSE
        ]
      ),
      ,
      drop = FALSE
    ]

    training_events <- sum(
      training_data[[loco_outcome]] == 1,
      na.rm = TRUE
    )

    if(
      nrow(training_data) < 80 ||
      training_events < 20
    ){

      cat(
        "    Skipped: insufficient training data\n"
      )

      next
    }

    training_rf <- training_data[
      ,
      c(
        loco_outcome,
        predictors_use
      ),
      drop = FALSE
    ]

    training_rf[[loco_outcome]] <- factor(
      ifelse(
        training_rf[[loco_outcome]] == 1,
        "Yes",
        "No"
      ),
      levels = c(
        "No",
        "Yes"
      )
    )

    set.seed(
      GLOBAL_SEED +
        i * 1000 +
        k * 100
    )

    rf_model <- randomForest::randomForest(

      as.formula(
        paste(
          loco_outcome,
          "~",
          paste(
            predictors_use,
            collapse = "+"
          )
        )
      ),

      data = training_rf,

      ntree = loco_ntree,

      # Retain the fixed mtry used in
      # the primary RF updating analyses.
      mtry = min(
        loco_mtry,
        length(predictors_use)
      )
    )

    for(
      period_now in
      names(loco_data_by_period)
    ){

      testing_data <-
        loco_data_by_period[[period_now]][

          loco_data_by_period[
            [period_now]
          ]$Center ==
            held_out_center,

          ,
          drop = FALSE
        ]

      testing_data <- testing_data[
        complete.cases(
          testing_data[
            ,
            c(
              loco_outcome,
              predictors_use
            ),
            drop = FALSE
          ]
        ),
        ,
        drop = FALSE
      ]

      y_test <- testing_data[
        [loco_outcome]
      ]

      test_n <- length(y_test)

      test_events <- sum(
        y_test == 1,
        na.rm = TRUE
      )

      # Center-period performance is not
      # estimated when sample size or
      # event count is insufficient.
      if(
        test_n < 30 ||
        test_events < 5 ||
        length(unique(y_test)) < 2
      ){

        cat(
          "    ",
          unname(
            loco_period_labels[
              period_now
            ]
          ),
          ": not estimable; n =",
          test_n,
          ", events =",
          test_events,
          "\n"
        )

        next
      }

      predicted_probability <- predict(
        rf_model,
        newdata = testing_data,
        type = "prob"
      )[, "Yes"]

      point_metrics <-
        loco_calculate_metrics(
          y = y_test,
          p = predicted_probability
        )

      loco_point_results[
        [length(loco_point_results) + 1]
      ] <- data.frame(

        Imputation = i,

        Held_out_center =
          held_out_center,

        Period = unname(
          loco_period_labels[
            period_now
          ]
        ),

        Training_N =
          nrow(training_data),

        Training_events =
          training_events,

        Test_N = test_n,

        Test_events =
          test_events,

        AUC = unname(
          point_metrics["AUC"]
        ),

        Brier = unname(
          point_metrics["Brier"]
        ),

        Cal_Int = unname(
          point_metrics["Cal_Int"]
        ),

        Cal_Slope = unname(
          point_metrics["Cal_Slope"]
        ),

        OE = unname(
          point_metrics["OE"]
        ),

        stringsAsFactors = FALSE
      )

      bootstrap_now <-
        loco_bootstrap_metrics(

          y = y_test,

          p =
            predicted_probability,

          B =
            loco_B_boot,

          seed =
            GLOBAL_SEED +
            i * 100000 +
            k * 1000 +
            match(
              period_now,
              names(
                loco_data_by_period
              )
            )
        )

      bootstrap_now$Imputation <- i

      bootstrap_now$Held_out_center <-
        held_out_center

      bootstrap_now$Period <- unname(
        loco_period_labels[
          period_now
        ]
      )

      bootstrap_now$Bootstrap <-
        seq_len(loco_B_boot)

      loco_bootstrap_results[
        [length(loco_bootstrap_results) + 1]
      ] <- bootstrap_now
    }
  }
}

if(length(loco_point_results) == 0){

  stop(
    "No valid LOCO results were generated."
  )
}

loco_point_by_imputation <- do.call(
  rbind,
  loco_point_results
)

loco_bootstrap <- do.call(
  rbind,
  loco_bootstrap_results
)

#####  4. Summarize across imputations  #####

loco_metrics_use <- c(
  "AUC",
  "Brier",
  "Cal_Int",
  "Cal_Slope",
  "OE"
)

loco_summary_results <- list()

loco_groups <- unique(
  loco_point_by_imputation[
    ,
    c(
      "Held_out_center",
      "Period"
    ),
    drop = FALSE
  ]
)

for(g in seq_len(nrow(loco_groups))){

  center_now <-
    loco_groups$Held_out_center[g]

  period_now <-
    loco_groups$Period[g]

  point_subset <-
    loco_point_by_imputation[

      loco_point_by_imputation$
        Held_out_center ==
        center_now &

      loco_point_by_imputation$
        Period ==
        period_now,

      ,
      drop = FALSE
    ]

  bootstrap_subset <-
    loco_bootstrap[

      loco_bootstrap$
        Held_out_center ==
        center_now &

      loco_bootstrap$
        Period ==
        period_now,

      ,
      drop = FALSE
    ]

  for(
    metric_now in
    loco_metrics_use
  ){

    point_estimate <-
      loco_mean_or_na(
        point_subset[
          [metric_now]
        ]
      )

    bootstrap_values <-
      bootstrap_subset[
        [metric_now]
      ]

    bootstrap_values <-
      bootstrap_values[
        is.finite(
          bootstrap_values
        )
      ]

    if(
      length(bootstrap_values) == 0
    ){

      ci_lower <- NA_real_
      ci_upper <- NA_real_

    } else {

      ci_lower <- as.numeric(
        quantile(
          bootstrap_values,
          0.025,
          na.rm = TRUE
        )
      )

      ci_upper <- as.numeric(
        quantile(
          bootstrap_values,
          0.975,
          na.rm = TRUE
        )
      )
    }

    loco_summary_results[
      [length(loco_summary_results) + 1]
    ] <- data.frame(

      Held_out_center =
        center_now,

      Period =
        period_now,

      M =
        nrow(point_subset),

      Test_N = round(
        mean(
          point_subset$Test_N,
          na.rm = TRUE
        )
      ),

      Test_events = round(
        mean(
          point_subset$Test_events,
          na.rm = TRUE
        )
      ),

      Metric =
        metric_now,

      Estimate =
        point_estimate,

      CI_lower =
        ci_lower,

      CI_upper =
        ci_upper,

      Estimate_95CI = sprintf(
        "%.3f (%.3f to %.3f)",
        point_estimate,
        ci_lower,
        ci_upper
      ),

      stringsAsFactors = FALSE
    )
  }
}

loco_summary <- do.call(
  rbind,
  loco_summary_results
)

loco_summary$Period <- factor(
  loco_summary$Period,
  levels = c(
    "Pre-COVID",
    "During-COVID",
    "After-COVID"
  )
)

loco_summary <- loco_summary[
  order(
    loco_summary$Held_out_center,
    loco_summary$Period,
    match(
      loco_summary$Metric,
      loco_metrics_use
    )
  ),
  ,
  drop = FALSE
]

loco_summary$Period <-
  as.character(
    loco_summary$Period
  )

#####  5. Save outputs  #####

write.csv(
  loco_point_by_imputation,
  file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO",
    "LOCO_RF_point_estimates_by_imputation.csv"
  ),
  row.names = FALSE
)

write.csv(
  loco_bootstrap,
  file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO",
    "LOCO_RF_bootstrap_B500.csv"
  ),
  row.names = FALSE
)

write.csv(
  loco_summary,
  file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO",
    "LOCO_RF_summary_B500.csv"
  ),
  row.names = FALSE
)

writeLines(
  capture.output(
    sessionInfo()
  ),
  con = file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO",
    "sessionInfo_LOCO_RF.txt"
  )
)

#####  6. Quick check  #####

cat(
  "\nLOCO RF sensitivity analysis completed.\n"
)

cat(
  "Outputs saved under:\n"
)

cat(
  file.path(
    project_dir,
    "IVIGR",
    "RF",
    "CenterSensitivity",
    "LOCO"
  ),
  "\n"
)

print(
  loco_summary,
  row.names = FALSE
)

#####  Final reproducibility record #####

writeLines(
  capture.output(sessionInfo()),
  con = file.path(project_dir, "sessionInfo_complete_analysis.txt")
)