Merge branch 'main' into feature/case-weights

Author: topepo

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: parsnip
 Title: A Common API to Modeling and Analysis Functions
-Version: 0.2.1.9000
+Version: 0.2.1.9001
 Authors@R: c(
     person("Max", "Kuhn", , "[email protected]", role = c("aut", "cre")),
     person("Davis", "Vaughan", , "[email protected]", role = "aut"),

NAMESPACE

@@ -171,13 +171,15 @@ export(bag_tree)
 export(bart)
 export(bartMachine_interval_calc)
 export(boost_tree)
+export(cforest_train)
 export(check_empty_ellipse)
 export(check_final_param)
 export(check_model_doesnt_exist)
 export(check_model_exists)
 export(contr_one_hot)
 export(control_parsnip)
 export(convert_stan_interval)
+export(ctree_train)
 export(cubist_rules)
 export(dbart_predict_calc)
 export(decision_tree)
@@ -220,6 +222,7 @@ export(make_classes)
 export(make_engine_list)
 export(make_seealso_list)
 export(mars)
+export(max_mtry_formula)
 export(maybe_data_frame)
 export(maybe_matrix)
 export(min_cols)
@@ -297,6 +300,7 @@ export(update_main_parameters)
 export(update_model_info_file)
 export(varying)
 export(varying_args)
+export(xgb_predict)
 export(xgb_train)
 importFrom(dplyr,arrange)
 importFrom(dplyr,bind_cols)

NEWS.md

@@ -1,18 +1,27 @@
 # parsnip (development version)
 
+
 * Enable the use of case weights for models that support them. 
 
 * Added a `glm_grouped()` function to convert long data to the grouped format required by `glm()` for logistic regression. 
 
 * `show_model_info()` now indicates which models can utilize case weights. 
 
+* `xgb_train()` now allows for case weights 
+
+* Added `ctree_train()` and `cforest_train()` wrappers for the functions in the partykit package. Engines for these will be added to other parsnip extension packages.  
+
+* Exported `xgb_predict()` which wraps xgboost's `predict()` method for use with parsnip extension packages (#688).
+
+
 # parsnip 0.2.1
 
 * Fixed a major bug in spark models induced in the previous version (#671).
 
 * Updated the parsnip add-in with new models and engines. 
 
 * Updated parameter ranges for some `tunable()` methods and added a missing engine argument for brulee models. 
+
 * Added information about how to install the mixOmics package for PLS models (#680)
 
 

R/aaa_models.R

@@ -260,12 +260,6 @@ check_mode_with_no_engine <- function(cls, mode) {
   }
 }
 
-check_engine_val <- function(eng) {
-  if (rlang::is_missing(eng) || length(eng) != 1 || !is.character(eng))
-    rlang::abort("Please supply a character string for an engine (e.g. `'lm'`).")
-  invisible(NULL)
-}
-
 check_arg_val <- function(arg) {
   if (rlang::is_missing(arg) || length(arg) != 1 || !is.character(arg))
     rlang::abort("Please supply a character string for the argument.")

R/boost_tree.R

@@ -213,12 +213,13 @@ check_args.boost_tree <- function(object) {
   invisible(object)
 }
 
+
 # xgboost helpers --------------------------------------------------------------
 
 #' Boosted trees via xgboost
 #'
-#' `xgb_train` is a wrapper for `xgboost` tree-based models where all of the
-#'  model arguments are in the main function.
+#' `xgb_train()` and `xgb_predict()` are wrappers for `xgboost` tree-based
+#' models where all of the model arguments are in the main function.
 #'
 #' @param x A data frame or matrix of predictors
 #' @param y A vector (factor or numeric) or matrix (numeric) of outcome data.
@@ -251,16 +252,16 @@ check_args.boost_tree <- function(object) {
 #' @param event_level For binary classification, this is a single string of either
 #' `"first"` or `"second"` to pass along describing which level of the outcome
 #' should be considered the "event".
-#' @param ... Other options to pass to `xgb.train`.
+#' @param ... Other options to pass to `xgb.train()` or xgboost's method for `predict()`.
 #' @return A fitted `xgboost` object.
 #' @keywords internal
 #' @export
 xgb_train <- function(
-  x, y,
-  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"), weights = NULL, ...) {
+    x, y, weights = NULL,
+    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(...)
@@ -387,13 +388,17 @@ maybe_proportion <- function(x, nm) {
   }
 }
 
-xgb_pred <- function(object, newdata, ...) {
-  if (!inherits(newdata, "xgb.DMatrix")) {
-    newdata <- maybe_matrix(newdata)
-    newdata <- xgboost::xgb.DMatrix(data = newdata, missing = NA)
+#' @rdname xgb_train
+#' @param new_data A rectangular data object, such as a data frame.
+#' @keywords internal
+#' @export
+xgb_predict <- function(object, new_data, ...) {
+  if (!inherits(new_data, "xgb.DMatrix")) {
+    new_data <- maybe_matrix(new_data)
+    new_data <- xgboost::xgb.DMatrix(data = new_data, missing = NA)
   }
 
-  res <- predict(object, newdata, ...)
+  res <- predict(object, new_data, ...)
 
   x <- switch(
     object$params$objective,
@@ -470,6 +475,7 @@ get_event_level <- function(model_spec){
   event_level
 }
 
+
 #' @export
 #' @rdname multi_predict
 #' @param trees An integer vector for the number of trees in the ensemble.
@@ -500,9 +506,9 @@ multi_predict._xgb.Booster <-
   }
 
 xgb_by_tree <- function(tree, object, new_data, type, ...) {
-  pred <- xgb_pred(
+  pred <- xgb_predict(
     object$fit,
-    newdata = new_data,
+    new_data = new_data,
     iterationrange = c(1, tree + 1),
     ntreelimit = NULL
   )

R/boost_tree_data.R

@@ -108,8 +108,8 @@ set_pred(
   value = list(
     pre = NULL,
     post = NULL,
-    func = c(fun = "xgb_pred"),
-    args = list(object = quote(object$fit), newdata = quote(new_data))
+    func = c(fun = "xgb_predict"),
+    args = list(object = quote(object$fit), new_data = quote(new_data))
   )
 )
 
@@ -121,8 +121,8 @@ set_pred(
   value = list(
     pre = NULL,
     post = NULL,
-    func = c(fun = "xgb_pred"),
-    args = list(object = quote(object$fit), newdata = quote(new_data))
+    func = c(fun = "xgb_predict"),
+    args = list(object = quote(object$fit), new_data = quote(new_data))
   )
 )
 
@@ -170,8 +170,8 @@ set_pred(
       }
       x
     },
-    func = c(pkg = NULL, fun = "xgb_pred"),
-    args = list(object = quote(object$fit), newdata = quote(new_data))
+    func = c(pkg = NULL, fun = "xgb_predict"),
+    args = list(object = quote(object$fit), new_data = quote(new_data))
   )
 )
 
@@ -196,8 +196,8 @@ set_pred(
       colnames(x) <- object$lvl
       x
     },
-    func = c(pkg = NULL, fun = "xgb_pred"),
-    args = list(object = quote(object$fit), newdata = quote(new_data))
+    func = c(pkg = NULL, fun = "xgb_predict"),
+    args = list(object = quote(object$fit), new_data = quote(new_data))
   )
 )
 
@@ -209,8 +209,8 @@ set_pred(
   value = list(
     pre = NULL,
     post = NULL,
-    func = c(fun = "xgb_pred"),
-    args = list(object = quote(object$fit), newdata = quote(new_data))
+    func = c(fun = "xgb_predict"),
+    args = list(object = quote(object$fit), new_data = quote(new_data))
   )
 )
 

R/descriptors.R

@@ -320,18 +320,6 @@ has_exprs <- function(x) {
   is_symbolic(x)
 }
 
-make_descr <- function(object) {
-  if (length(object$args) > 0)
-    expr_main <- map_lgl(object$args, has_exprs)
-  else
-    expr_main <- FALSE
-  if (length(object$eng_args) > 0)
-    expr_eng_args <- map_lgl(object$eng_args, has_exprs)
-  else
-    expr_eng_args <- FALSE
-  any(expr_main) | any(expr_eng_args)
-}
-
 # Locate descriptors -----------------------------------------------------------
 
 # take a model spec, see if any require descriptors

R/engine_docs.R

@@ -289,22 +289,6 @@ sort_c <- function(x) {
   withr::with_collate("C", sort(x))
 }
 
-get_sorted_unique_engines <- function(x) {
-  engines <- x$engine
-  engines <- unique(engines)
-  engines <- sort_c(engines)
-  engines
-}
-combine_prefix_with_engines <- function(prefix, engines) {
-  if (length(engines) == 0L) {
-    engines <- "No engines currently available"
-  } else {
-    engines <- glue::glue_collapse(engines, sep = ", ")
-  }
-
-  glue::glue("{prefix} {engines}")
-}
-
 # ------------------------------------------------------------------------------
 
 #' Locate and show errors/warnings in engine-specific documentation

R/fit.R

@@ -390,10 +390,6 @@ inher <- function(x, cls, cl) {
 
 # ------------------------------------------------------------------------------
 
-
-has_both_or_none <- function(a, b)
-  (!is.null(a) & is.null(b)) | (is.null(a) & !is.null(b))
-
 check_interface <- function(formula, data, cl, model) {
   inher(formula, "formula", cl)
   inher(data, c("data.frame", "tbl_spark"), cl)

R/linear_reg_gls.R

@@ -1,7 +1,7 @@
 #' Linear regression via generalized least squares
 #'
 #' The `"gls"` engine estimates linear regression for models where the rows of the
-#' data are not indpendent.
+#' data are not independent.
 #'
 #' @includeRmd man/rmd/linear_reg_gls.md details
 #'

R/misc.R

@@ -119,10 +119,6 @@ levels_from_formula <- function(f, dat) {
   res
 }
 
-is_spark <- function(x)
-  isTRUE(unname(x$method$fit$func["pkg"] == "sparklyr"))
-
-
 #' @export
 #' @keywords internal
 #' @rdname add_on_exports
@@ -211,17 +207,6 @@ check_outcome <- function(y, spec) {
   invisible(NULL)
 }
 
-
-# Get's a character string of varible names used as the outcome
-# in a terms object
-terms_y <- function(x) {
-  att <- attributes(x)
-  resp_ind <- att$response
-  y_expr <- att$predvars[[resp_ind + 1]]
-  all.vars(y_expr)
-}
-
-
 # ------------------------------------------------------------------------------
 
 #' @export