Merge pull request #449 from tidymodels/survival_reg

Add model spec for `survival_reg`

Author: hfrick

NAMESPACE

@@ -57,6 +57,7 @@ S3method(print,nearest_neighbor)
 S3method(print,nullmodel)
 S3method(print,rand_forest)
 S3method(print,surv_reg)
+S3method(print,survival_reg)
 S3method(print,svm_linear)
 S3method(print,svm_poly)
 S3method(print,svm_rbf)
@@ -96,6 +97,7 @@ S3method(update,multinom_reg)
 S3method(update,nearest_neighbor)
 S3method(update,rand_forest)
 S3method(update,surv_reg)
+S3method(update,survival_reg)
 S3method(update,svm_linear)
 S3method(update,svm_poly)
 S3method(update,svm_rbf)
@@ -198,6 +200,7 @@ export(show_fit)
 export(show_model_info)
 export(stan_conf_int)
 export(surv_reg)
+export(survival_reg)
 export(svm_linear)
 export(svm_poly)
 export(svm_rbf)

NEWS.md

@@ -6,6 +6,8 @@
 
 * A new linear SVM model `svm_linear()` is now available with the `LiblineaR` engine (#424) and the `kernlab` engine (#438), and the `LiblineaR` engine is available for `logistic_reg()` as well (#429). These models can use sparse matrices via `fit_xy()` (#447).
 
+* New model specification `survival_reg()` for the new mode `"censored regression"`. (#444)
+
 # parsnip 0.1.5
 
 * An RStudio add-in is available that makes writing multiple `parsnip` model specifications to the source window. It can be accessed via the IDE addin menus or by calling `parsnip_addin()`.

R/survival_reg.R

@@ -0,0 +1,117 @@
+#' General Interface for Parametric Survival Models
+#'
+#' `survival_reg()` is a way to generate a _specification_ of a model
+#'  before fitting and allows the model to be created using
+#'  R. The main argument for the
+#'  model is:
+#' \itemize{
+#'   \item \code{dist}: The probability distribution of the outcome.
+#' }
+#' This argument is converted to its specific names at the
+#'  time that the model is fit. Other options and argument can be
+#'  set using `set_engine()`. If left to its default
+#'  here (`NULL`), the value is taken from the underlying model
+#'  functions.
+#'
+#' @inheritParams boost_tree
+#' @param mode A single character string for the type of model.
+#'  The only possible value for this model is "censored regression".
+#' @param dist A character string for the outcome distribution. "weibull" is
+#'  the default.
+#' @details
+#' The data given to the function are not saved and are only used
+#' to determine the _mode_ of the model. For `survival_reg()`,the
+#' mode will always be "censored regression".
+#'
+#' Since survival models typically involve censoring (and require the use of
+#' [survival::Surv()] objects), the [fit()] function will require that the
+#' survival model be specified via the formula interface.
+#'
+#' @seealso [fit()], [survival::Surv()]
+#' @examples
+#' survival_reg()
+#' # Parameters can be represented by a placeholder:
+#' survival_reg(dist = varying())
+#'
+#' @export
+survival_reg <- function(mode = "censored regression", dist = NULL) {
+
+  args <- list(
+    dist = enquo(dist)
+  )
+
+  new_model_spec(
+    "survival_reg",
+    args = args,
+    eng_args = NULL,
+    mode = mode,
+    method = NULL,
+    engine = NULL
+  )
+}
+
+#' @export
+print.survival_reg <- function(x, ...) {
+  cat("Parametric Survival Regression Model Specification (", x$mode, ")\n\n", sep = "")
+  model_printer(x, ...)
+
+  if (!is.null(x$method$fit$args)) {
+    cat("Model fit template:\n")
+    print(show_call(x))
+  }
+
+  invisible(x)
+}
+
+# ------------------------------------------------------------------------------
+
+#' Update a Parametric Survival Regression Specification
+#'
+#' If parameters need to be modified, this function can be used
+#'  in lieu of recreating the object from scratch.
+#'
+#' @inheritParams update.boost_tree
+#' @param object A survival regression model specification.
+#' @examples
+#' model <- survival_reg(dist = "weibull")
+#' model
+#' update(model, dist = "lnorm")
+#' @method update survival_reg
+#' @rdname survival_reg
+#' @export
+update.survival_reg <- function(object, parameters = NULL, dist = NULL, fresh = FALSE, ...) {
+
+  eng_args <- update_engine_parameters(object$eng_args, ...)
+
+  if (!is.null(parameters)) {
+    parameters <- check_final_param(parameters)
+  }
+
+  args <- list(
+    dist = enquo(dist)
+  )
+
+  args <- update_main_parameters(args, parameters)
+
+  if (fresh) {
+    object$args <- args
+    object$eng_args <- eng_args
+  } else {
+    null_args <- map_lgl(args, null_value)
+    if (any(null_args))
+      args <- args[!null_args]
+    if (length(args) > 0)
+      object$args[names(args)] <- args
+    if (length(eng_args) > 0)
+      object$eng_args[names(eng_args)] <- eng_args
+  }
+
+  new_model_spec(
+    "survival_reg",
+    args = object$args,
+    eng_args = object$eng_args,
+    mode = object$mode,
+    method = NULL,
+    engine = object$engine
+  )
+}

R/survival_reg_data.R

@@ -0,0 +1,7 @@
+
+set_new_model("survival_reg")
+set_model_mode("survival_reg", "censored regression")
+
+# ------------------------------------------------------------------------------
+
+# parnip just contains the model specification, the engines are the censored package.

man/survival_reg.Rd

@@ -0,0 +1,58 @@
+
+test_that("primary argument", {
+  new_empty_quosure <- function(expr) {
+    rlang::new_quosure(expr, env = rlang::empty_env())
+  }
+
+  normal <- survival_reg(dist = "lnorm")
+  expect_equal(
+    normal$args,
+    list(dist = new_empty_quosure("lnorm"))
+  )
+
+  dist_v <- survival_reg(dist = varying())
+  expect_equal(
+    dist_v$args,
+    list(dist = new_empty_quosure(varying()))
+  )
+})
+
+test_that("updating", {
+  new_empty_quosure <- function(expr) {
+    rlang::new_quosure(expr, env = rlang::empty_env())
+  }
+
+  basic <- survival_reg()
+
+  update_chr <- update(basic, dist = "lnorm")
+  expect_equal(
+    update_chr$args,
+    list(dist = new_empty_quosure("lnorm"))
+  )
+
+  param_tibb <- tibble::tibble(dist = "weibull")
+  update_tibb <- update(basic, param_tibb)
+  expect_equal(
+    update_tibb$args,
+    list(dist = "weibull")
+  )
+
+  param_list <- as.list(param_tibb)
+  update_list <- update(basic, param_list)
+  expect_equal(
+    update_list$args,
+    list(dist = "weibull")
+  )
+
+})
+
+test_that("bad input", {
+  expect_error(survival_reg(mode = ", classification"))
+})
+
+test_that("wrong fit interface", {
+  expect_error(
+    survival_reg() %>% fit_xy(),
+    "must use the formula interface"
+  )
+})