Add warnings when the argument is corrected

Author: topepo

NAMESPACE

@@ -132,6 +132,8 @@ export(make_classes)
 export(mars)
 export(maybe_data_frame)
 export(maybe_matrix)
+export(min_cols)
+export(min_rows)
 export(mlp)
 export(model_printer)
 export(multi_predict)

NEWS.md

@@ -4,7 +4,9 @@
 
 * For three models (`glmnet`, `xgboost`, and `ranger`), enable sparse matrix use via `fit_xy()` (#373).
 
-* Some added protections were added for function arguments that are dependent on the data dimensions (e.g., `mtry`, `neighbors`, `min_n`, etc). 
+* Some added protections were added for function arguments that are dependent on the data dimensions (e.g., `mtry`, `neighbors`, `min_n`, etc). (#184)
+
+* Infrastructure was improved for running `parsnip` models in parallel using PSOCK clusters on Windows. 
 
 # parsnip 0.1.3
 

R/arguments.R

@@ -204,3 +204,66 @@ make_xy_call <- function(object, target) {
 
   fit_call
 }
+
+## -----------------------------------------------------------------------------
+#' Execution-time data dimension checks
+#'
+#' For some tuning parameters, the range of values depend on the data
+#' dimensions (e.g. `mtry`). Some packages will fail if the parameter values are
+#' outside of these ranges. Since the model might receive resampled versions of
+#' the data, these ranges can't be set prior to the point where the model is
+#' fit.  These functions check the possible range of the data and adjust them
+#' if needed (with a warning).
+#'
+#' @param num_cols,num_rows The parameter value requested by the user.
+#' @param source A data frame for the data to be used in the fit. If the source
+#' is named "data", it is assumed that one column of the data corresponds to
+#' an outcome (and is subtracted off).
+#' @param offset A number subtracted off of the number of rows available in the
+#' data.
+#' @return An integer (and perhaps a warning).
+#' @examples
+
+#' nearest_neighbor(neighbors= 100) %>%
+#'   set_engine("kknn") %>%
+#'   set_mode("regression") %>%
+#'   translate()
+#'
+#' library(ranger)
+#' rand_forest(mtry = 2, min_n = 100, trees = 3) %>%
+#'   set_engine("ranger") %>%
+#'   set_mode("regression") %>%
+#'   fit(mpg ~ ., data = mtcars)
+#' @export
+min_cols <- function(num_cols, source) {
+  cl <- match.call()
+  src_name <- rlang::expr_text(cl$source)
+  if (cl$source == "data") {
+    p <- ncol(source) - 1
+  } else {
+    p <- ncol(source)
+  }
+  if (num_cols > p) {
+    msg <- paste0(num_cols, " columns were requested but there were ", p,
+                 " predictors in the data. ", p, " will be used.")
+    rlang::warn(msg)
+    num_cols <- p
+  }
+
+  as.integer(num_cols)
+}
+
+#' @export
+#' @rdname min_cols
+min_rows <- function(num_rows, source, offset = 0) {
+  n <- nrow(source)
+
+  if (num_rows > n - offset) {
+    msg <- paste0(num_rows, " samples were requested but there were ", n,
+                  " rows in the data. ", n - offset, " will be used.")
+    rlang::warn(msg)
+    num_rows <- n - offset
+  }
+
+  as.integer(num_rows)
+}

R/boost_tree.R

@@ -244,7 +244,7 @@ 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", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(nrow(x)))
+      rlang::call2("min_rows", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(x))
   }
 
   ## -----------------------------------------------------------------------------
@@ -357,6 +357,13 @@ xgb_train <- function(
     colsample_bytree <- 1
   }
 
+  if (min_child_weight > n) {
+    msg <- paste0(min_child_weight, " samples were requested but there were ",
+                  n, " rows in the data. ", n, " will be used.")
+    rlang::warn(msg)
+    min_child_weight <- min(min_child_weight, n)
+  }
+
   arg_list <- list(
     eta = eta,
     max_depth = max_depth,
@@ -537,8 +544,21 @@ C5.0_train <-
     ctrl_args <- other_args[names(other_args) %in% c_names]
     fit_args <- other_args[names(other_args) %in% f_names]
 
+    n <- nrow(x)
+    if (n == 0) {
+      rlang::abort("There are zero rows in the predictor set.")
+    }
+
+
     ctrl <- call2("C5.0Control", .ns = "C50")
-    ctrl$minCases <- min(minCases, nrow(x))
+    if (minCases > n) {
+      msg <- paste0(minCases, " samples were requested but there were ",
+                    n, " rows in the data. ", n, " will be used.")
+      rlang::warn(msg)
+      minCases <- n
+    }
+    ctrl$minCases <- minCases
+
     ctrl$sample <- sample
     ctrl <- rlang::call_modify(ctrl, !!!ctrl_args)
 

R/decision_tree.R

@@ -185,11 +185,11 @@ translate.decision_tree <- function(x, engine = x$engine, ...) {
 
   if (any(names(arg_vals) == "minsplit")) {
     arg_vals$minsplit <-
-      rlang::call2("min", rlang::eval_tidy(arg_vals$minsplit), expr(nrow(data)))
+      rlang::call2("min_rows", rlang::eval_tidy(arg_vals$minsplit), expr(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)))
+      rlang::call2("min_rows", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(x))
   }
 
   ## -----------------------------------------------------------------------------

R/nearest_neighbor.R

@@ -181,7 +181,7 @@ translate.nearest_neighbor <- function(x, engine = x$engine, ...) {
 
     if (any(names(arg_vals) == "ks")) {
       arg_vals$ks <-
-        rlang::call2("min", rlang::eval_tidy(arg_vals$ks), expr(nrow(data) - 5))
+        rlang::call2("min_rows", rlang::eval_tidy(arg_vals$ks), expr(data), 5)
     }
   }
 

R/rand_forest.R

@@ -203,20 +203,20 @@ translate.rand_forest <- function(x, engine = x$engine, ...) {
   # Protect some arguments based on data dimensions
 
   if (any(names(arg_vals) == "mtry")) {
-    arg_vals$mtry <- rlang::call2("min", arg_vals$mtry, expr(ncol(x)))
+    arg_vals$mtry <- rlang::call2("min_cols", arg_vals$mtry, expr(x))
   }
 
   if (any(names(arg_vals) == "min.node.size")) {
     arg_vals$min.node.size <-
-      rlang::call2("min", arg_vals$min.node.size, expr(nrow(x)))
+      rlang::call2("min_rows", arg_vals$min.node.size, expr(x))
   }
   if (any(names(arg_vals) == "nodesize")) {
     arg_vals$nodesize <-
-      rlang::call2("min", arg_vals$nodesize, expr(nrow(x)))
+      rlang::call2("min_rows", arg_vals$nodesize, expr(x))
   }
   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_rows", arg_vals$min_instances_per_node, expr(x))
   }
 
   ## -----------------------------------------------------------------------------

man/boost_tree.Rd

@@ -162,6 +162,6 @@ test_that('argument checks for data dimensions', {
     set_mode("classification")
 
   args <- translate(spec)$method$fit$args
-  expect_equal(args$min_instances_per_node, expr(min(1000, nrow(x))))
+  expect_equal(args$min_instances_per_node, expr(min_rows(1000, x)))
 })
 

man/min_cols.Rd

@@ -59,7 +59,7 @@ test_that('primary arguments', {
                  formula = expr(missing_arg()),
                  data = expr(missing_arg()),
                  weights = expr(missing_arg()),
-                 minsplit = expr(min(15, nrow(data)))
+                 minsplit = expr(min_rows(15, data))
                )
   )
 
@@ -163,8 +163,14 @@ test_that('argument checks for data dimensions', {
     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_warning(
+    f_fit  <- spec %>% fit(body_mass_g ~ ., data = penguins),
+    "1000 samples were requested but there were 333 rows in the data. 333 will be used."
+  )
+  expect_warning(
+    xy_fit <- spec %>% fit_xy(x = penguins[, -6], y = penguins$body_mass_g),
+    "1000 samples were requested but there were 333 rows in the data. 333 will be used."
+  )
 
   expect_equal(f_fit$fit$control$minsplit,  nrow(penguins))
   expect_equal(xy_fit$fit$control$minsplit, nrow(penguins))
@@ -175,6 +181,6 @@ test_that('argument checks for data dimensions', {
     set_mode("regression")
 
   args <- translate(spec)$method$fit$args
-  expect_equal(args$min_instances_per_node,  rlang::expr(min(1000, nrow(x))))
+  expect_equal(args$min_instances_per_node,  rlang::expr(min_rows(1000, x)))
 
 })

man/nearest_neighbor.Rd

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

tests/testthat/test_boost_tree.R

@@ -207,8 +207,15 @@ test_that('argument checks for data dimensions', {
     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_warning(
+    f_fit  <- spec %>% fit(body_mass_g ~ ., data = penguins),
+    "1000 samples were requested but there were 333 rows in the data. 328 will be used."
+  )
+
+  expect_warning(
+    xy_fit <- spec %>% fit_xy(x = penguins[, -6], y = penguins$body_mass_g),
+    "1000 samples were requested but there were 333 rows in the data. 328 will be used."
+  )
 
   expect_equal(f_fit$fit$best.parameters$k,  nrow(penguins) - 5)
   expect_equal(xy_fit$fit$best.parameters$k, nrow(penguins) - 5)