|
| 1 | +#' General Interface for Parametric Survival Models |
| 2 | +#' |
| 3 | +#' `surv_reg` is a way to generate a _specification_ of a model |
| 4 | +#' before fitting and allows the model to be created using |
| 5 | +#' R. The main argument for the |
| 6 | +#' model is: |
| 7 | +#' \itemize{ |
| 8 | +#' \item \code{dist}: The probability distribution of the outcome. |
| 9 | +#' } |
| 10 | +#' This argument is converted to its specific names at the |
| 11 | +#' time that the model is fit. Other options and argument can be |
| 12 | +#' set using the `others` argument. If left to its default |
| 13 | +#' here (`NULL`), the value is taken from the underlying model |
| 14 | +#' functions. |
| 15 | +#' |
| 16 | +#' The data given to the function are not saved and are only used |
| 17 | +#' to determine the _mode_ of the model. For `surv_reg`,the |
| 18 | +#' mode will always be "regression". |
| 19 | +#' |
| 20 | +#' Since survival models typically involve censoring (and require the use of |
| 21 | +#' [survival::Surv()] objects), the [fit()] function will require that the |
| 22 | +#' survival model be specified via the formula or recipes interfaces. |
| 23 | +#' |
| 24 | +#' For recipes, right censoring indicators should be specified |
| 25 | +#' using the "censoring var" role (see examples below). Also, for |
| 26 | +#' the engine that uses `flexsurv::flexsurvfit`, extra roles can |
| 27 | +#' be used for non-location parameters (e.g. `sigma` or `sdlog`) so |
| 28 | +#' that other distributional parameters can be functions or |
| 29 | +#' covariates. See the example below as well as Jackson (2016). |
| 30 | +#' |
| 31 | +#' Also, for the `flexsurv::flexsurvfit` engine, the typical |
| 32 | +#' `strata` function cannot be used. To achieve the same effect, |
| 33 | +#' the extra parameter roles can be used (as described above). |
| 34 | +#' |
| 35 | +#' The model can be created using the [fit()] function using the |
| 36 | +#' following _engines_: |
| 37 | +#' \itemize{ |
| 38 | +#' \item \pkg{R}: `"flexsurv"` |
| 39 | +#' } |
| 40 | +#' @param mode A single character string for the type of model. |
| 41 | +#' The only possible value for this model is "regression". |
| 42 | +#' @param others A named list of arguments to be used by the |
| 43 | +#' underlying models (e.g., `flexsurv::flexsurvreg`). These are not evaluated |
| 44 | +#' until the model is fit and will be substituted into the model |
| 45 | +#' fit expression. |
| 46 | +#' @param dist A character string for the outcome distribution. "weibull" is |
| 47 | +#' the default. |
| 48 | +#' @param ... Used for S3 method consistency. Any arguments passed to |
| 49 | +#' the ellipses will result in an error. Use `others` instead. |
| 50 | +#' @seealso [varying()], [fit()], [survival::Surv()] |
| 51 | +#' @references Jackson, C. (2016). `flexsurv`: A Platform for Parametric Survival |
| 52 | +#' Modeling in R. _Journal of Statistical Software_, 70(8), 1 - 33. |
| 53 | +#' @examples |
| 54 | +#' surv_reg() |
| 55 | +#' # Parameters can be represented by a placeholder: |
| 56 | +#' surv_reg(dist = varying()) |
| 57 | +#' |
| 58 | +#' # Examples of using recipes with the `fit` function |
| 59 | +#' |
| 60 | +#' library(dplyr) |
| 61 | +#' library(recipes) |
| 62 | +#' library(survival) |
| 63 | +#' data(lung) |
| 64 | +#' |
| 65 | +#' surv_rec <- recipe(time ~ ., data = lung) %>% |
| 66 | +#' add_role(status, new_role = "censoring var") %>% |
| 67 | +#' # exclude some vars from being in the model |
| 68 | +#' add_role(inst, sex, ph.karno, pat.karno, meal.cal, wt.loss, |
| 69 | +#' new_role = "other variables") |
| 70 | +#' |
| 71 | +#' log_normal_mod <- surv_reg(dist = "lnorm") |
| 72 | +#' |
| 73 | +#' fit(log_normal_mod, recipe = surv_rec, data = lung, engine = "flexsurv") |
| 74 | +#' |
| 75 | +#' # make the normal variance be a function of gender: |
| 76 | +#' |
| 77 | +#' strata_model <- surv_rec %>% |
| 78 | +#' add_role(sex, new_role = "sdlog") |
| 79 | +#' |
| 80 | +#' fit(log_normal_mod, recipe = strata_model, data = lung, engine = "flexsurv") |
| 81 | +#' |
| 82 | +#' @export |
| 83 | +surv_reg <- |
| 84 | + function(mode = "regression", |
| 85 | + dist = NULL, |
| 86 | + others = list(), |
| 87 | + ...) { |
| 88 | + check_empty_ellipse(...) |
| 89 | + if (!(mode %in% surv_reg_modes)) |
| 90 | + stop( |
| 91 | + "`mode` should be one of: ", |
| 92 | + paste0("'", surv_reg_modes, "'", collapse = ", "), |
| 93 | + call. = FALSE |
| 94 | + ) |
| 95 | + args <- list(dist = dist) |
| 96 | + |
| 97 | + no_value <- !vapply(others, is.null, logical(1)) |
| 98 | + others <- others[no_value] |
| 99 | + |
| 100 | + # write a constructor function |
| 101 | + out <- list( |
| 102 | + args = args, |
| 103 | + others = others, |
| 104 | + mode = mode, |
| 105 | + method = NULL, |
| 106 | + engine = NULL |
| 107 | + ) |
| 108 | + class(out) <- make_classes("surv_reg") |
| 109 | + out |
| 110 | + } |
| 111 | + |
| 112 | +#' @export |
| 113 | +print.surv_reg <- function(x, ...) { |
| 114 | + cat("Parametric Survival Regression Model Specification (", x$mode, ")\n\n", sep = "") |
| 115 | + model_printer(x, ...) |
| 116 | + |
| 117 | + if(!is.null(x$method$fit_args)) { |
| 118 | + cat("Model fit template:\n") |
| 119 | + print(show_call(x)) |
| 120 | + } |
| 121 | + |
| 122 | + invisible(x) |
| 123 | +} |
| 124 | + |
| 125 | +################################################################### |
| 126 | + |
| 127 | +#' Update a Parametric Survival Regression Specification |
| 128 | +#' |
| 129 | +#' If parameters need to be modified, this function can be used |
| 130 | +#' in lieu of recreating the object from scratch. |
| 131 | +#' |
| 132 | +#' @inheritParams surv_reg |
| 133 | +#' @param object A survival regression model specification. |
| 134 | +#' @param fresh A logical for whether the arguments should be |
| 135 | +#' modified in-place of or replaced wholesale. |
| 136 | +#' @return An updated model specification. |
| 137 | +#' @examples |
| 138 | +#' model <- surv_reg(dist = "weibull") |
| 139 | +#' model |
| 140 | +#' update(model, dist = "lnorm") |
| 141 | +#' @method update surv_reg |
| 142 | +#' @rdname surv_reg |
| 143 | +#' @export |
| 144 | +update.surv_reg <- |
| 145 | + function(object, |
| 146 | + dist = NULL, |
| 147 | + others = list(), |
| 148 | + fresh = FALSE, |
| 149 | + ...) { |
| 150 | + check_empty_ellipse(...) |
| 151 | + |
| 152 | + args <- list(dist = dist) |
| 153 | + |
| 154 | + if (fresh) { |
| 155 | + object$args <- args |
| 156 | + } else { |
| 157 | + null_args <- map_lgl(args, null_value) |
| 158 | + if (any(null_args)) |
| 159 | + args <- args[!null_args] |
| 160 | + if (length(args) > 0) |
| 161 | + object$args[names(args)] <- args |
| 162 | + } |
| 163 | + |
| 164 | + if (length(others) > 0) { |
| 165 | + if (fresh) |
| 166 | + object$others <- others |
| 167 | + else |
| 168 | + object$others[names(others)] <- others |
| 169 | + } |
| 170 | + |
| 171 | + object |
| 172 | + } |
| 173 | + |
| 174 | + |
| 175 | +################################################################### |
| 176 | + |
| 177 | +#' @export |
| 178 | +translate.surv_reg <- function(x, engine, ...) { |
| 179 | + x <- translate.default(x, engine, ...) |
| 180 | + |
| 181 | + if (x$engine == "flexsurv") { |
| 182 | + # `dist` has no default in the function |
| 183 | + if (all(names(x$method$fit_args) != "dist")) |
| 184 | + x$method$fit_args$dist <- "weibull" |
| 185 | + } |
| 186 | + x |
| 187 | +} |
| 188 | + |
0 commit comments