Ensure that fit_xy() patches the formula environment with weights (#705)

* Prefix everywhere we use `new_quosure()` or `empty_env()`

We don't import these, so we have to do this. Tests were only working by chance because we have `library(rlang)` in some of the test files!

* Ensure that `fit_xy()` patches the formula environment with weights

* missing roxygen tag

* avoid deprecated tests

Co-authored-by: Max Kuhn <[email protected]>

Author: DavisVaughan

R/case_weights.R

@@ -47,6 +47,24 @@ weights_to_numeric <- function(x, spec) {
   x
 }
 
+patch_formula_environment_with_case_weights <- function(formula,
+                                                        data,
+                                                        case_weights) {
+  # `lm()` and `glm()` and others use the original model function call to
+  # construct a call for `model.frame()`. That will normally fail because the
+  # formula has its own environment attached (usually the global environment)
+  # and it will look there for a vector named 'weights'. To account
+  # for this, we create a child of the `formula`'s environment and
+  # stash the `weights` there with the expected name and then
+  # reassign this as the `formula`'s environment
+  environment(formula) <- rlang::new_environment(
+    data = list(data = data, weights = case_weights),
+    parent = environment(formula)
+  )
+
+  formula
+}
+
 #' Convert case weights to final from
 #'
 #' tidymodels requires case weights to have special classes. To use them in
@@ -55,6 +73,7 @@ weights_to_numeric <- function(x, spec) {
 #' @param x A vector with class `"hardhat_case_weights"`.
 #' @param where The location where they will be used: `"parsnip"` or
 #' `"yardstick"`.
+#' @param ... Additional options (not currently used).
 #' @return A numeric vector or NULL.
 #' @export
 convert_case_weights <- function(x, where = "parsnip", ...) {

R/convert_data.R

@@ -252,6 +252,12 @@
     if (length(weights) != nrow(x)) {
       rlang::abort(glue::glue("`weights` should have {nrow(x)} elements"))
     }
+
+    form <- patch_formula_environment_with_case_weights(
+      formula = form,
+      data = x,
+      case_weights = weights
+    )
   }
 
   res <- list(

R/fit.R

@@ -146,16 +146,10 @@ fit.model_spec <-
 
     wts <- weights_to_numeric(case_weights, object)
 
-    # `lm()` and `glm()` and others use the original model function call to
-    # construct a call for `model.frame()`. That will normally fail because the
-    # formula has its own environment attached (usually the global environment)
-    # and it will look there for a vector named 'weights'. To account
-    # for this, we create a child of the `formula`'s environment and
-    # stash the `weights` there with the expected name and then
-    # reassign this as the `formula`'s environment
-    environment(formula) <- rlang::new_environment(
-      data = list(data = data, weights = wts),
-      parent = environment(formula)
+    formula <- patch_formula_environment_with_case_weights(
+      formula = formula,
+      data = data,
+      case_weights = wts
     )
 
     eval_env$data <- data

R/fit_helpers.R

@@ -177,7 +177,7 @@ xy_form <- function(object, env, control, ...) {
     .convert_xy_to_form_fit(
       x = env$x,
       y = env$y,
-      weights = NULL,
+      weights = env$weights,
       y_name = "..y",
       remove_intercept = remove_intercept
     )

man/convert_case_weights.Rd

@@ -24,6 +24,25 @@ test_that('case weights with xy method', {
     print(C5_bst_wt_fit$fit$call),
     "weights = weights"
   )
+
+  expect_error({
+    set.seed(1)
+    C5_bst_wt_fit <-
+      boost_tree(trees = 5) %>%
+      set_engine("C5.0") %>%
+      set_mode("classification") %>%
+      fit_xy(
+        x = two_class_dat[c("A", "B")],
+        y = two_class_dat$Class,
+        case_weights = wts
+      )
+  },
+  regexp = NA)
+
+  expect_output(
+    print(C5_bst_wt_fit$fit$call),
+    "weights = weights"
+  )
 })
 
 
@@ -51,6 +70,19 @@ test_that('case weights with xy method - non-standard argument names', {
   #   print(rf_wt_fit$fit$call),
   #   "case\\.weights = weights"
   # )
+
+  expect_error({
+    set.seed(1)
+    rf_wt_fit <-
+      rand_forest(trees = 5) %>%
+      set_mode("classification") %>%
+      fit_xy(
+        x = two_class_dat[c("A", "B")],
+        y = two_class_dat$Class,
+        case_weights = wts
+      )
+  },
+  regexp = NA)
 })
 
 test_that('case weights with formula method', {
@@ -78,5 +110,34 @@ test_that('case weights with formula method', {
   expect_equal(coef(lm_wt_fit$fit), coef(lm_sub_fit$fit))
 })
 
+test_that('case weights with formula method that goes through `fit_xy()`', {
+
+  skip_if_not_installed("modeldata")
+  data("ames", package = "modeldata")
+  ames$Sale_Price <- log10(ames$Sale_Price)
+
+  set.seed(1)
+  wts <- runif(nrow(ames))
+  wts <- ifelse(wts < 1/5, 0L, 1L)
+  ames_subset <- ames[wts != 0, ]
+  wts <- frequency_weights(wts)
+
+  expect_error(
+    lm_wt_fit <-
+      linear_reg() %>%
+      fit_xy(
+        x = ames[c("Longitude", "Latitude")],
+        y = ames$Sale_Price,
+        case_weights = wts
+      ),
+    regexp = NA)
 
+  lm_sub_fit <-
+    linear_reg() %>%
+    fit_xy(
+      x = ames_subset[c("Longitude", "Latitude")],
+      y = ames_subset$Sale_Price
+    )
 
+  expect_equal(coef(lm_wt_fit$fit), coef(lm_sub_fit$fit))
+})

tests/testthat/test-case-weights.R

@@ -1,3 +1,4 @@
+
 test_that('updating', {
   expr1 <- mlp(mode = "regression") %>% set_engine("nnet", Hess = FALSE, abstol = tune())
   expr2 <- mlp(mode = "regression") %>% set_engine("nnet", Hess = tune())