Merge pull request #377 from tidymodels/check-arg-dimensions

Make arguments robust to values outside of data dimensions

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,6 +4,10 @@
 
 * 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). (#184)
+
+* Infrastructure was improved for running `parsnip` models in parallel using PSOCK clusters on Windows. 
+
 # parsnip 0.1.3
 
  * A `glance()` method for `model_fit` objects was added (#325)

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

@@ -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,23 @@ 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_rows", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(x))
+  }
+
+  ## -----------------------------------------------------------------------------
+
+  x$method$fit$args <- arg_vals
+
   x
 }
 
@@ -242,14 +260,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)
 }
@@ -335,12 +357,19 @@ 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,
     gamma = gamma,
     colsample_bytree = colsample_bytree,
-    min_child_weight = min_child_weight,
+    min_child_weight = min(min_child_weight, n),
     subsample = subsample
   )
 
@@ -515,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")
+    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

@@ -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_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_rows", rlang::eval_tidy(arg_vals$min_instances_per_node), expr(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_rows", rlang::eval_tidy(arg_vals$ks), expr(data), 5)
     }
   }
+
+  x$method$fit$args <- arg_vals
+
   x
 }
 

R/rand_forest.R

@@ -161,6 +161,8 @@ translate.rand_forest <- function(x, engine = x$engine, ...) {
 
   x <- translate.default(x, engine, ...)
 
+  ## -----------------------------------------------------------------------------
+
   # slightly cleaner code using
   arg_vals <- x$method$fit$args
 
@@ -185,14 +187,47 @@ translate.rand_forest <- function(x, engine = x$engine, ...) {
 
   # add checks to error trap or change things for this method
   if (engine == "ranger") {
-    if (any(names(arg_vals) == "importance"))
-      if (isTRUE(is.logical(quo_get_expr(arg_vals$importance))))
+
+    if (any(names(arg_vals) == "importance")) {
+      if (isTRUE(is.logical(quo_get_expr(arg_vals$importance)))) {
         rlang::abort("`importance` should be a character value. See ?ranger::ranger.")
+      }
+    }
     # unless otherwise specified, classification models are probability forests
-    if (x$mode == "classification" && !any(names(arg_vals) == "probability"))
+    if (x$mode == "classification" && !any(names(arg_vals) == "probability")) {
       arg_vals$probability <- TRUE
+    }
+  }
+
+  ## -----------------------------------------------------------------------------
+  # Protect some arguments based on data dimensions
+
+  if (any(names(arg_vals) == "mtry") & engine != "cforest") {
+    arg_vals$mtry <- rlang::call2("min_cols", arg_vals$mtry, expr(x))
+  }
+  if (any(names(arg_vals) == "mtry") & engine == "cforest") {
+    arg_vals$mtry <- rlang::call2("min_cols", arg_vals$mtry, expr(data))
+  }
 
+  if (any(names(arg_vals) == "min.node.size")) {
+    arg_vals$min.node.size <-
+      rlang::call2("min_rows", arg_vals$min.node.size, expr(x))
+  }
+  if (any(names(arg_vals) == "minsplit" & engine == "cforest")) {
+    arg_vals$minsplit <-
+      rlang::call2("min_rows", arg_vals$minsplit, expr(data))
+  }
+  if (any(names(arg_vals) == "nodesize")) {
+    arg_vals$nodesize <-
+      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_rows", arg_vals$min_instances_per_node, expr(x))
+  }
+
+  ## -----------------------------------------------------------------------------
+
   x$method$fit$args <- arg_vals
 
   x

man/min_cols.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_rows(1000, x)))
+})
+