R/surv_partial.rfsrc.R

In ggRandomForests: Visually Exploring Random Forests

#' Survival partial dependence data for one or more predictors
#'
#' \strong{Deprecated.} Use \code{\link{gg_partial_rfsrc}} instead, which
#' returns a classed \code{gg_partial_rfsrc} object with a dedicated
#' \code{plot()} method.
#'
#' Computes partial dependence curves for a survival or competing-risk
#' \code{\link[randomForestSRC]{rfsrc}} forest by calling
#' \code{\link[randomForestSRC]{partial.rfsrc}} at \code{npts} evenly-spaced
#' unique values of each predictor across all stored event times.
#'
#' @param rforest A fitted \code{\link[randomForestSRC]{rfsrc}} survival or
#'   competing-risk forest object.
#' @param var_list Character vector of predictor names for which partial
#'   dependence should be computed. Each must appear in
#'   \code{rforest$xvar.names}.
#' @param npts Integer; the number of predictor grid points to evaluate
#'   (default 25). Evenly-spaced unique values are sampled from each predictor.
#' @param partial.type The prediction type to return. For survival forests one
#'   of \code{"surv"} (default), \code{"mort"}, or \code{"chf"}. For competing
#'   risk forests one of \code{"years.lost"}, \code{"cif"}, or \code{"chf"}.
#'   See \code{\link[randomForestSRC]{partial.rfsrc}} for full details.
#'
#' @return A named list with one element per variable in \code{var_list}. Each
#'   element is itself a list with:
#'   \describe{
#'     \item{name}{The predictor variable name (character).}
#'     \item{dta}{The raw output of
#'       \code{\link[randomForestSRC]{get.partial.plot.data}}, a list containing
#'       at minimum \code{x} (predictor values) and \code{yhat} (partial
#'       predictions), and for survival/competing risk, \code{partial.time}.}
#'   }
#'
#' @seealso \code{\link{gg_partial_rfsrc}},
#'   \code{\link[randomForestSRC]{partial.rfsrc}},
#'   \code{\link[randomForestSRC]{get.partial.plot.data}}
#'
#' @importFrom randomForestSRC partial.rfsrc
#' @examples
#' ## ------------------------------------------------------------
#' ## survival
#' ## ------------------------------------------------------------
#'
#' data(veteran, package = "randomForestSRC")
#' v.obj <- randomForestSRC::rfsrc(Surv(time,status)~.,
#'   veteran, nsplit = 10, ntree = 100)
#'
#' spart <- surv_partial.rfsrc(v.obj, var_list="age", partial.type = "mort")
#'
#' ## partial effect of age on mortality
#' partial.obj <- partial(v.obj,
#'                        partial.type = "mort",
#'                        partial.xvar = "age",
#'                        partial.values = v.obj$xvar$age,
#'                        partial.time = v.obj$time.interest)
#' pdta <- get.partial.plot.data(partial.obj)
#'
#' plot(lowess(pdta$x, pdta$yhat, f = 1/3),
#'      type = "l", xlab = "age", ylab = "adjusted mortality")
#'
#' ## example where x is discrete - partial effect of age on mortality
#' ## we use the granule=TRUE option
#' partial.obj <- partial(v.obj,
#'                        partial.type = "mort",
#'                        partial.xvar = "trt",
#'                        partial.values = v.obj$xvar$trt,
#'                        partial.time = v.obj$time.interest)
#' pdta <- get.partial.plot.data(partial.obj, granule = TRUE)
#' boxplot(pdta$yhat ~ pdta$x, xlab = "treatment", ylab = "partial effect")
#'
#'
#' ## partial effects of karnofsky score on survival
#' karno <- quantile(v.obj$xvar$karno)
#' partial.obj <- partial(v.obj,
#'                        partial.type = "surv",
#'                        partial.xvar = "karno",
#'                        partial.values = karno,
#'                        partial.time = v.obj$time.interest)
#' pdta <- get.partial.plot.data(partial.obj)
#'
#' matplot(pdta$partial.time, t(pdta$yhat), type = "l", lty = 1,
#'         xlab = "time", ylab = "karnofsky adjusted survival")
#' legend("topright", legend = paste0("karnofsky = ", karno), fill = 1:5)
#'
#'
#' ## ------------------------------------------------------------
#' ## competing risk
#' ## ------------------------------------------------------------
#'
#' data(follic, package = "randomForestSRC")
#' follic.obj <- rfsrc(Surv(time, status) ~ ., follic, nsplit = 3, ntree = 100)
#'
#' ## partial effect of age on years lost
#' partial.obj <- partial(follic.obj,
#'                        partial.type = "years.lost",
#'                        partial.xvar = "age",
#'                        partial.values = follic.obj$xvar$age,
#'                        partial.time = follic.obj$time.interest)
#' pdta1 <- get.partial.plot.data(partial.obj, target = 1)
#' pdta2 <- get.partial.plot.data(partial.obj, target = 2)
#'
#' # Save and restore the user's graphical parameters per CRAN policy.
#' oldpar <- par(no.readonly = TRUE)
#' on.exit(par(oldpar))
#' par(mfrow = c(2, 2))
#' plot(lowess(pdta1$x, pdta1$yhat),
#'      type = "l", xlab = "age", ylab = "adjusted years lost relapse")
#' plot(lowess(pdta2$x, pdta2$yhat),
#'      type = "l", xlab = "age", ylab = "adjusted years lost death")
#'
#' ## partial effect of age on cif
#' partial.obj <- partial(follic.obj,
#'                        partial.type = "cif",
#'                        partial.xvar = "age",
#'                        partial.values = quantile(follic.obj$xvar$age),
#'                        partial.time = follic.obj$time.interest)
#' pdta1 <- get.partial.plot.data(partial.obj, target = 1)
#' pdta2 <- get.partial.plot.data(partial.obj, target = 2)
#'
#' matplot(pdta1$partial.time, t(pdta1$yhat), type = "l", lty = 1,
#'         xlab = "time", ylab = "age adjusted cif for relapse")
#' matplot(pdta2$partial.time, t(pdta2$yhat), type = "l", lty = 1,
#'         xlab = "time", ylab = "age adjusted cif for death")
#'
#' @export surv_partial.rfsrc
surv_partial.rfsrc <- function(rforest, var_list, npts = 25, partial.type = "surv") { # nolint: object_name_linter
  .Deprecated(
    new     = "gg_partial_rfsrc",
    package = "ggRandomForests",
    msg     = paste0(
      "'surv_partial.rfsrc' is deprecated and will be removed in a future release.\n",
      "Use 'gg_partial_rfsrc()' instead, which returns a classed object with a\n",
      "dedicated plot() method."
    )
  )
  ###----------Partial dependency estimation, for each variable, at each time point ----
  surv.lst <- lapply(var_list, function(xvar) {
    ## extract the key variable. Use message() (suppressible) instead of
    ## cat() so the function plays nicely inside notebooks/Shiny/quarto.
    message("partial plot for: ", xvar)

    ## determine the partial plot data
    xv <- sort(unique(rforest$xvar[, xvar]))
    xv <- unique(xv[seq(1, length(xv), length = npts)])

    ## Get the partial.plot.data
    partial.dta    <- randomForestSRC::get.partial.plot.data(
      randomForestSRC::partial.rfsrc(
        rforest,
        partial.type = partial.type,
        partial.xvar = xvar,
        partial.values = xv,
        partial.time = rforest$time.interest
      )
    )

    list(name = xvar,
         dta = partial.dta)

  })
  return(surv.lst)
}