Merge branch 'master' into multinom_reg_pred

Author: patr1ckm

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
@@ -28,6 +28,7 @@ Imports:
     stats,
     tidyr,
     globals,
+    prettyunits,
     vctrs (>= 0.2.0)
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 6.1.99.9001

NEWS.md

@@ -1,14 +1,25 @@
 # parsnip 0.0.3.9001
 
-* [A bug](https://github.com/tidymodels/parsnip/issues/222) was fixed standardizing
-the output column types of `multi_predict` and `predict` for `multinom_reg`.
+## New Features
+
+* The time elapsed during model fitting is stored in the `$elapsed` slot of the
+parsnip model object, and is printed when the model object is printed.
 
 * Some default parameter ranges were updated for SVM, KNN, and MARS models. 
 
+## Fixes
+* [A bug](https://github.com/tidymodels/parsnip/issues/222) was fixed standardizing
+the output column types of `multi_predict` and `predict` for `multinom_reg`.
+
 * [A bug](https://github.com/tidymodels/parsnip/issues/208) was fixed related to using data descriptors and `fit_xy()`. 
 
 * 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).
 
+* 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
 
 Test case update due to CRAN running extra tests [(#202)](https://github.com/tidymodels/parsnip/issues/202)

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/fit.R

@@ -367,6 +367,7 @@ check_xy_interface <- function(x, y, cl, model) {
 #' @export
 print.model_fit <- function(x, ...) {
   cat("parsnip model object\n\n")
+  cat("Fit in: ", prettyunits::pretty_sec(x$elapsed[["elapsed"]]))
 
   if (inherits(x$fit, "try-error")) {
     cat("Model fit failed with error:\n", x$fit, "\n")

R/fit_helpers.R

@@ -52,14 +52,17 @@ form_form <-
       spec = object
     )
 
-    res$fit <- eval_mod(
-      fit_call,
-      capture = control$verbosity == 0,
-      catch = control$catch,
-      env = env,
-      ...
+    elapsed <- system.time(
+      res$fit <- eval_mod(
+        fit_call,
+        capture = control$verbosity == 0,
+        catch = control$catch,
+        env = env,
+        ...
+      )
     )
     res$preproc <- list(y_var = all.vars(env$formula[[2]]))
+    res$elapsed <- elapsed
     res
   }
 
@@ -107,19 +110,24 @@ xy_xy <- function(object, env, control, target = "none", ...) {
 
   res <- list(lvl = levels(env$y), spec = object)
 
-  res$fit <- eval_mod(
-    fit_call,
-    capture = control$verbosity == 0,
-    catch = control$catch,
-    env = env,
-    ...
+
+  elapsed <- system.time(
+    res$fit <- eval_mod(
+      fit_call,
+      capture = control$verbosity == 0,
+      catch = control$catch,
+      env = env,
+      ...
+    )
   )
+
   if (is.vector(env$y)) {
     y_name <- character(0)
   } else {
     y_name <- colnames(env$y)
   }
   res$preproc <- list(y_var = y_name)
+  res$elapsed <- elapsed
   res
 }
 

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
@@ -381,7 +389,7 @@ nnet_softmax <- function(results, object) {
 
   results <- apply(results, 1, function(x) exp(x)/sum(exp(x)))
   results <- t(results)
-  names(results) <- paste0(".pred_", object$lvl)
+  colnames(results) <- object$lvl
   results <- as_tibble(results)
   results
 }

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 {