handle attributes on outcome columns (#1062)

Author: simonpcouch

NEWS.md

@@ -1,5 +1,7 @@
 # parsnip (development version)
 
+* Tightened logic for outcome checking. This resolves issues—some errors and some silent failures—when atomic outcome variables have an attribute (#1060, #1061).
+
 * `rpart_train()` has been deprecated in favor of using `decision_tree()` with the `"rpart"` engine or `rpart::rpart()` directly (#1044).
 
 * Fixed bug in fitting some model types with the `"spark"` engine (#1045).

R/convert_data.R

@@ -234,7 +234,7 @@
   if (is.matrix(y)) {
     y <- as.data.frame(y)
   } else {
-    if (is.vector(y) | is.factor(y)) {
+    if (is.atomic(y)) {
       y <- data.frame(y)
       names(y) <- y_name
     }
@@ -328,7 +328,7 @@ make_formula <- function(x, y, short = TRUE) {
 
 
 will_make_matrix <- function(y) {
-  if (is.matrix(y) | is.vector(y) | is.factor(y))
+  if (is.matrix(y) | is.atomic(y))
     return(FALSE)
   cls <- unique(unlist(lapply(y, class)))
   if (length(cls) > 1)

R/fit.R

@@ -267,7 +267,7 @@ fit_xy.model_spec <-
     }
     y_var <- colnames(y)
 
-    if (object$engine != "spark" & NCOL(y) == 1 & !(is.vector(y) | is.factor(y))) {
+    if (object$engine != "spark" & NCOL(y) == 1 & !(is.atomic(y))) {
       if (is.matrix(y)) {
         y <- y[, 1]
       } else {
@@ -411,10 +411,8 @@ check_xy_interface <- function(x, y, cl, model) {
     inher(x, c("data.frame", "matrix"), cl)
   }
 
-  # `y` can be a vector (which is not a class), or a factor or
-  # Surv object (which are not vectors)
-  if (!is.null(y) && !is.vector(y))
-    inher(y, c("data.frame", "matrix", "factor", "Surv"), cl)
+  if (!is.null(y) && !is.atomic(y))
+    inher(y, c("data.frame", "matrix"), cl)
 
   # rule out spark data sets that don't use the formula interface
   if (inherits(x, "tbl_spark") | inherits(y, "tbl_spark"))

R/fit_helpers.R

@@ -121,7 +121,7 @@ xy_xy <- function(object, env, control, target = "none", ...) {
     elapsed <- list(elapsed = NA_real_)
   }
 
-  if (is.vector(env$y)) {
+  if (is.atomic(env$y)) {
     y_name <- character(0)
   } else {
     y_name <- colnames(env$y)
@@ -199,7 +199,7 @@ xy_form <- function(object, env, control, ...) {
   if (!is.null(env$y_var)) {
     data_obj$y_var <- env$y_var
   } else {
-    if (is.vector(env$y)) {
+    if (is.atomic(env$y)) {
       data_obj$y_var <- character(0)
     }
 

tests/testthat/test_fit_interfaces.R

@@ -121,3 +121,36 @@ test_that('No loaded engines', {
   expect_snapshot_error({poisson_reg() %>% fit(mpg ~., data = mtcars)})
   expect_snapshot_error({cubist_rules(engine = "Cubist") %>% fit(mpg ~., data = mtcars)})
 })
+
+test_that("fit_xy() can handle attributes on a data.frame outcome (#1060)", {
+  lr <- linear_reg()
+  x <- data.frame(x = 1:5)
+  y <- c(2:5, 5)
+
+  expect_silent(res <-
+                  fit_xy(lr, x = x, y =  data.frame(y = structure(y, label = "hi")))
+  )
+  expect_equal(res[["fit"]], fit_xy(lr, x, y)[["fit"]], ignore_attr = "label")
+})
+
+test_that("fit_xy() can handle attributes on an atomic outcome (#1061)", {
+  lr <- linear_reg()
+  x <- data.frame(x = 1:5)
+  y <- c(2:5, 5)
+
+  expect_silent(res <- fit_xy(lr, x = x, y = structure(y, label = "hi")))
+  expect_equal(res[["fit"]], fit_xy(lr, x, y)[["fit"]], ignore_attr = "label")
+})
+
+test_that("fit() can handle attributes on a vector outcome", {
+  lr <- linear_reg()
+  dat <- data.frame(x = 1:5, y = c(2:5, 5))
+  dat_attr <- data.frame(x = 1:5, y = structure(c(2:5, 5), label = "hi"))
+
+  expect_silent(res <- fit(lr, y ~ x, dat_attr))
+  expect_equal(
+    res[["fit"]],
+    fit(lr, y ~ x, dat)[["fit"]],
+    ignore_attr = TRUE
+  )
+})