Merge branch 'main' into gam-775

Author: topepo

.github/workflows/R-CMD-check.yaml

@@ -62,13 +62,13 @@ jobs:
       - name: Install Miniconda
         # conda can fail at downgrading python, so we specify python version in advance
         env:
-          RETICULATE_MINICONDA_PYTHON_VERSION: "3.7"
+          RETICULATE_MINICONDA_PYTHON_VERSION: "3.8"
         run: reticulate::install_miniconda() # creates r-reticulate conda env by default
         shell: Rscript {0}
 
       - name: Install TensorFlow
         run: |
-          tensorflow::install_tensorflow(version='2.7', conda_python_version = NULL)
+          tensorflow::install_tensorflow(version='2.13', conda_python_version = NULL)
         shell: Rscript {0}
 
       - uses: r-lib/actions/check-r-package@v2

.github/workflows/pkgdown.yaml

@@ -36,13 +36,13 @@ jobs:
       - name: Install Miniconda
         # conda can fail at downgrading python, so we specify python version in advance
         env:
-          RETICULATE_MINICONDA_PYTHON_VERSION: "3.7"
+          RETICULATE_MINICONDA_PYTHON_VERSION: "3.8"
         run: reticulate::install_miniconda() # creates r-reticulate conda env by default
         shell: Rscript {0}
 
       - name: Install TensorFlow
         run: |
-          tensorflow::install_tensorflow(version='2.7', conda_python_version = NULL)
+          tensorflow::install_tensorflow(version='2.13', conda_python_version = NULL)
         shell: Rscript {0}
 
       - name: Build site

.github/workflows/test-coverage.yaml

@@ -33,13 +33,13 @@ jobs:
       - name: Install Miniconda
         # conda can fail at downgrading python, so we specify python version in advance
         env:
-          RETICULATE_MINICONDA_PYTHON_VERSION: "3.7"
+          RETICULATE_MINICONDA_PYTHON_VERSION: "3.8"
         run: reticulate::install_miniconda() # creates r-reticulate conda env by default
         shell: Rscript {0}
 
       - name: Install TensorFlow
         run: |
-          tensorflow::install_tensorflow(version='2.7', conda_python_version = NULL)
+          tensorflow::install_tensorflow(version='2.13', conda_python_version = NULL)
         shell: Rscript {0}
 
       - name: Test coverage

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: parsnip
 Title: A Common API to Modeling and Analysis Functions
