Misc updates

DESCRIPTION

@@ -1,13 +1,13 @@
 Package: parsnip
-Version: 0.0.3.9001
+Version: 0.0.3.9002
 Title: A Common API to Modeling and Analysis Functions
 Description: A common interface is provided to allow users to specify a model without having to remember the different argument names across different functions or computational engines (e.g. 'R', 'Spark', 'Stan', etc). 
 Authors@R: c(
     person(given = "Max",   family = "Kuhn",    email = "[email protected]",   role = c("aut", "cre")),
     person(given = "Davis", family = "Vaughan", email = "[email protected]", role = c("aut")),
     person("RStudio", role = "cph"))
 Maintainer: Max Kuhn <[email protected]>
-URL: https://tidymodels.github.io/parsnip
+URL: https://tidymodels.github.io/parsnip, https://github.com/tidymodels/parsnip
 BugReports: https://github.com/tidymodels/parsnip/issues
 License: GPL-2
 Encoding: UTF-8

NEWS.md

@@ -6,8 +6,10 @@
 
 * A bug was fixed related to the column names generated by `multi_predict()`. The top-level tibble will always have a column named `.pred` and this list column contains tibbles across sub-models. The column names for these sub-model tibbles will have names consistent with `predict()` (which was previously incorrect). See [43c15db](https://github.com/tidymodels/parsnip/commit/43c15db377ea9ef27483ff209f6bd0e98cb830d2).
 
-# [A bug](https://github.com/tidymodels/parsnip/issues/174) was fixed
-standardizing the column names of `nnet` class probability predictions.
+* The model `udpate()` methods gained a `parameters` argument for cases when the parameters are contained in a tibble or list. 
+
+# [A bug](https://github.com/tidymodels/parsnip/issues/174) was fixed standardizing the column names of `nnet` class probability predictions.
+
 
 # parsnip 0.0.3.1
 

R/boost_tree.R

@@ -148,6 +148,10 @@ print.boost_tree <- function(x, ...) {
 
 #' @export
 #' @param object A boosted tree model specification.
+#' @param parameters A 1-row tibble or named list with _main_
+#'  parameters to update. If the individual arguments are used,
+#'  these will supersede the values in `parameters`. Also, using
+#'  engine arguments in this object will result in an error.
 #' @param ... Not used for `update()`.
 #' @param fresh A logical for whether the arguments should be
 #'  modified in-place of or replaced wholesale.
@@ -157,17 +161,31 @@ print.boost_tree <- function(x, ...) {
 #' model
 #' update(model, mtry = 1)
 #' update(model, mtry = 1, fresh = TRUE)
+#'
+#' param_values <- tibble::tibble(mtry = 10, tree_depth = 5)
+#'
+#' model %>% update(param_values)
+#' model %>% update(param_values, mtry = 3)
+#'
+#' param_values$verbose <- 0
+#' # Fails due to engine argument
+#' # model %>% update(param_values)
 #' @method update boost_tree
 #' @rdname boost_tree
 #' @export
 update.boost_tree <-
   function(object,
+           parameters = NULL,
            mtry = NULL, trees = NULL, min_n = NULL,
            tree_depth = NULL, learn_rate = NULL,
            loss_reduction = NULL, sample_size = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
 
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
+
     args <- list(
       mtry = enquo(mtry),
       trees = enquo(trees),
@@ -178,6 +196,8 @@ update.boost_tree <-
       sample_size = enquo(sample_size)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     # TODO make these blocks into a function and document well
     if (fresh) {
       object$args <- args

R/decision_tree.R

@@ -137,15 +137,22 @@ print.decision_tree <- function(x, ...) {
 #' @export
 update.decision_tree <-
   function(object,
+           parameters = NULL,
            cost_complexity = NULL, tree_depth = NULL, min_n = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
     args <- list(
       cost_complexity   = enquo(cost_complexity),
       tree_depth  = enquo(tree_depth),
       min_n  = enquo(min_n)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/linear_reg.R

@@ -169,14 +169,21 @@ translate.linear_reg <- function(x, engine = x$engine, ...) {
 #' @export
 update.linear_reg <-
   function(object,
+           parameters = NULL,
            penalty = NULL, mixture = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
     args <- list(
       penalty = enquo(penalty),
       mixture = enquo(mixture)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/logistic_reg.R

@@ -154,14 +154,21 @@ translate.logistic_reg <- translate.linear_reg
 #' @export
 update.logistic_reg <-
   function(object,
+           parameters = NULL,
            penalty = NULL, mixture = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
     args <- list(
       penalty = enquo(penalty),
       mixture = enquo(mixture)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/mars.R

@@ -106,16 +106,23 @@ print.mars <- function(x, ...) {
 #' @export
 update.mars <-
   function(object,
+           parameters = NULL,
            num_terms = NULL, prod_degree = NULL, prune_method = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
 
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
+
     args <- list(
       num_terms    = enquo(num_terms),
       prod_degree  = enquo(prod_degree),
       prune_method = enquo(prune_method)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/misc.R

@@ -232,3 +232,51 @@ terms_y <- function(x) {
   y_expr <- att$predvars[[resp_ind + 1]]
   all.vars(y_expr)
 }
+
+
+# ------------------------------------------------------------------------------
+
+check_final_param <- function(x) {
+  if (is.null(x)) {
+    return(invisible(x))
+  }
+  if (!is.list(x) & !tibble::is_tibble(x)) {
+    rlang::abort("The parameter object should be a list or tibble")
+  }
+  if (tibble::is_tibble(x) && nrow(x) > 1) {
+    rlang::abort("The parameter tibble should have a single row.")
+  }
+  if (tibble::is_tibble(x)) {
+    x <- as.list(x)
+  }
+  if (length(names) == 0 || any(names(x) == "")) {
+    rlang::abort("All values in `parameters` should have a name.")
+  }
+
+  invisible(x)
+}
+
+update_main_parameters <- function(args, param) {
+
+  if (length(param) == 0) {
+    return(args)
+  }
+  if (length(args) == 0) {
+    return(param)
+  }
+
+  # In case an engine argument is included:
+  has_extra_args <- !(names(param) %in% names(args))
+  extra_args <- names(param)[has_extra_args]
+  if (any(has_extra_args)) {
+    rlang::abort(
+      paste("At least one argument is not a main argument:",
+            paste0("`", extra_args, "`", collapse = ", "))
+    )
+  }
+  param <- param[!has_extra_args]
+
+
+
+  args <- utils::modifyList(args, param)
+}

R/mlp.R

@@ -139,10 +139,16 @@ print.mlp <- function(x, ...) {
 #' @export
 update.mlp <-
   function(object,
+           parameters = NULL,
            hidden_units = NULL, penalty = NULL, dropout = NULL,
            epochs = NULL, activation = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
+
     args <- list(
       hidden_units = enquo(hidden_units),
       penalty      = enquo(penalty),
@@ -151,6 +157,8 @@ update.mlp <-
       activation   = enquo(activation)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     # TODO make these blocks into a function and document well
     if (fresh) {
       object$args <- args

R/multinom_reg.R

@@ -137,14 +137,21 @@ translate.multinom_reg <- translate.linear_reg
 #' @export
 update.multinom_reg <-
   function(object,
+           parameters = NULL,
            penalty = NULL, mixture = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
     args <- list(
       penalty = enquo(penalty),
       mixture = enquo(mixture)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/nearest_neighbor.R

@@ -106,17 +106,25 @@ print.nearest_neighbor <- function(x, ...) {
 #' @export
 #' @inheritParams update.boost_tree
 update.nearest_neighbor <- function(object,
+                                    parameters = NULL,
                                     neighbors = NULL,
                                     weight_func = NULL,
                                     dist_power = NULL,
                                     fresh = FALSE, ...) {
   update_dot_check(...)
+
+  if (!is.null(parameters)) {
+    parameters <- check_final_param(parameters)
+  }
+
   args <- list(
     neighbors   = enquo(neighbors),
     weight_func = enquo(weight_func),
     dist_power  = enquo(dist_power)
   )
 
+  args <- update_main_parameters(args, parameters)
+
   if (fresh) {
     object$args <- args
   } else {

R/rand_forest.R

@@ -140,15 +140,22 @@ print.rand_forest <- function(x, ...) {
 #' @export
 update.rand_forest <-
   function(object,
+           parameters = NULL,
            mtry = NULL, trees = NULL, min_n = NULL,
            fresh = FALSE, ...) {
     update_dot_check(...)
+
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
     args <- list(
       mtry   = enquo(mtry),
       trees  = enquo(trees),
       min_n  = enquo(min_n)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     # TODO make these blocks into a function and document well
     if (fresh) {
       object$args <- args

R/surv_reg.R

@@ -111,12 +111,19 @@ print.surv_reg <- function(x, ...) {
 #' @method update surv_reg
 #' @rdname surv_reg
 #' @export
-update.surv_reg <- function(object, dist = NULL, fresh = FALSE, ...) {
+update.surv_reg <- function(object, parameters = NULL, dist = NULL, fresh = FALSE, ...) {
   update_dot_check(...)
+
+  if (!is.null(parameters)) {
+    parameters <- check_final_param(parameters)
+  }
+
   args <- list(
     dist = enquo(dist)
   )
 
+  args <- update_main_parameters(args, parameters)
+
   if (fresh) {
     object$args <- args
   } else {

R/svm_poly.R

@@ -106,18 +106,25 @@ print.svm_poly <- function(x, ...) {
 #' @export
 update.svm_poly <-
   function(object,
+           parameters = NULL,
            cost = NULL, degree = NULL, scale_factor = NULL, margin = NULL,
            fresh = FALSE,
            ...) {
     update_dot_check(...)
 
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
+
     args <- list(
       cost   = enquo(cost),
       degree  = enquo(degree),
       scale_factor  = enquo(scale_factor),
       margin  = enquo(margin)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {

R/svm_rbf.R

@@ -104,17 +104,24 @@ print.svm_rbf <- function(x, ...) {
 #' @export
 update.svm_rbf <-
   function(object,
+           parameters = NULL,
            cost = NULL, rbf_sigma = NULL, margin = NULL,
            fresh = FALSE,
            ...) {
     update_dot_check(...)
 
+    if (!is.null(parameters)) {
+      parameters <- check_final_param(parameters)
+    }
+
     args <- list(
       cost   = enquo(cost),
       rbf_sigma  = enquo(rbf_sigma),
       margin  = enquo(margin)
     )
 
+    args <- update_main_parameters(args, parameters)
+
     if (fresh) {
       object$args <- args
     } else {