Merge branch 'master' into 0-1-6-RC

Author: topepo

NEWS.md

@@ -11,11 +11,16 @@
 
 * The `liquidSVM` engine for `svm_rbf()` was deprecated due to that package's removal from CRAN. (#425)
 
+* The xgboost engine for boosted trees was translating `mtry` to xgboost's `colsample_bytree`. We now map `mtry` to `colsample_bynode` since that is more consistent with how random forest works. `colsample_bytree` can still be optimized by passing it in as an engine argument. `colsample_bynode` was added to xgboost after the `parsnip` package code was written. (#495)
+
+* For xgboost, `mtry` and `colsample_bytree` can be passed as integer counts or proportions, while `subsample` and `validation` should always be proportions. `xgb_train()` now has a new option `counts` (`TRUE` or `FALSE`) that states which scale for `mtry` and `colsample_bytree` is being used. (#461)  
+
+r
 ## Other Changes
 
 * Re-licensed package from GPL-2 to MIT. See [consent from copyright holders here](https://github.com/tidymodels/parsnip/issues/462).
 
-* `set_mode()` now checks if `mode` is compatible with the model class, similar to `new_model_spec()` (@jtlandis, #467).
+* `set_mode()` now checks if `mode` is compatible with the model class, similar to `new_model_spec()` (@jtlandis, #467). Both `set_mode()` and `set_engine()` now error for `NULL` or missing arguments (#503).
 
 * Re-organized model documentation for `update` methods (#479).
 
@@ -27,6 +32,7 @@
 
 * xgboost engines now respect the `event_level` option for predictions (#460).  
 
+
 # parsnip 0.1.5
 
 * An RStudio add-in is available that makes writing multiple `parsnip` model specifications to the source window. It can be accessed via the IDE addin menus or by calling `parsnip_addin()`.

R/aaa_models.R

@@ -133,21 +133,23 @@ check_mode_val <- function(mode) {
   invisible(NULL)
 }
 
+
+stop_incompatible_mode <- function(spec_modes) {
+  msg <- glue::glue(
+    "Available modes are: ",
+    glue::glue_collapse(glue::glue("'{spec_modes}'"), sep = ", ")
+  )
+  rlang::abort(msg)
+}
+
 # check if class and mode are compatible
 check_spec_mode_val <- function(cls, mode) {
   spec_modes <- rlang::env_get(get_model_env(), paste0(cls, "_modes"))
-  compatible_modes <-
-    glue::glue(
-      "`mode` should be one of: ",
-      glue::glue_collapse(glue::glue("'{spec_modes}'"), sep = ", ")
-    )
-
-  if (is.null(mode)) {
-    rlang::abort(compatible_modes)
+  if (is.null(mode) || length(mode) > 1) {
+    stop_incompatible_mode(spec_modes)
   } else if (!(mode %in% spec_modes)) {
-    rlang::abort(compatible_modes)
+    stop_incompatible_mode(spec_modes)
   }
-
   invisible(NULL)
 }
 

R/arguments.R

@@ -76,11 +76,12 @@ set_args <- function(object, ...) {
 #' @rdname set_args
 #' @export
 set_mode <- function(object, mode) {
+  cls <- class(object)[1]
   if (rlang::is_missing(mode)) {
-    mode <- NULL
+    spec_modes <- rlang::env_get(get_model_env(), paste0(cls, "_modes"))
+    stop_incompatible_mode(spec_modes)
   }
-  mode <- mode[1]
-  check_spec_mode_val(class(object)[1], mode)
+  check_spec_mode_val(cls, mode)
   object$mode <- mode
   object
 }

R/boost_tree.R

@@ -264,20 +264,26 @@ check_args.boost_tree <- function(object) {
 #' @param max_depth An integer for the maximum depth of the tree.
 #' @param nrounds An integer for the number of boosting iterations.
 #' @param eta A numeric value between zero and one to control the learning rate.
-#' @param colsample_bytree Subsampling proportion of columns.
+#' @param colsample_bytree Subsampling proportion of columns for each tree.
+#' See the `counts` argument below. The default uses all columns.
+#' @param colsample_bynode Subsampling proportion of columns for each node
+#' within each tree. See the `counts` argument below. The default uses all
+#' columns.
 #' @param min_child_weight A numeric value for the minimum sum of instance
 #'  weights needed in a child to continue to split.
 #' @param gamma A number for the minimum loss reduction required to make a
 #'  further partition on a leaf node of the tree
-#' @param subsample Subsampling proportion of rows.
-#' @param validation A positive number. If on `[0, 1)` the value, `validation`
-#' is a random proportion of data in `x` and `y` that are used for performance
-#' assessment and potential early stopping. If 1 or greater, it is the _number_
-#' of training set samples use for these purposes.
+#' @param subsample Subsampling proportion of rows. By default, all of the
+#' training data are used.
+#' @param validation The _proportion_ of the data that are used for performance
+#' assessment and potential early stopping.
 #' @param early_stop An integer or `NULL`. If not `NULL`, it is the number of
 #' training iterations without improvement before stopping. If `validation` is
 #' used, performance is base on the validation set; otherwise, the training set
 #' is used.
+#' @param counts A logical. If `FALSE`, `colsample_bynode` and
+#' `colsample_bytree` are both assumed to be _proportions_ of the proportion of
+#' columns affects (instead of counts).
 #' @param objective A single string (or NULL) that defines the loss function that
 #' `xgboost` uses to create trees. See [xgboost::xgb.train()] for options. If left
 #' NULL, an appropriate loss function is chosen.
@@ -290,11 +296,10 @@ check_args.boost_tree <- function(object) {
 #' @export
 xgb_train <- function(
   x, y,
-  max_depth = 6, nrounds = 15, eta  = 0.3, colsample_bytree = 1,
-  min_child_weight = 1, gamma = 0, subsample = 1, validation = 0,
-  early_stop = NULL, objective = NULL,
-  event_level = c("first", "second"),
-  ...) {
+  max_depth = 6, nrounds = 15, eta  = 0.3, colsample_bynode = NULL,
+  colsample_bytree = NULL, min_child_weight = 1, gamma = 0, subsample = 1,
+  validation = 0, early_stop = NULL, objective = NULL, counts = TRUE,
+  event_level = c("first", "second"), ...) {
 
   event_level <- rlang::arg_match(event_level, c("first", "second"))
   others <- list(...)
@@ -304,6 +309,7 @@ xgb_train <- function(
   if (!is.numeric(validation) || validation < 0 || validation >= 1) {
     rlang::abort("`validation` should be on [0, 1).")
   }
+
   if (!is.null(early_stop)) {
     if (early_stop <= 1) {
       rlang::abort(paste0("`early_stop` should be on [2, ",  nrounds, ")."))
@@ -313,7 +319,6 @@ xgb_train <- function(
     }
   }
 
-
   if (is.null(objective)) {
     if (is.numeric(y)) {
       objective <- "reg:squarederror"
@@ -331,19 +336,21 @@ xgb_train <- function(
 
   x <- as_xgb_data(x, y, validation, event_level)
 
-  # translate `subsample` and `colsample_bytree` to be on (0, 1] if not
-  if (subsample > 1) {
-    subsample <- subsample/n
-  }
-  if (subsample > 1) {
-    subsample <- 1
-  }
 
-  if (colsample_bytree > 1) {
-    colsample_bytree <- colsample_bytree/p
+  if (!is.numeric(subsample) || subsample < 0 || subsample > 1) {
+    rlang::abort("`subsample` should be on [0, 1].")
   }
-  if (colsample_bytree > 1) {
+
+  # initialize
+  if (is.null(colsample_bytree)) {
     colsample_bytree <- 1
+  } else {
+    colsample_bytree <- recalc_param(colsample_bytree, counts, p)
+  }
+  if (is.null(colsample_bynode)) {
+    colsample_bynode <- 1
+  } else {
+    colsample_bynode <- recalc_param(colsample_bynode, counts, p)
   }
 
   if (min_child_weight > n) {
@@ -358,6 +365,7 @@ xgb_train <- function(
     max_depth = max_depth,
     gamma = gamma,
     colsample_bytree = colsample_bytree,
+    colsample_bynode = colsample_bynode,
     min_child_weight = min(min_child_weight, n),
     subsample = subsample,
     objective = objective
@@ -390,6 +398,30 @@ xgb_train <- function(
   eval_tidy(call, env = current_env())
 }
 
+recalc_param <- function(x, counts, denom) {
+  nm <- as.character(match.call()$x)
+  if (is.null(x)) {
+    x <- 1
+  } else {
+    if (counts) {
+      maybe_proportion(x, nm)
+      x <- min(denom, x)/denom
+    }
+  }
+  x
+}
+
+maybe_proportion <- function(x, nm) {
+  if (x < 1) {
+    msg <- paste0(
+      "The option `counts = TRUE` was used but parameter `", nm,
+      "` was given as ", signif(x, 3), ". Please use a value >= 1 or use ",
+      "`counts = FALSE`."
+    )
+    rlang::abort(msg)
+  }
+}
+
 #' @importFrom stats binomial
 xgb_pred <- function(object, newdata, ...) {
   if (!inherits(newdata, "xgb.DMatrix")) {
@@ -432,7 +464,8 @@ as_xgb_data <- function(x, y, validation = 0, event_level = "first", ...) {
 
   if (!inherits(x, "xgb.DMatrix")) {
     if (validation > 0) {
-      trn_index <- sample(1:n, size = floor(n * (1 - validation)) + 1)
+      m <- floor(n * (1 - validation)) + 1
+      trn_index <- sample(1:n, size = max(m, 2))
       wlist <-
         list(validation = xgboost::xgb.DMatrix(x[-trn_index, ], label = y[-trn_index], missing = NA))
       dat <- xgboost::xgb.DMatrix(x[trn_index, ], label = y[trn_index], missing = NA)

R/boost_tree_data.R

@@ -37,7 +37,7 @@ set_model_arg(
   model = "boost_tree",
   eng = "xgboost",
   parsnip = "mtry",
-  original = "colsample_bytree",
+  original = "colsample_bynode",
   func = list(pkg = "dials", fun = "mtry"),
   has_submodel = FALSE
 )

R/engines.R

@@ -10,23 +10,21 @@ possible_engines <- function(object, ...) {
   unique(engs$engine)
 }
 
+stop_incompatible_engine <- function(avail_eng) {
+  msg <- glue::glue(
+    "Available engines are: ",
+    glue::glue_collapse(glue::glue("'{avail_eng}'"), sep = ", ")
+  )
+  rlang::abort(msg)
+}
+
 check_engine <- function(object) {
   avail_eng <- possible_engines(object)
-  if (is.null(object$engine)) {
-    object$engine <- avail_eng[1]
-    rlang::warn(glue::glue("`engine` was NULL and updated to be `{object$engine}`"))
-  } else {
-    if (!is.character(object$engine) | length(object$engine) != 1) {
-      rlang::abort("`engine` should be a single character value.")
-    }
-  }
-  if (!(object$engine %in% avail_eng)) {
-    rlang::abort(
-      glue::glue(
-        "Engine '{object$engine}' is not available. Please use one of: ",
-        glue::glue_collapse(glue::glue("'{avail_eng}'"), sep = ", ")
-      )
-    )
+  eng <- object$engine
+  if (is.null(eng) || length(eng) > 1) {
+    stop_incompatible_engine(avail_eng)
+  } else if (!(eng %in% avail_eng)) {
+    stop_incompatible_engine(avail_eng)
   }
   object
 }
@@ -97,7 +95,8 @@ set_engine <- function(object, engine, ...) {
   }
 
   if (rlang::is_missing(engine)) {
-    engine <- NULL
+    avail_eng <- possible_engines(object)
+    stop_incompatible_engine(avail_eng)
   }
   object$engine <- engine
   object <- check_engine(object)

man/boost_tree.Rd

@@ -38,8 +38,7 @@ mod_param <-
   update(sample_size = sample_prop(c(0.4, 0.9)))
 ```
 
-For this engine, tuning over `trees` is very efficient since the same model 
-object can be used to make predictions over multiple values of `trees`.  
+For this engine, tuning over `trees` is very efficient since the same model  object can be used to make predictions over multiple values of `trees`.  
 
 Note that `xgboost` models require that non-numeric predictors (e.g., factors) must be converted to dummy variables or some other numeric representation. By default, when using `fit()` with `xgboost`, a one-hot encoding is used to convert factor predictors to indicator variables. 
 
@@ -89,7 +88,7 @@ get_defaults_boost_tree <- function() {
     "boost_tree", "xgboost",      "tree_depth",                "max_depth", get_arg("parsnip", "xgb_train", "max_depth"),
     "boost_tree", "xgboost",           "trees",                 "nrounds",  get_arg("parsnip", "xgb_train", "nrounds"),
     "boost_tree", "xgboost",      "learn_rate",                     "eta",  get_arg("parsnip", "xgb_train", "eta"),
-    "boost_tree", "xgboost",            "mtry",        "colsample_bytree",  get_arg("parsnip", "xgb_train", "colsample_bytree"),
+    "boost_tree", "xgboost",            "mtry",        "colsample_bynode",  get_arg("parsnip", "xgb_train", "colsample_bynode"),
     "boost_tree", "xgboost",           "min_n",        "min_child_weight",  get_arg("parsnip", "xgb_train", "min_child_weight"),
     "boost_tree", "xgboost",  "loss_reduction",                   "gamma",  get_arg("parsnip", "xgb_train", "gamma"),
     "boost_tree", "xgboost",     "sample_size",               "subsample",  get_arg("parsnip", "xgb_train", "subsample"),

man/rmd/boost-tree.Rmd

@@ -49,6 +49,6 @@ test_that('pipe engine', {
 test_that("can't set a mode that isn't allowed by the model spec", {
   expect_error(
     set_mode(linear_reg(), "classification"),
-    "`mode` should be one of"
+    "Available modes are:"
   )
 })