boost_tree() data dimension checks

Author: topepo

R/boost_tree.R

@@ -221,6 +221,10 @@ translate.boost_tree <- function(x, engine = x$engine, ...) {
   }
   x <- translate.default(x, engine, ...)
 
+  ## -----------------------------------------------------------------------------
+
+  arg_vals <- x$method$fit$args
+
   if (engine == "spark") {
     if (x$mode == "unknown") {
       rlang::abort(
@@ -230,9 +234,21 @@ translate.boost_tree <- function(x, engine = x$engine, ...) {
         )
       )
     } else {
-      x$method$fit$args$type <- x$mode
+      arg_vals$type <- x$mode
     }
   }
+
+  ## -----------------------------------------------------------------------------
+  # Protect some arguments based on data dimensions
+
+  # 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)))
+  }
+
+  ## -----------------------------------------------------------------------------
+
   x
 }
 
@@ -242,14 +258,18 @@ check_args.boost_tree <- function(object) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$trees) && args$trees < 0)
+  if (is.numeric(args$trees) && args$trees < 0) {
     rlang::abort("`trees` should be >= 1.")
-  if (is.numeric(args$sample_size) && (args$sample_size < 0 | args$sample_size > 1))
+  }
+  if (is.numeric(args$sample_size) && (args$sample_size < 0 | args$sample_size > 1)) {
     rlang::abort("`sample_size` should be within [0,1].")
-  if (is.numeric(args$tree_depth) && args$tree_depth < 0)
+  }
+  if (is.numeric(args$tree_depth) && args$tree_depth < 0) {
     rlang::abort("`tree_depth` should be >= 1.")
-  if (is.numeric(args$min_n) && args$min_n < 0)
+  }
+  if (is.numeric(args$min_n) && args$min_n < 0) {
     rlang::abort("`min_n` should be >= 1.")
+  }
 
   invisible(object)
 }
@@ -340,7 +360,7 @@ xgb_train <- function(
     max_depth = max_depth,
     gamma = gamma,
     colsample_bytree = colsample_bytree,
-    min_child_weight = min_child_weight,
+    min_child_weight = min(min_child_weight, n),
     subsample = subsample
   )
 
@@ -516,7 +536,7 @@ C5.0_train <-
     fit_args <- other_args[names(other_args) %in% f_names]
 
     ctrl <- call2("C5.0Control", .ns = "C50")
-    ctrl$minCases <- minCases
+    ctrl$minCases <- min(minCases, nrow(x))
     ctrl$sample <- sample
     ctrl <- rlang::call_modify(ctrl, !!!ctrl_args)
 

tests/testthat/test_boost_tree_C50.R

@@ -138,3 +138,25 @@ test_that('submodel prediction', {
   )
 })
 
+
+## -----------------------------------------------------------------------------
+
+test_that('argument checks for data dimensions', {
+
+  skip_if_not_installed("C50")
+
+  data(penguins, package = "modeldata")
+  penguins <- na.omit(penguins)
+
+  spec <-
+    boost_tree(min_n = 1000, trees = 5) %>%
+    set_engine("C5.0") %>%
+    set_mode("classification")
+
+  f_fit  <- spec %>% fit(species ~ ., data = penguins)
+  xy_fit <- spec %>% fit_xy(x = penguins[, -1], y = penguins$species)
+
+  expect_equal(f_fit$fit$control$minCases,  nrow(penguins))
+  expect_equal(xy_fit$fit$control$minCases, nrow(penguins))
+
+})

tests/testthat/test_boost_tree_xgboost.R

@@ -352,4 +352,31 @@ test_that('xgboost data and sparse matrices', {
 })
 
 
+## -----------------------------------------------------------------------------
+
+test_that('argument checks for data dimensions', {
+
+  skip_if_not_installed("C50")
+
+  data(penguins, package = "modeldata")
+  penguins <- na.omit(penguins)
+
+  spec <-
+    boost_tree(mtry = 1000, min_n = 1000, trees = 5) %>%
+    set_engine("xgboost") %>%
+    set_mode("classification")
+
+  penguins_dummy <- model.matrix(species ~ ., data = penguins)
+  penguins_dummy <- as.data.frame(penguins_dummy[, -1])
+
+  f_fit  <- spec %>% fit(species ~ ., data = penguins)
+  xy_fit <- spec %>% fit_xy(x = penguins_dummy, y = penguins$species)
+
+  expect_equal(f_fit$fit$params$colsample_bytree, 1)
+  expect_equal(f_fit$fit$params$min_child_weight, nrow(penguins))
+  expect_equal(xy_fit$fit$params$colsample_bytree, 1)
+  expect_equal(xy_fit$fit$params$min_child_weight, nrow(penguins))
+
+})
+