Merge pull request #381 from tidymodels/regression-xy-error

Update and make `mode` checking more robust

Author: topepo

R/fit_helpers.R

@@ -7,13 +7,15 @@
 form_form <-
   function(object, control, env, ...) {
 
+    # prob rewrite this as simple subset/levels
+    y_levels <- levels_from_formula(env$formula, env$data)
+
     if (object$mode == "classification") {
-      # prob rewrite this as simple subset/levels
-      y_levels <- levels_from_formula(env$formula, env$data)
       if (!inherits(env$data, "tbl_spark") && is.null(y_levels))
-        rlang::abort("For classification models, the outcome should be a factor.")
-    } else {
-      y_levels <- NULL
+        rlang::abort("For a classification model, the outcome should be a factor.")
+    } else if (object$mode == "regression") {
+      if (!inherits(env$data, "tbl_spark") && !is.null(y_levels))
+        rlang::abort("For a regression model, the outcome should be numeric.")
     }
 
     object <- check_mode(object, y_levels)
@@ -57,11 +59,7 @@ xy_xy <- function(object, env, control, target = "none", ...) {
     rlang::abort("spark objects can only be used with the formula interface to `fit()`")
 
   object <- check_mode(object, levels(env$y))
-
-  if (object$mode == "classification") {
-    if (is.null(levels(env$y)))
-      rlang::abort("For classification models, the outcome should be a factor.")
-  }
+  check_outcome(env$y, object)
 
   encoding_info <-
     get_encoding(class(object)[1]) %>%
@@ -133,7 +131,10 @@ form_xy <- function(object, control, env,
   res <- list(lvl = levels_from_formula(env$formula, env$data), spec = object)
   if (object$mode == "classification") {
     if (is.null(res$lvl))
-      rlang::abort("For classification models, the outcome should be a factor.")
+      rlang::abort("For a classification model, the outcome should be a factor.")
+  } else if (object$mode == "regression") {
+    if (!is.null(res$lvl))
+      rlang::abort("For a regression model, the outcome should be numeric.")
   }
 
   res <- xy_xy(
@@ -153,10 +154,7 @@ form_xy <- function(object, control, env,
 
 xy_form <- function(object, env, control, ...) {
 
-  if (object$mode == "classification") {
-    if (is.null(levels(env$y)))
-      rlang::abort("For classification models, the outcome should be a factor.")
-  }
+  check_outcome(env$y, object)
 
   encoding_info <-
     get_encoding(class(object)[1]) %>%

R/misc.R

@@ -212,11 +212,11 @@ check_outcome <- function(y, spec) {
   if (spec$mode == "unknown") {
     return(invisible(NULL))
   } else if (spec$mode == "regression") {
-    if (!is.numeric(y))
-      rlang::abort("The model outcome should be numeric for regression models.")
+    if (!all(map_lgl(y, is.numeric)))
+      rlang::abort("For a regression model, the outcome should be numeric.")
   } else if (spec$mode == "classification") {
-    if (!is.factor(y)) {
-      rlang::abort("The model outcome should be a factor for regression models.")
+    if (!all(map_lgl(y, is.factor))) {
+      rlang::abort("For a classification model, the outcome should be a factor.")
     }
   }
   invisible(NULL)

tests/testthat/test_boost_tree_xgboost.R

@@ -122,6 +122,16 @@ test_that('xgboost execution, regression', {
     ),
     regexp = NA
   )
+
+  expect_error(
+    res <- parsnip::fit_xy(
+      car_basic,
+      x = mtcars[, num_pred],
+      y = factor(mtcars$vs),
+      control = ctrl
+    ),
+    regexp = "For a regression model"
+  )
 })
 
 

tests/testthat/test_linear_reg.R

@@ -241,6 +241,16 @@ test_that('lm execution', {
     regexp = NA
   )
 
+  expect_error(
+    res <- fit_xy(
+      hpc_basic,
+      x = hpc[, num_pred],
+      y = hpc$class,
+      control = ctrl
+    ),
+    regexp = "For a regression model"
+  )
+
   expect_error(
     res <- fit(
       hpc_basic,
@@ -250,13 +260,15 @@ test_that('lm execution', {
     )
   )
 
-  lm_form_catch <- fit(
-    hpc_basic,
-    hpc_bad_form,
-    data = hpc,
-    control = caught_ctrl
+  expect_error(
+    lm_form_catch <- fit(
+      hpc_basic,
+      hpc_bad_form,
+      data = hpc,
+      control = caught_ctrl
+    ),
+    regexp = "For a regression model"
   )
-  expect_true(inherits(lm_form_catch$fit, "try-error"))
 
   ## multivariate y
 

tests/testthat/test_mars.R

@@ -151,16 +151,14 @@ test_that('mars execution', {
   expect_true(has_multi_predict(res))
   expect_equal(multi_predict_args(res), "num_terms")
 
-  expect_message(
-    expect_error(
-      res <- fit(
-        hpc_basic,
-        hpc_bad_form,
-        data = hpc,
-        control = ctrl
-      )
+  expect_error(
+    res <- fit(
+      hpc_basic,
+      hpc_bad_form,
+      data = hpc,
+      control = ctrl
     ),
-    "Timing stopped"
+    regexp = "For a regression model"
   )
 
   ## multivariate y
@@ -203,7 +201,7 @@ test_that('mars prediction', {
            input_fields =
              c(430.476046435458, 158.833790342308, 218.07635084308,
                158.833790342308, 158.833790342308)
-           ),
+      ),
       class = "data.frame", row.names = c(NA, -5L)
     )
 

tests/testthat/test_rand_forest_ranger.R

@@ -37,6 +37,16 @@ test_that('ranger classification execution', {
   )
   expect_output(print(res), "parsnip model object")
 
+  expect_error(
+    res <- fit(
+      lc_ranger,
+      funded_amnt ~ Class + term,
+      data = lending_club,
+      control = ctrl
+    ),
+    regexp = "For a classification model"
+  )
+
   expect_error(
     res <- fit_xy(
       lc_ranger,