un-do return values for failed models for issue #123

topepo · topepo · commit d8c7484e165f · 2019-02-27T12:23:17.000-05:00
diff --git a/NAMESPACE b/NAMESPACE
@@ -17,6 +17,7 @@ S3method(predict,model_fit)
 S3method(predict,model_spec)
 S3method(predict,nullmodel)
 S3method(predict_class,"_lognet")
+S3method(predict_class,"_multnet")
 S3method(predict_classprob,"_lognet")
 S3method(predict_classprob,"_multnet")
 S3method(predict_numeric,"_elnet")
diff --git a/R/predict.R b/R/predict.R
@@ -112,6 +112,11 @@ predict.model_fit <- function(object, new_data, type = NULL, opts = list(), ...)
   if (any(names(the_dots) == "newdata"))
     stop("Did you mean to use `new_data` instead of `newdata`?", call. = FALSE)
 
+  if (inherits(object$fit, "try-error")) {
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
+  }
+
   other_args <- c("level", "std_error", "quantile") # "time" for survival probs later
   is_pred_arg <- names(the_dots) %in% other_args
   if (any(!is_pred_arg)) {
@@ -242,8 +247,13 @@ prepare_data <- function(object, new_data) {
 #'  multiple rows per sub-model.
 #' @keywords internal
 #' @export
-multi_predict <- function(object, ...)
+multi_predict <- function(object, ...) {
+  if (inherits(object$fit, "try-error")) {
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
+  }
   UseMethod("multi_predict")
+}
 
 #' @keywords internal
 #' @export
@@ -256,11 +266,3 @@ multi_predict.default <- function(object, ...)
 predict.model_spec <- function(object, ...) {
   stop("You must use `fit()` on your model specification before you can use `predict()`.", call. = FALSE)
 }
-
-
-failed_class <- function(n, lvl) {
-  tibble(.pred = rep(NA_real_, n))
-}
-
-
-
diff --git a/R/predict_class.R b/R/predict_class.R
@@ -17,7 +17,8 @@ predict_class.model_fit <- function(object, new_data, ...) {
     stop("No class prediction module defined for this model.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    return(failed_class(lvl = object$lvl))
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
@@ -54,13 +55,3 @@ predict_class.model_fit <- function(object, new_data, ...) {
 predict_class <- function(object, ...)
   UseMethod("predict_class")
 
-# ------------------------------------------------------------------------------
-
-# Some `predict()` helpers for failed models:
-
-failed_class <- function(n = 1, lvl) {
-  res <- rep(NA_character_, n)
-  res <- factor(res, levels = lvl)
-  res
-}
-
diff --git a/R/predict_classprob.R b/R/predict_classprob.R
@@ -14,7 +14,8 @@ predict_classprob.model_fit <- function(object, new_data, ...) {
     stop("No class probability module defined for this model.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    return(failed_classprob(lvl = object$lvl))
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
@@ -49,15 +50,3 @@ predict_classprob.model_fit <- function(object, new_data, ...) {
 # @inheritParams predict.model_fit
 predict_classprob <- function(object, ...)
   UseMethod("predict_classprob")
-
-
-# ------------------------------------------------------------------------------
-
-# Some `predict()` helpers for failed models:
-
-failed_classprob <- function(n = 1, lvl) {
-  res <- matrix(NA_real_, nrow = n, ncol = length(lvl))
-  colnames(res) <- lvl
-  as_tibble(res)
-}
-
diff --git a/R/predict_interval.R b/R/predict_interval.R
@@ -15,7 +15,8 @@ predict_confint.model_fit <- function(object, new_data, level = 0.95, std_error
          "engine.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    return(failed_int(lvl = object$lvl))
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
@@ -50,24 +51,6 @@ predict_confint <- function(object, ...)
 
 # ------------------------------------------------------------------------------
 
-# Some `predict()` helpers for failed models:
-
-failed_int <- function(n = 1, lvl = NULL, nms = ".pred") {
-  # TODO figure out multivariate models
-  if (is.null(lvl)) {
-    res <- matrix(NA_real_, nrow = n, ncol = length(nms) * 2)
-    colnames(res) <- c(".pred_lower", ".pred_upper")
-  } else {
-    res <- matrix(NA_real_, ncol = length(lvl) * 2, nrow = n)
-    nms <- expand.grid(c("lower", "upper"), lvl)
-    nms <- paste(".pred", nms$Var1, nms$Var2, sep = "_")
-    colnames(res) <- nms
-  }
-  as_tibble(res)
-}
-
-# ------------------------------------------------------------------------------
-
 # @keywords internal
 # @rdname other_predict
 # @inheritParams predict.model_fit
@@ -81,7 +64,8 @@ predict_predint.model_fit <- function(object, new_data, level = 0.95, std_error
          "engine.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    return(failed_int(lvl = object$lvl))
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
diff --git a/R/predict_numeric.R b/R/predict_numeric.R
@@ -15,8 +15,8 @@ predict_numeric.model_fit <- function(object, new_data, ...) {
     stop("No prediction module defined for this model.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    # TODO handle multivariate cases
-    return(failed_numeric())
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
@@ -51,21 +51,3 @@ predict_numeric.model_fit <- function(object, new_data, ...) {
 # @inheritParams predict_numeric.model_fit
 predict_numeric <- function(object, ...)
   UseMethod("predict_numeric")
-
-# ------------------------------------------------------------------------------
-
-# Some `predict()` helpers for failed models:
-
-failed_numeric <- function(n = 1, nms = ".pred") {
-  res <- matrix(NA_real_, ncol = length(nms), nrow = n)
-  if (length(nms) > 1) {
-    colnames(res) <- nms
-    res <- as_tibble(res)
-  } else {
-    res <- res[,1]
-  }
-  res
-}
-
-
-
diff --git a/R/predict_quantile.R b/R/predict_quantile.R
@@ -1,35 +1,40 @@
 # @keywords internal
 # @rdname other_predict
-# @param quant A vector of numbers between 0 and 1 for the quantile being 
-#  predicted. 
+# @param quant A vector of numbers between 0 and 1 for the quantile being
+#  predicted.
 # @inheritParams predict.model_fit
 # @method predict_quantile model_fit
 # @export predict_quantile.model_fit
 # @export
 predict_quantile.model_fit <-
   function (object, new_data, quantile = (1:9)/10, ...) {
-    
+
     if (is.null(object$spec$method$quantile))
       stop("No quantile prediction method defined for this ",
            "engine.", call. = FALSE)
-    
+
+    if (inherits(object$fit, "try-error")) {
+      warning("Model fit failed; cannot make predictions.", call. = FALSE)
+      return(NULL)
+    }
+
     new_data <- prepare_data(object, new_data)
-    
+
     # preprocess data
     if (!is.null(object$spec$method$quantile$pre))
       new_data <- object$spec$method$quantile$pre(new_data, object)
-    
+
     # Pass some extra arguments to be used in post-processor
     object$spec$method$quantile$args$p <- quantile
     pred_call <- make_pred_call(object$spec$method$quantile)
-    
+
     res <- eval_tidy(pred_call)
-    
+
     # post-process the predictions
     if(!is.null(object$spec$method$quantile$post)) {
       res <- object$spec$method$quantile$post(res, object)
     }
-    
+
     res
   }
 
diff --git a/R/predict_raw.R b/R/predict_raw.R
@@ -18,7 +18,8 @@ predict_raw.model_fit <- function(object, new_data, opts = list(), ...) {
     stop("No raw prediction module defined for this model.", call. = FALSE)
 
   if (inherits(object$fit, "try-error")) {
-    stop("Model fit failed; cannot make predictions.")
+    warning("Model fit failed; cannot make predictions.", call. = FALSE)
+    return(NULL)
   }
 
   new_data <- prepare_data(object, new_data)
diff --git a/man/linear_reg.Rd b/man/linear_reg.Rd
diff --git a/man/logistic_reg.Rd b/man/logistic_reg.Rd
diff --git a/man/multinom_reg.Rd b/man/multinom_reg.Rd
diff --git a/tests/testthat/test_failed_models.R b/tests/testthat/test_failed_models.R
@@ -34,15 +34,14 @@ test_that('numeric model', {
     set_engine("lm") %>%
     fit(Sepal.Length ~ ., data = iris_bad, control = ctrl)
 
-  num_res <- predict(lm_mod, iris_bad[1:11, -1])
-  expect_equal(num_res, tibble(.pred = rep(NA_real_, 1)))
+  expect_warning(num_res <- predict(lm_mod, iris_bad[1:11, -1]))
+  expect_equal(num_res, NULL)
 
-  exp_int_res <- tibble(.pred_lower = rep(NA_real_, 1), .pred_upper = rep(NA_real_, 1))
-  ci_res <- predict(lm_mod, iris_bad[1:11, -1], type = "conf_int")
-  expect_equal(ci_res, exp_int_res)
+  expect_warning(ci_res <- predict(lm_mod, iris_bad[1:11, -1], type = "conf_int"))
+  expect_equal(ci_res, NULL)
 
-  pi_res <- predict(lm_mod, iris_bad[1:11, -1], type = "pred_int")
-  expect_equal(pi_res, exp_int_res)
+  expect_warning(pi_res <- predict(lm_mod, iris_bad[1:11, -1], type = "pred_int"))
+  expect_equal(pi_res, NULL)
 
 })
 
@@ -54,24 +53,22 @@ test_that('classification model', {
     set_engine("glm") %>%
     fit(Class ~ log(funded_amnt) + int_rate + big_num, data = lending_club, control = ctrl)
 
-  cls_res <- predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class))
-  exp_cls_res <- tibble(.pred_class = factor(rep(NA_character_, 1), levels = lvl))
-  expect_equal(cls_res, exp_cls_res)
-
-  prb_res <-
-    predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class), type = "prob")
-  exp_prb_res <- tibble(.pred_bad = rep(NA_real_, 1), .pred_good = rep(NA_real_, 1))
-  expect_equal(prb_res, exp_prb_res)
-
-  ci_res <-
-    predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class), type = "conf_int")
-  exp_ci_res <-
-    tibble(
-      .pred_lower_bad  = rep(NA_real_, 1),
-      .pred_upper_bad  = rep(NA_real_, 1),
-      .pred_lower_good = rep(NA_real_, 1),
-      .pred_upper_good = rep(NA_real_, 1)
-      )
-  expect_equal(ci_res, exp_ci_res)
+  expect_warning(
+    cls_res <-
+      predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class))
+  )
+  expect_equal(cls_res, NULL)
+
+  expect_warning(
+    prb_res <-
+      predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class), type = "prob")
+  )
+  expect_equal(prb_res, NULL)
+
+  expect_warning(
+    ci_res <-
+      predict(log_reg, lending_club %>%  dplyr::slice(1:7) %>% dplyr::select(-Class), type = "conf_int")
+  )
+  expect_equal(ci_res, NULL)
 })
 

Original file line number	Diff line number	Diff line change
`@@ -18,7 +18,8 @@ predict_raw.model_fit <- function(object, new_data, opts = list(), ...) {`
`18`	`18`	`stop("No raw prediction module defined for this model.", call. = FALSE)`
`19`	`19`
`20`	`20`	`if (inherits(object$fit, "try-error")) {`
`21`		`- stop("Model fit failed; cannot make predictions.")`
	`21`	`+ warning("Model fit failed; cannot make predictions.", call. = FALSE)`
	`22`	`+ return(NULL)`
`22`	`23`	`}`
`23`	`24`
`24`	`25`	`new_data <- prepare_data(object, new_data)`