|
| 1 | +#' Create a starter clone-censor-weighting dataset |
| 2 | +#' |
| 3 | +#' Expands each observation into one row per treatment strategy and flags |
| 4 | +#' immediate deviations from the observed baseline treatment as censored clones. |
| 5 | +#' This is a light-weight scaffold for package development rather than a full |
| 6 | +#' causal inference implementation. |
| 7 | +#' |
| 8 | +#' @param data A data frame containing one row per participant. |
| 9 | +#' @param id The name of the participant identifier column. |
| 10 | +#' @param follow_up The name of the follow-up time column. |
| 11 | +#' @param event The name of the event indicator column. |
| 12 | +#' @param treatment The name of the observed treatment column. |
| 13 | +#' @param regimes Optional vector of treatment strategies to clone. When `NULL`, |
| 14 | +#' unique non-missing observed treatments are used. |
| 15 | +#' |
| 16 | +#' @return A tibble with one row per participant-strategy combination and the |
| 17 | +#' additional columns `.clone_id`, `.regime`, `.censored`, and `.weight`. |
| 18 | +#' @export |
| 19 | +clone_censor_weighting <- function( |
| 20 | + data, |
| 21 | + id, |
| 22 | + follow_up, |
| 23 | + event, |
| 24 | + treatment, |
| 25 | + regimes = NULL |
| 26 | +) { |
| 27 | + .assert_data_frame(data) |
| 28 | + |
| 29 | + required_columns <- c(id, follow_up, event, treatment) |
| 30 | + .assert_required_columns(data, required_columns) |
| 31 | + |
| 32 | + tbl <- tibble::as_tibble(data) |
| 33 | + |
| 34 | + if (!is.numeric(tbl[[follow_up]])) { |
| 35 | + stop("`follow_up` must refer to a numeric column.", call. = FALSE) |
| 36 | + } |
| 37 | + |
| 38 | + if (!all(stats::na.omit(tbl[[event]]) %in% c(0, 1))) { |
| 39 | + stop("`event` must contain only 0/1 values.", call. = FALSE) |
| 40 | + } |
| 41 | + |
| 42 | + if (is.null(regimes)) { |
| 43 | + regimes <- sort(unique(stats::na.omit(tbl[[treatment]]))) |
| 44 | + } |
| 45 | + |
| 46 | + if (length(regimes) == 0) { |
| 47 | + stop("`regimes` must contain at least one treatment strategy.", call. = FALSE) |
| 48 | + } |
| 49 | + |
| 50 | + id_values <- tbl[[id]] |
| 51 | + observed_treatment <- tidyr::replace_na(as.character(tbl[[treatment]]), ".missing") |
| 52 | + regime_values <- as.character(regimes) |
| 53 | + |
| 54 | + clones <- purrr::map( |
| 55 | + regime_values, |
| 56 | + function(regime) { |
| 57 | + clone <- dplyr::mutate( |
| 58 | + tbl, |
| 59 | + .clone_id = paste(id_values, regime, sep = "::"), |
| 60 | + .regime = regime, |
| 61 | + .censored = as.integer(observed_treatment != regime), |
| 62 | + .weight = 1 |
| 63 | + ) |
| 64 | + |
| 65 | + clone[, c( |
| 66 | + ".clone_id", |
| 67 | + ".regime", |
| 68 | + ".censored", |
| 69 | + ".weight", |
| 70 | + setdiff(names(clone), c(".clone_id", ".regime", ".censored", ".weight")) |
| 71 | + )] |
| 72 | + } |
| 73 | + ) |
| 74 | + |
| 75 | + cloned_tbl <- dplyr::bind_rows(clones) |
| 76 | + row_order <- order(cloned_tbl[[id]], cloned_tbl[[follow_up]], cloned_tbl[[".regime"]]) |
| 77 | + |
| 78 | + tibble::as_tibble(cloned_tbl[row_order, , drop = FALSE]) |
| 79 | +} |
| 80 | + |
| 81 | +#' Construct a survival response |
| 82 | +#' |
| 83 | +#' @param data A data frame with follow-up and event columns. |
| 84 | +#' @param follow_up The name of the follow-up time column. |
| 85 | +#' @param event The name of the event indicator column. |
| 86 | +#' |
| 87 | +#' @return An object of class `"Surv"`. |
| 88 | +#' @export |
| 89 | +make_surv_response <- function(data, follow_up, event) { |
| 90 | + .assert_data_frame(data) |
| 91 | + .assert_required_columns(data, c(follow_up, event)) |
| 92 | + |
| 93 | + survival::Surv(time = data[[follow_up]], event = data[[event]]) |
| 94 | +} |
0 commit comments