Merge IT ALL

Merge branch 'master' into encoding-options

# Conflicts:
#	R/linear_reg_data.R
#	R/svm_poly_data.R
#	R/svm_rbf_data.R
#	tests/testthat/test_svm_poly.R
#	tests/testthat/test_svm_rbf.R

Author: juliasilge

NAMESPACE

@@ -143,6 +143,7 @@ export(predict_quantile.model_fit)
 export(predict_raw)
 export(predict_raw.model_fit)
 export(rand_forest)
+export(repair_call)
 export(rpart_train)
 export(set_args)
 export(set_dependency)

NEWS.md

@@ -4,10 +4,20 @@
 
  * `tidyr` >= 1.0.0 is now required. 
 
+ * SVM models produced by `kernlab` now use the formula method. This change was due to how `ksvm()` made indicator variables for factor predictors (with one-hot encodings). Since the ordinary formula method did not do this, the data are passed as-is to `ksvm()` so that the results are closer to what one would get if `ksmv()` were called directly. 
+ 
+ * MARS models produced by `earth` now use the formula method. 
+ 
+ * Under-the-hood changes were made so that non-standard data arguments in the modeling packages can be accomodated. (#315)
+ 
 ## New Features
 
  * A new main argument was added to `boost_tree()` called `stop_iter` for early stopping. The `xgb_train()` function gained arguments for early stopping and a percentage of data to leave out for a validation set. 
 
+ * If `fit()` is used and the underlying model uses a formula, the _actual_ formula is pass to the model (instead of a placeholder). This makes the model call better. 
+ 
+ * A function named `repair_call()` was added. This can help change the underlying models `call` object to better reflect what they would have obtained if the model function had been used directly (instead of via `parsnip`). This is only useful when the user chooses a formula interface and the model uses a formula interface. It will also be of limited use when a recipes is used to construct the feature set in `workflows` or `tune`. 
+ 
 # parsnip 0.1.1
 
 ## New Features

R/aaa.R

@@ -66,7 +66,7 @@ utils::globalVariables(
     'lab', 'original', 'predicted_label', 'prediction', 'value', 'type',
     "neighbors", ".submodels", "has_submodel", "max_neighbor", "max_penalty",
     "max_terms", "max_tree", "model", "name", "num_terms", "penalty", "trees",
-    "sub_neighbors", ".pred_class")
+    "sub_neighbors", ".pred_class", "x", "y")
 )
 
 # nocov end

R/aaa_models.R

