more data dimension protections

Author: topepo

R/boost_tree.R

@@ -244,11 +244,13 @@ translate.boost_tree <- function(x, engine = x$engine, ...) {
   # min_n parameters
   if (any(names(arg_vals) == "min_instances_per_node")) {
     arg_vals$min_instances_per_node <-
-      rlang::call2("min", arg_vals$min_instances_per_node, expr(nrow(x)))
+      rlang::call2("min", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(nrow(x)))
   }
 
   ## -----------------------------------------------------------------------------
 
+  x$method$fit$args <- arg_vals
+
   x
 }
 

R/decision_tree.R

@@ -180,6 +180,22 @@ translate.decision_tree <- function(x, engine = x$engine, ...) {
     }
   }
 
+  ## -----------------------------------------------------------------------------
+  # Protect some arguments based on data dimensions
+
+  if (any(names(arg_vals) == "minsplit")) {
+    arg_vals$minsplit <-
+      rlang::call2("min", rlang::eval_tidy(arg_vals$minsplit), expr(nrow(data)))
+  }
+  if (any(names(arg_vals) == "min_instances_per_node")) {
+    arg_vals$min_instances_per_node <-
+      rlang::call2("min", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(nrow(x)))
+  }
+
+  ## -----------------------------------------------------------------------------
+
+  x$method$fit$args <- arg_vals
+
   x
 }
 

R/nearest_neighbor.R

@@ -168,12 +168,25 @@ translate.nearest_neighbor <- function(x, engine = x$engine, ...) {
   }
   x <- translate.default(x, engine, ...)
 
+  arg_vals <- x$method$fit$args
+
   if (engine == "kknn") {
-    if (!any(names(x$method$fit$args) == "ks") ||
-        is_missing_arg(x$method$fit$args$ks)) {
-      x$method$fit$args$ks <- 5
+
+    if (!any(names(arg_vals) == "ks") || is_missing_arg(arg_vals$ks)) {
+      arg_vals$ks <- 5
+    }
+
+    ## -----------------------------------------------------------------------------
+    # Protect some arguments based on data dimensions
+
+    if (any(names(arg_vals) == "ks")) {
+      arg_vals$ks <-
+        rlang::call2("min", rlang::eval_tidy(arg_vals$ks), expr(nrow(data) - 5))
     }
   }
+
+  x$method$fit$args <- arg_vals
+
   x
 }
 

man/nearest_neighbor.Rd

@@ -151,4 +151,17 @@ test_that('bad input', {
   expect_error(translate(boost_tree(formula = y ~ x)))
 })
 
-# ------------------------------------------------------------------------------
+
+## -----------------------------------------------------------------------------
+
+test_that('argument checks for data dimensions', {
+
+  spec <-
+    boost_tree(mtry = 1000, min_n = 1000, trees = 5) %>%
+    set_engine("spark") %>%
+    set_mode("classification")
+
+  args <- translate(spec)$method$fit$args
+  expect_equal(args$min_instances_per_node, expr(min(1000, nrow(x))))
+})
+

tests/testthat/test_boost_tree.R

@@ -59,7 +59,7 @@ test_that('primary arguments', {
                  formula = expr(missing_arg()),
                  data = expr(missing_arg()),
                  weights = expr(missing_arg()),
-                 minsplit = new_empty_quosure(15)
+                 minsplit = expr(min(15, nrow(data)))
                )
   )
 
@@ -148,3 +148,33 @@ test_that('default engine', {
   )
   expect_true(inherits(fit$fit, "rpart"))
 })
+
+
+
+## -----------------------------------------------------------------------------
+
+test_that('argument checks for data dimensions', {
+
+  data(penguins, package = "modeldata")
+  penguins <- na.omit(penguins)
+
+  spec <-
+    decision_tree(min_n = 1000) %>%
+    set_engine("rpart") %>%
+    set_mode("regression")
+
+  f_fit  <- spec %>% fit(body_mass_g ~ ., data = penguins)
+  xy_fit <- spec %>% fit_xy(x = penguins[, -6], y = penguins$body_mass_g)
+
+  expect_equal(f_fit$fit$control$minsplit,  nrow(penguins))
+  expect_equal(xy_fit$fit$control$minsplit, nrow(penguins))
+
+  spec <-
+    decision_tree(min_n = 1000) %>%
+    set_engine("spark") %>%
+    set_mode("regression")
+
+  args <- translate(spec)$method$fit$args
+  expect_equal(args$min_instances_per_node,  rlang::expr(min(1000, nrow(x))))
+
+})

tests/testthat/test_decision_tree.R

@@ -18,7 +18,7 @@ test_that('primary arguments', {
     expected = list(
       formula = expr(missing_arg()),
       data = expr(missing_arg()),
-      ks = 5
+      ks = expr(min(5, nrow(data) - 5))
     )
   )
 
@@ -30,7 +30,7 @@ test_that('primary arguments', {
     expected = list(
       formula = expr(missing_arg()),
       data = expr(missing_arg()),
-      ks = new_empty_quosure(2)
+      ks = expr(min(2, nrow(data) - 5))
     )
   )
 
@@ -43,7 +43,7 @@ test_that('primary arguments', {
       formula = expr(missing_arg()),
       data = expr(missing_arg()),
       kernel = new_empty_quosure("triangular"),
-      ks = 5
+      ks = expr(min(5, nrow(data) - 5))
     )
   )
 
@@ -56,7 +56,7 @@ test_that('primary arguments', {
       formula = expr(missing_arg()),
       data = expr(missing_arg()),
       distance = new_empty_quosure(2),
-      ks = 5
+      ks = expr(min(5, nrow(data) - 5))
     )
   )
 
@@ -72,7 +72,7 @@ test_that('engine arguments', {
       formula = expr(missing_arg()),
       data = expr(missing_arg()),
       scale = new_empty_quosure(FALSE),
-      ks = 5
+      ks = expr(min(5, nrow(data) - 5))
     )
   )
 

tests/testthat/test_nearest_neighbor.R

@@ -193,3 +193,25 @@ test_that('kknn multi-predict', {
     dplyr::select(.pred)
   expect_equal(pred_uni, pred_uni_obs)
 })
+
+
+## -----------------------------------------------------------------------------
+
+test_that('argument checks for data dimensions', {
+
+  data(penguins, package = "modeldata")
+  penguins <- na.omit(penguins)
+
+  spec <-
+    nearest_neighbor(neighbors = 1000) %>%
+    set_engine("kknn") %>%
+    set_mode("regression")
+
+  f_fit  <- spec %>% fit(body_mass_g ~ ., data = penguins)
+  xy_fit <- spec %>% fit_xy(x = penguins[, -6], y = penguins$body_mass_g)
+
+  expect_equal(f_fit$fit$best.parameters$k,  nrow(penguins) - 5)
+  expect_equal(xy_fit$fit$best.parameters$k, nrow(penguins) - 5)
+
+})
+