add predict_hazard()

Author: EmilHvitfeldt

NAMESPACE

@@ -31,6 +31,7 @@ S3method(predict_classprob,"_lognet")
 S3method(predict_classprob,"_multnet")
 S3method(predict_classprob,model_fit)
 S3method(predict_confint,model_fit)
+S3method(predict_hazard,model_fit)
 S3method(predict_linear_pred,model_fit)
 S3method(predict_numeric,"_elnet")
 S3method(predict_numeric,model_fit)
@@ -153,6 +154,7 @@ export(predict.model_fit)
 export(predict_class.model_fit)
 export(predict_classprob.model_fit)
 export(predict_confint.model_fit)
+export(predict_hazard.model_fit)
 export(predict_linear_pred)
 export(predict_linear_pred.model_fit)
 export(predict_numeric)

R/aaa_models.R

@@ -32,7 +32,7 @@ parsnip$modes <- c("regression", "classification", "unknown")
 
 pred_types <-
   c("raw", "numeric", "class", "prob", "conf_int", "pred_int", "quantile",
-    "time", "survival", "linear_pred")
+    "time", "survival", "linear_pred", "hazard")
 
 # ------------------------------------------------------------------------------
 

R/predict.R

@@ -147,6 +147,7 @@ predict.model_fit <- function(object, new_data, type = NULL, opts = list(), ...)
     time        = predict_time(object = object, new_data = new_data, ...),
     survival    = predict_survival(object = object, new_data = new_data, ...),
     linear_pred = predict_linear_pred(object = object, new_data = new_data, ...),
+    hazard      = predict_hazard(object = object, new_data = new_data, ...),
     raw         = predict_raw(object = object, new_data = new_data, opts = opts, ...),
     rlang::abort(glue::glue("I don't know about type = '{type}'"))
   )
@@ -158,6 +159,7 @@ predict.model_fit <- function(object, new_data, type = NULL, opts = list(), ...)
       prob        = format_classprobs(res),
       time        = format_time(res),
       survival    = format_survival(res),
+      hazard      = format_hazard(res),
       linear_pred = format_linear_pred(res),
       res
     )
@@ -265,6 +267,19 @@ format_linear_pred <- function(x) {
   x
 }
 
+format_hazard <- function(x) {
+  if (isTRUE(ncol(x) > 1) | is.data.frame(x)) {
+    x <- as_tibble(x, .name_repair = "minimal")
+    if (!any(grepl("^\\.time", names(x)))) {
+      names(x) <- paste0(".time_", names(x))
+    }
+  } else {
+    x <- tibble(.pred_hazard = unname(x))
+  }
+
+  x
+}
+
 make_pred_call <- function(x) {
   if ("pkg" %in% names(x$func))
     cl <-

R/predict_hazard.R

@@ -0,0 +1,43 @@
+#' @keywords internal
+#' @rdname other_predict
+#' @inheritParams predict.model_fit
+#' @method predict_hazard model_fit
+#' @export predict_hazard.model_fit
+#' @export
+predict_hazard.model_fit <-
+  function(object, new_data, .time, ...) {
+
+    if (is.null(object$spec$method$pred$hazard))
+      rlang::abort("No hazard prediction method defined for this engine.")
+
+    if (inherits(object$fit, "try-error")) {
+      rlang::warn("Model fit failed; cannot make predictions.")
+      return(NULL)
+    }
+
+    new_data <- prepare_data(object, new_data)
+
+    # preprocess data
+    if (!is.null(object$spec$method$pred$hazard$pre))
+      new_data <- object$spec$method$pred$hazard$pre(new_data, object)
+
+    # Pass some extra arguments to be used in post-processor
+    object$spec$method$pred$hazard$args$.time <- .time
+    pred_call <- make_pred_call(object$spec$method$pred$hazard)
+
+    res <- eval_tidy(pred_call)
+
+    # post-process the predictions
+    if(!is.null(object$spec$method$pred$hazard$post)) {
+      res <- object$spec$method$pred$hazard$post(res, object)
+    }
+
+    res
+  }
+
+# @export
+# @keywords internal
+# @rdname other_predict
+# @inheritParams predict.model_fit
+predict_hazard <- function (object, ...)
+  UseMethod("predict_hazard")