@@ -195,14 +195,35 @@ check_fit_info <- function(fit_obj) {
   if (is.null(fit_obj)) {
     rlang::abort("The `fit` module cannot be NULL.")
   }
+
+  # check required data elements
   exp_nms <- c("defaults", "func", "interface", "protect")
-  if (!isTRUE(all.equal(sort(names(fit_obj)), exp_nms))) {
+  has_req_nms <- exp_nms %in% names(fit_obj)
+
+  if (!all(has_req_nms)) {
     rlang::abort(
       glue::glue("The `fit` module should have elements: ",
       glue::glue_collapse(glue::glue("`{exp_nms}`"), sep = ", "))
       )
   }
 
+  # check optional data elements
+  opt_nms <- c("data")
+  other_nms <- setdiff(exp_nms, names(fit_obj))
+  has_opt_nms <- other_nms %in% opt_nms
+  if (any(!has_opt_nms)) {
+    msg <- glue::glue("The `fit` module can only have optional elements: ",
+                      glue::glue_collapse(glue::glue("`{exp_nms}`"), sep = ", "))
+
+    rlang::abort(msg)
+  }
+  if (any(other_nms == "data")) {
+    data_nms <- names(fit_obj$data)
+    if (length(data_nms == 0) || any(data_nms == "")) {
+      rlang::abort("All elements of the `data` argument vector must be named.")
+    }
+  }
+
   check_interface_val(fit_obj$interface)
   check_func_val(fit_obj$func)
 

R/arguments.R

@@ -24,7 +24,7 @@ check_eng_args <- function(args, obj, core_args) {
   if (length(common_args) > 0) {
     args <- args[!(names(args) %in% common_args)]
     common_args <- paste0(common_args, collapse = ", ")
-    rlang::warn(glue::glue("The following arguments cannot be manually modified",
+    rlang::warn(glue::glue("The following arguments cannot be manually modified ",
                            "and were removed: {common_args}."))
   }
   args
@@ -113,3 +113,94 @@ eval_args <- function(spec, ...) {
   spec$eng_args <- purrr::map(spec$eng_args, maybe_eval)
   spec
 }
+
+# ------------------------------------------------------------------------------
+
+# In some cases, a model function that we are calling has non-standard argument
+# names. For example, a function foo() that only has the x/y interface might
+# have a signature like `foo(X, Y)`.
+
+# To deal with this, we allow for the `data` element of the model
+# as an option to specify these actual argument names
+#
+#   value = list(
+#     interface = "xy",
+#     data = c(x = "X", y = "Y"),
+#     protect = c("X", "Y"),
+#     func = c(pkg = "bar", fun = "foo"),
+#     defaults = list()
+#   )
+
+make_call <- function(fun, ns, args, ...) {
+  # remove any null or placeholders (`missing_args`) that remain
+  discard <-
+    vapply(args, function(x)
+      is_missing_arg(x) | is.null(x), logical(1))
+  args <- args[!discard]
+
+  if (!is.null(ns) & !is.na(ns)) {
+    out <- call2(fun, !!!args, .ns = ns)
+  } else
+    out <- call2(fun, !!!args)
+  out
+}
+
+
+make_form_call <- function(object, env = NULL) {
+  fit_args <- object$method$fit$args
+
+  # Get the arguments related to data:
+  if (is.null(object$method$fit$data)) {
+    data_args <- c(formula = "formula", data = "data")
+  } else {
+    data_args <- object$method$fit$data
+  }
+
+  # add data arguments
+  for (i in seq_along(data_args)) {
+    fit_args[[ unname(data_args[i]) ]] <- sym(names(data_args)[i])
+  }
+
+  # sub in actual formula
+  fit_args[[ unname(data_args["formula"]) ]]  <- env$formula
+
+  if (object$engine == "spark") {
+    env$x <- env$data
+  }
+
+  fit_call <- make_call(
+    fun = object$method$fit$func["fun"],
+    ns = object$method$fit$func["pkg"],
+    fit_args
+  )
+  fit_call
+}
+
+make_xy_call <- function(object, target) {
+  fit_args <- object$method$fit$args
+
+  # Get the arguments related to data:
+  if (is.null(object$method$fit$data)) {
+    data_args <- c(x = "x", y = "y")
+  } else {
+    data_args <- object$method$fit$data
+  }
+
+  object$method$fit$args[[ unname(data_args["y"]) ]] <- rlang::expr(y)
+  object$method$fit$args[[ unname(data_args["x"]) ]] <-
+    switch(
+      target,
+      none = rlang::expr(x),
+      data.frame = rlang::expr(as.data.frame(x)),
+      matrix = rlang::expr(as.matrix(x)),
+      rlang::abort(glue::glue("Invalid data type target: {target}."))
+    )
+
+  fit_call <- make_call(
+    fun = object$method$fit$func["fun"],
+    ns = object$method$fit$func["pkg"],
+    object$method$fit$args
+  )
+
+  fit_call
+}

R/boost_tree_data.R

@@ -358,6 +358,7 @@ set_fit(
   mode = "regression",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "type"),
     func = c(pkg = "sparklyr", fun = "ml_gradient_boosted_trees"),
     defaults = list(seed = expr(sample.int(10 ^ 5, 1)))
@@ -377,6 +378,7 @@ set_fit(
   mode = "classification",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "type"),
     func = c(pkg = "sparklyr", fun = "ml_gradient_boosted_trees"),
     defaults = list(seed = expr(sample.int(10 ^ 5, 1)))

R/decision_tree.R

@@ -102,7 +102,7 @@ print.decision_tree <- function(x, ...) {
 
 #' @export
 #' @inheritParams update.boost_tree
-#' @param object A random forest model specification.
+#' @param object A decision tree model specification.
 #' @examples
 #' model <- decision_tree(cost_complexity = 10, min_n = 3)
 #' model

R/decision_tree_data.R

@@ -258,6 +258,7 @@ set_fit(
   mode = "regression",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula"),
     func = c(pkg = "sparklyr", fun = "ml_decision_tree_classifier"),
     defaults =
@@ -278,6 +279,7 @@ set_fit(
   mode = "classification",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula"),
     func = c(pkg = "sparklyr", fun = "ml_decision_tree_classifier"),
     defaults =

R/fit_helpers.R

@@ -30,21 +30,7 @@ form_form <-
     # sub in arguments to actual syntax for corresponding engine
     object <- translate(object, engine = object$engine)
 
-    fit_args <- object$method$fit$args
-
-    if (is_spark(object)) {
-      fit_args$x <- quote(x)
-      env$x <- env$data
-    } else {
-      fit_args$data <- quote(data)
-    }
-    fit_args$formula <- quote(formula)
-
-    fit_call <- make_call(
-      fun = object$method$fit$func["fun"],
-      ns = object$method$fit$func["pkg"],
-      fit_args
-    )
+    fit_call <- make_form_call(object, env = env)
 
     res <- list(
       lvl = y_levels,
@@ -89,21 +75,7 @@ xy_xy <- function(object, env, control, target = "none", ...) {
   # sub in arguments to actual syntax for corresponding engine
   object <- translate(object, engine = object$engine)
 
-  object$method$fit$args[["y"]] <- quote(y)
-  object$method$fit$args[["x"]] <-
-    switch(
-      target,
-      none = quote(x),
-      data.frame = quote(as.data.frame(x)),
-      matrix = quote(as.matrix(x)),
-      rlang::abort(glue::glue("Invalid data type target: {target}."))
-    )
-
-  fit_call <- make_call(
-    fun = object$method$fit$func["fun"],
-    ns = object$method$fit$func["pkg"],
-    object$method$fit$args
-  )
+  fit_call <- make_xy_call(object, target)
 
   res <- list(lvl = levels(env$y), spec = object)
 

R/linear_reg_data.R

@@ -314,6 +314,7 @@ set_fit(
   mode = "regression",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "weight_col"),
     func = c(pkg = "sparklyr", fun = "ml_linear_regression"),
     defaults = list()

R/logistic_reg_data.R

@@ -249,6 +249,7 @@ set_fit(
   mode = "classification",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "weight_col"),
     func = c(pkg = "sparklyr", fun = "ml_logistic_regression"),
     defaults =

R/mars_data.R

@@ -40,8 +40,8 @@ set_fit(
   eng = "earth",
   mode = "regression",
   value = list(
-    interface = "data.frame",
-    protect = c("x", "y", "weights"),
+    interface = "formula",
+    protect = c("formula", "data", "weights"),
     func = c(pkg = "earth", fun = "earth"),
     defaults = list(keepxy = TRUE)
   )
@@ -59,8 +59,8 @@ set_fit(
   eng = "earth",
   mode = "classification",
   value = list(
-    interface = "data.frame",
-    protect = c("x", "y", "weights"),
+    interface = "formula",
+    protect = c("formula", "data", "weights"),
     func = c(pkg = "earth", fun = "earth"),
     defaults = list(keepxy = TRUE)
   )

R/misc.R

@@ -115,22 +115,6 @@ convert_arg <- function(x) {
     x
 }
 
-make_call <- function(fun, ns, args, ...) {
-
-  #args <- map(args, convert_arg)
-
-  # remove any null or placeholders (`missing_args`) that remain
-  discard <-
-    vapply(args, function(x)
-      is_missing_arg(x) | is.null(x), logical(1))
-  args <- args[!discard]
-
-  if (!is.null(ns) & !is.na(ns)) {
-    out <- call2(fun, !!!args, .ns = ns)
-  } else
-    out <- call2(fun, !!!args)
-  out
-}
 
 levels_from_formula <- function(f, dat) {
   if (inherits(dat, "tbl_spark"))

R/mlp.R

@@ -37,7 +37,7 @@
 #' @param dropout A number between 0 (inclusive) and 1 denoting the proportion
 #'  of model parameters randomly set to zero during model training.
 #' @param epochs An integer for the number of training iterations.
-#' @param activation A single character strong denoting the type of relationship
+#' @param activation A single character string denoting the type of relationship
 #'  between the original predictors and the hidden unit layer. The activation
 #'  function between the hidden and output layers is automatically set to either
 #'  "linear" or "softmax" depending on the type of outcome. Possible values are:
@@ -105,7 +105,7 @@ print.mlp <- function(x, ...) {
 #'
 #' @export
 #' @inheritParams update.boost_tree
-#' @param object A random forest model specification.
+#' @param object A multilayer perceptron model specification.
 #' @examples
 #' model <- mlp(hidden_units = 10, dropout = 0.30)
 #' model

R/multinom_reg_data.R

@@ -128,6 +128,7 @@ set_fit(
   mode = "classification",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "weight_col"),
     func = c(pkg = "sparklyr", fun = "ml_logistic_regression"),
     defaults = list(family = "multinomial")

R/predict.R

@@ -191,7 +191,7 @@ format_num <- function(x) {
       names(x) <- paste0(".pred_", names(x))
     }
   } else {
-    x <- tibble(.pred = x)
+    x <- tibble(.pred = unname(x))
   }
 
   x
@@ -201,14 +201,15 @@ format_class <- function(x) {
   if (inherits(x, "tbl_spark"))
     return(x)
 
-  tibble(.pred_class = x)
+  tibble(.pred_class = unname(x))
 }
 
 format_classprobs <- function(x) {
   if (!any(grepl("^\\.pred_", names(x)))) {
     names(x) <- paste0(".pred_", names(x))
   }
   x <- as_tibble(x)
+  x <- purrr::map_dfr(x, rlang::set_names, NULL)
   x
 }
 

R/rand_forest_data.R

@@ -496,6 +496,7 @@ set_fit(
   mode = "classification",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "type"),
     func = c(pkg = "sparklyr", fun = "ml_random_forest"),
     defaults = list(seed = expr(sample.int(10 ^ 5, 1)))
@@ -515,6 +516,7 @@ set_fit(
   mode = "regression",
   value = list(
     interface = "formula",
+    data = c(formula = "formula", data = "x"),
     protect = c("x", "formula", "type"),
     func = c(pkg = "sparklyr", fun = "ml_random_forest"),
     defaults = list(seed = expr(sample.int(10 ^ 5, 1)))