-Version: 1.2.1.9000
+Version: 1.2.1.9001
 Authors@R: c(
     person("Max", "Kuhn", , "[email protected]", role = c("aut", "cre")),
     person("Davis", "Vaughan", , "[email protected]", role = "aut"),
@@ -25,7 +25,7 @@ Imports:
     ggplot2,
     globals,
     glue,
-    hardhat (>= 1.1.0),
+    hardhat (>= 1.3.1.9000),
     lifecycle,
     magrittr,
     pillar,
@@ -77,4 +77,6 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
+Remotes:  
+    tidymodels/hardhat
 RoxygenNote: 7.3.1

NAMESPACE

@@ -29,6 +29,7 @@ S3method(check_args,svm_linear)
 S3method(check_args,svm_poly)
 S3method(check_args,svm_rbf)
 S3method(extract_fit_engine,model_fit)
+S3method(extract_fit_time,model_fit)
 S3method(extract_parameter_dials,model_spec)
 S3method(extract_parameter_set_dials,model_spec)
 S3method(extract_spec_parsnip,model_fit)
@@ -222,6 +223,7 @@ export(discrim_quad)
 export(discrim_regularized)
 export(eval_args)
 export(extract_fit_engine)
+export(extract_fit_time)
 export(extract_parameter_dials)
 export(extract_parameter_set_dials)
 export(extract_spec_parsnip)
@@ -376,6 +378,7 @@ importFrom(generics,varying_args)
 importFrom(ggplot2,autoplot)
 importFrom(glue,glue_collapse)
 importFrom(hardhat,extract_fit_engine)
+importFrom(hardhat,extract_fit_time)
 importFrom(hardhat,extract_parameter_dials)
 importFrom(hardhat,extract_parameter_set_dials)
 importFrom(hardhat,extract_spec_parsnip)

NEWS.md

@@ -1,7 +1,13 @@
 # parsnip (development version)
 
+
 * `fit_xy()` currently raises an error for `gen_additive_mod()` model specifications as the default engine (`"mgcv"`) specifies smoothing terms in model formulas. However, some engines specify smooths via additional arguments, in which case the restriction on `fit_xy()` is excessive. parsnip will now only raise an error when fitting a `gen_additive_mod()` with `fit_xy()` when using the `"mgcv"` engine (#775).
 
+* Aligned `null_model()` with other model types; the model type now has an engine argument that defaults to `"parsnip"` and is checked with the same machinery that checks other model types in the package (#1083).
+
+* New `extract_fit_time()` method has been added that returns the time it took to train the model (#853).
+
+
 # parsnip 1.2.1
 
 * Added a missing `tidy()` method for survival analysis glmnet models (#1086).

R/bag_tree.R

@@ -85,9 +85,7 @@ update.bag_tree <-
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.bag_tree <- function(object) {
-  if (object$engine == "C5.0" && object$mode == "regression")
-    stop("C5.0 is classification only.", call. = FALSE)
+check_args.bag_tree <- function(object, call = rlang::caller_env()) {
   invisible(object)
 }
 

R/boost_tree.R

@@ -164,23 +164,15 @@ translate.boost_tree <- function(x, engine = x$engine, ...) {
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.boost_tree <- function(object) {
+check_args.boost_tree <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$trees) && args$trees < 0) {
-    rlang::abort("`trees` should be >= 1.")
-  }
-  if (is.numeric(args$sample_size) && (args$sample_size < 0 | args$sample_size > 1)) {
-    rlang::abort("`sample_size` should be within [0,1].")
-  }
-  if (is.numeric(args$tree_depth) && args$tree_depth < 0) {
-    rlang::abort("`tree_depth` should be >= 1.")
-  }
-  if (is.numeric(args$min_n) && args$min_n < 0) {
-    rlang::abort("`min_n` should be >= 1.")
-  }
-
+  check_number_whole(args$trees, min = 0, allow_null = TRUE, call = call, arg = "trees")
+  check_number_decimal(args$sample_size, min = 0, max = 1, allow_null = TRUE, call = call, arg = "sample_size")
+  check_number_whole(args$tree_depth, min = 0, allow_null = TRUE, call = call, arg = "tree_depth")
+  check_number_whole(args$min_n, min = 0, allow_null = TRUE, call = call, arg = "min_n")
+  
   invisible(object)
 }
 

R/c5_rules.R

@@ -111,32 +111,23 @@ update.C5_rules <-
 # make work in different places
 
 #' @export
-check_args.C5_rules <- function(object) {
+check_args.C5_rules <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$trees)) {
-    if (length(args$trees) > 1) {
-      rlang::abort("Only a single value of `trees` is used.")
-    }
-    msg <- "The number of trees should be >= 1 and <= 100. Truncating the value."
-    if (args$trees > 100) {
-      object$args$trees <-
-        rlang::new_quosure(100L, env = rlang::empty_env())
-      rlang::warn(msg)
-    }
-    if (args$trees < 1) {
-      object$args$trees <-
-        rlang::new_quosure(1L, env = rlang::empty_env())
-      rlang::warn(msg)
-    }
+  check_number_whole(args$min_n, allow_null = TRUE, call = call, arg = "min_n")
+  check_number_whole(args$tree, allow_null = TRUE, call = call, arg = "tree")
 
+  msg <- "The number of trees should be {.code >= 1} and {.code <= 100}"
+  if (!(is.null(args$trees)) && args$trees > 100) {
+    object$args$trees <- rlang::new_quosure(100L, env = rlang::empty_env())
+    cli::cli_warn(c(msg, "Truncating to 100."))
   }
-  if (is.numeric(args$min_n)) {
-    if (length(args$min_n) > 1) {
-      rlang::abort("Only a single `min_n`` value is used.")
-    }
+  if (!(is.null(args$trees)) && args$trees < 1) {
+    object$args$trees <- rlang::new_quosure(1L, env = rlang::empty_env())
+    cli::cli_warn(c(msg, "Truncating to 1."))
   }
+
   invisible(object)
 }
 

R/cubist_rules.R

@@ -135,44 +135,36 @@ update.cubist_rules <-
 # make work in different places
 
 #' @export
-check_args.cubist_rules <- function(object) {
+check_args.cubist_rules <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$committees)) {
-    if (length(args$committees) > 1) {
-      rlang::abort("Only a single committee member is used.")
-    }
-    msg <- "The number of committees should be >= 1 and <= 100. Truncating the value."
-    if (args$committees > 100) {
-      object$args$committees <-
-        rlang::new_quosure(100L, env = rlang::empty_env())
-      rlang::warn(msg)
-    }
-    if (args$committees < 1) {
-      object$args$committees <-
-        rlang::new_quosure(1L, env = rlang::empty_env())
-      rlang::warn(msg)
-    }
+  check_number_whole(args$committees, allow_null = TRUE, call = call, arg = "committees")
 
-  }
-  if (is.numeric(args$neighbors)) {
-    if (length(args$neighbors) > 1) {
-      rlang::abort("Only a single neighbors value is used.")
-    }
-    msg <- "The number of neighbors should be >= 0 and <= 9. Truncating the value."
-    if (args$neighbors > 9) {
-      object$args$neighbors <-
-        rlang::new_quosure(9L, env = rlang::empty_env())
-      rlang::warn(msg)
-    }
-    if (args$neighbors < 0) {
-      object$args$neighbors <-
-        rlang::new_quosure(0L, env = rlang::empty_env())
-      rlang::warn(msg)
+  msg <- "The number of committees should be {.code >= 1} and {.code <= 100}."
+  if (!(is.null(args$committees)) && args$committees > 100) {
+    object$args$committees <-
+      rlang::new_quosure(100L, env = rlang::empty_env())
+      cli::cli_warn(c(msg, "Truncating to 100."))
     }
+  if (!(is.null(args$committees)) && args$committees < 1) {
+    object$args$committees <-
+      rlang::new_quosure(1L, env = rlang::empty_env())
+      cli::cli_warn(c(msg, "Truncating to 1."))
+  }
+
+  check_number_whole(args$neighbors, allow_null = TRUE, call = call, arg = "neighbors")
 
+  msg <- "The number of neighbors should be {.code >= 0} and {.code <= 9}."
+  if (!(is.null(args$neighbors)) && args$neighbors > 9) {
+    object$args$neighbors <- rlang::new_quosure(9L, env = rlang::empty_env())
+    cli::cli_warn(c(msg, "Truncating to 9."))
   }
+  if (!(is.null(args$neighbors)) && args$neighbors < 0) {
+    object$args$neighbors <- rlang::new_quosure(0L, env = rlang::empty_env())
+    cli::cli_warn(c(msg, "Truncating to 0."))
+  }
+
   invisible(object)
 }
 

R/decision_tree.R

@@ -128,9 +128,7 @@ translate.decision_tree <- function(x, engine = x$engine, ...) {
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.decision_tree <- function(object) {
-  if (object$engine == "C5.0" && object$mode == "regression")
-    rlang::abort("C5.0 is classification only.")
+check_args.decision_tree <- function(object, call = rlang::caller_env()) {
   invisible(object)
 }
 

R/discrim_flexible.R

@@ -85,21 +85,14 @@ update.discrim_flexible <-
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.discrim_flexible <- function(object) {
+check_args.discrim_flexible <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$prod_degree) && args$prod_degree < 0)
-    stop("`prod_degree` should be >= 1", call. = FALSE)
-
-  if (is.numeric(args$num_terms) && args$num_terms < 0)
-    stop("`num_terms` should be >= 1", call. = FALSE)
-
-  if (!is.character(args$prune_method) &&
-      !is.null(args$prune_method) &&
-      !is.character(args$prune_method))
-    stop("`prune_method` should be a single string value", call. = FALSE)
-
+  check_number_whole(args$prod_degree, min = 1, allow_null = TRUE, call = call, arg = "prod_degree")
+  check_number_whole(args$num_terms, min = 1, allow_null = TRUE, call = call, arg = "num_terms")
+  check_string(args$prune_method, allow_empty = FALSE, allow_null = TRUE, call = call, arg = "prune_method")
+  
   invisible(object)
 }
 

R/discrim_linear.R

@@ -80,13 +80,11 @@ update.discrim_linear <-
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.discrim_linear <- function(object) {
+check_args.discrim_linear <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (all(is.numeric(args$penalty)) && any(args$penalty < 0)) {
-    stop("The amount of regularization should be >= 0", call. = FALSE)
-  }
+  check_number_decimal(args$penalty, min = 0, allow_null = TRUE, call = call, arg = "penalty")
 
   invisible(object)
 }

R/discrim_regularized.R

@@ -95,18 +95,13 @@ update.discrim_regularized <-
 # ------------------------------------------------------------------------------
 
 #' @export
-check_args.discrim_regularized <- function(object) {
+check_args.discrim_regularized <- function(object, call = rlang::caller_env()) {
 
   args <- lapply(object$args, rlang::eval_tidy)
 
-  if (is.numeric(args$frac_common_cov) &&
-      (args$frac_common_cov < 0 | args$frac_common_cov > 1)) {
-    stop("The common covariance fraction should be between zero and one", call. = FALSE)
-  }
-  if (is.numeric(args$frac_identity) &&
-      (args$frac_identity < 0 | args$frac_identity > 1)) {
-    stop("The identity matrix fraction should be between zero and one", call. = FALSE)
-  }
+  check_number_decimal(args$frac_common_cov, min = 0, max = 1, allow_null = TRUE, call = call, arg = "frac_common_cov")
+  check_number_decimal(args$frac_identity, min = 0, max = 1, allow_null = TRUE, call = call, arg = "frac_identity")
+  
   invisible(object)
 }
 

R/extract.R

@@ -14,8 +14,15 @@
 #'
 #' - `extract_parameter_set_dials()` returns a set of dials parameter objects.
 #'
+#' - `extract_fit_time()` returns a tibble with fit times. The fit times
+#'   correspond to the time for the parsnip engine to fit and do not include
+#'   other portions of the elapsed time in [parsnip::fit.model_spec()].
+#'
 #' @param x A parsnip `model_fit` object or a parsnip `model_spec` object.
 #' @param parameter A single string for the parameter ID.
+#' @param summarize A logical for whether the elapsed fit time should be
+#'   returned as a single row or multiple rows. Doesn't support `FALSE` for
+#'   parsnip models.
 #' @param ... Not currently used.
 #' @details
 #' Extracting the underlying engine fit can be helpful for describing the
@@ -127,3 +134,20 @@ eval_call_info <-  function(x) {
 extract_parameter_dials.model_spec <- function(x, parameter, ...) {
   extract_parameter_dials(extract_parameter_set_dials(x), parameter)
 }
+
+#' @export
+#' @rdname extract-parsnip
+extract_fit_time.model_fit <- function(x, summarize = TRUE, ...) {
+  elapsed <- x[["elapsed"]][["elapsed"]][["elapsed"]]
+
+  if (is.na(elapsed) || is.null(elapsed)) {
+    rlang::abort(
+      "This model was fit before `extract_fit_time()` was added."
+    )
+  }
+
+  dplyr::tibble(
+    stage_id = class(x$spec)[1],
+    elapsed = elapsed
+  )
+}

R/fit.R

@@ -453,8 +453,15 @@ allow_sparse <- function(x) {
 #' @export
 print.model_fit <- function(x, ...) {
   cat("parsnip model object\n\n")
-  if (!is.na(x$elapsed[["elapsed"]])) {
-    cat("Fit time: ", prettyunits::pretty_sec(x$elapsed[["elapsed"]]), "\n")
+
+  if (is.null(x$elapsed$print) && !is.na(x$elapsed[["elapsed"]])) {
+    elapsed <- x$elapsed[["elapsed"]]
+    cat("Fit time: ", prettyunits::pretty_sec(elapsed), "\n")
+  }
+
+  if (isTRUE(x$elapsed$print)) {
+    elapsed <- x$elapsed$elapsed[["elapsed"]]
+    cat("Fit time: ", prettyunits::pretty_sec(elapsed), "\n")
   }
 
   if (inherits(x$fit, "try-error")) {