export internal functions for tidyclust (#1181)

Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com>

Author: EmilHvitfeldt

NAMESPACE

@@ -134,6 +134,7 @@ S3method(vec_restore,resample_results)
 S3method(vec_restore,tune_results)
 export(.catch_and_log)
 export(.check_grid)
+export(.check_param_objects)
 export(.config_key_from_metrics)
 export(.create_weight_mapping)
 export(.determine_pred_types)
@@ -153,13 +154,25 @@ export(.get_tune_outcome_names)
 export(.get_tune_parameter_names)
 export(.get_tune_parameters)
 export(.get_tune_workflow)
+export(.has_preprocessor)
+export(.has_preprocessor_formula)
+export(.has_preprocessor_recipe)
+export(.has_preprocessor_variables)
+export(.has_spec)
+export(.is_cataclysmic)
 export(.load_namespace)
 export(.loop_over_all_stages)
 export(.loop_over_all_stages2)
 export(.make_static)
+export(.needs_finalization)
 export(.par_fns)
+export(.set_workflow)
+export(.set_workflow_recipe)
+export(.set_workflow_spec)
 export(.stash_last_result)
+export(.update_model)
 export(.update_parallel_over)
+export(.update_recipe)
 export(.use_case_weights_with_yardstick)
 export(.validate_resample_weights)
 export(.weighted_sd)
@@ -251,6 +264,7 @@ export(min_grid.proportional_hazards)
 export(min_grid.rule_fit)
 export(mirai_installed)
 export(new_backend_options)
+export(new_bare_tibble)
 export(new_iteration_results)
 export(outcome_names)
 export(parameters)

R/checks.R

@@ -153,7 +153,10 @@ grid_msg <- "{.arg grid} should be a positive integer or a data frame."
   grid
 }
 
-needs_finalization <- function(x, nms = character(0)) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.needs_finalization <- function(x, nms = character(0)) {
   # If an unknown engine-specific parameter, the object column is missing and
   # no need for finalization
   x <- x[!is.na(x$object), ]
@@ -187,7 +190,7 @@ check_parameters <- function(
   tune_recipe <- tune_param$id[tune_param$source == "recipe"]
   tune_recipe <- length(tune_recipe) > 0
 
-  if (needs_finalization(pset, grid_names)) {
+  if (.needs_finalization(pset, grid_names)) {
     if (tune_recipe) {
       cli::cli_abort(
         c(
@@ -289,7 +292,10 @@ check_bayes_initial_size <- function(num_param, num_grid, race = FALSE) {
   invisible(NULL)
 }
 
-check_param_objects <- function(pset) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.check_param_objects <- function(pset) {
   params <- purrr::map_lgl(pset$object, inherits, "param")
 
   if (!all(params)) {
@@ -318,11 +324,11 @@ check_workflow <- function(
     )
   }
 
-  if (!has_preprocessor(x)) {
+  if (!.has_preprocessor(x)) {
     cli::cli_abort("A formula, recipe, or variables preprocessor is required.")
   }
 
-  if (!has_spec(x)) {
+  if (!.has_spec(x)) {
     cli::cli_abort("A parsnip model is required.")
   }
 
@@ -333,7 +339,7 @@ check_workflow <- function(
       pset <- hardhat::extract_parameter_set_dials(x)
     }
 
-    check_param_objects(pset)
+    .check_param_objects(pset)
 
     incompl <- dials::has_unknowns(pset$object)
 

R/collect.R

@@ -648,7 +648,7 @@ estimate_tune_results <- function(x, ..., col_name = ".metrics") {
   id_names <- grep("^id", names(x), value = TRUE)
   group_cols <- .get_extra_col_names(x)
 
-  all_bad <- is_cataclysmic(x)
+  all_bad <- .is_cataclysmic(x)
   if (all_bad) {
     cli::cli_abort(
       "All models failed. Run {.code show_notes(.Last.tune.result)} for more

R/finalize.R

@@ -92,12 +92,12 @@ finalize_workflow <- function(x, parameters) {
 
   mod <- extract_spec_parsnip(x)
   mod <- finalize_model(mod, parameters)
-  x <- set_workflow_spec(x, mod)
+  x <- .set_workflow_spec(x, mod)
 
-  if (has_preprocessor_recipe(x)) {
+  if (.has_preprocessor_recipe(x)) {
     rec <- extract_preprocessor(x)
     rec <- finalize_recipe(rec, parameters)
-    x <- set_workflow_recipe(x, rec)
+    x <- .set_workflow_recipe(x, rec)
   }
 
   if (has_postprocessor(x)) {

R/grid_helpers.R

@@ -8,7 +8,7 @@
 #   if (length(orig_rows) != nrow(x_vals)) {
 #     msg <- "Some assessment set rows are not available at prediction time."
 #
-#     if (has_preprocessor_recipe(workflow)) {
+#     if (.has_preprocessor_recipe(workflow)) {
 #       msg <-
 #         c(
 #           msg,
@@ -129,28 +129,40 @@ finalize_workflow_preprocessor <- function(workflow, grid_preprocessor) {
   recipe <- extract_preprocessor(workflow)
   recipe <- merge(recipe, grid_preprocessor)$x[[1]]
 
-  workflow <- set_workflow_recipe(workflow, recipe)
+  workflow <- .set_workflow_recipe(workflow, recipe)
 
   workflow
 }
 
 # ------------------------------------------------------------------------------
 
-has_preprocessor <- function(workflow) {
-  has_preprocessor_recipe(workflow) ||
-    has_preprocessor_formula(workflow) ||
-    has_preprocessor_variables(workflow)
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.has_preprocessor <- function(workflow) {
+  .has_preprocessor_recipe(workflow) ||
+    .has_preprocessor_formula(workflow) ||
+    .has_preprocessor_variables(workflow)
 }
 
-has_preprocessor_recipe <- function(workflow) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.has_preprocessor_recipe <- function(workflow) {
   "recipe" %in% names(workflow$pre$actions)
 }
 
-has_preprocessor_formula <- function(workflow) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.has_preprocessor_formula <- function(workflow) {
   "formula" %in% names(workflow$pre$actions)
 }
 
-has_preprocessor_variables <- function(workflow) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.has_preprocessor_variables <- function(workflow) {
   "variables" %in% names(workflow$pre$actions)
 }
 
@@ -162,16 +174,25 @@ has_case_weights <- function(workflow) {
   "case_weights" %in% names(workflow$pre$actions)
 }
 
-has_spec <- function(workflow) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.has_spec <- function(workflow) {
   "model" %in% names(workflow$fit$actions)
 }
 
-set_workflow_spec <- function(workflow, spec) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.set_workflow_spec <- function(workflow, spec) {
   workflow$fit$actions$model$spec <- spec
   workflow
 }
 
-set_workflow_recipe <- function(workflow, recipe) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.set_workflow_recipe <- function(workflow, recipe) {
   workflow$pre$actions$recipe$recipe <- recipe
   workflow
 }

R/loop_over_all_stages-helpers.R

@@ -336,7 +336,7 @@ finalize_fit_pre <- function(wflow_current, grid, static) {
     if (length(pre_proc_id) > 0) {
       grid <- grid[, pre_proc_id]
       pre_proc <- finalize_recipe(pre_proc, grid)
-      wflow_current <- set_workflow_recipe(wflow_current, pre_proc)
+      wflow_current <- .set_workflow_recipe(wflow_current, pre_proc)
     }
   }
   workflows::.fit_pre(wflow_current, static$data$fit$data)
@@ -352,7 +352,7 @@ finalize_fit_model <- function(wflow_current, grid) {
   if (length(mod_id) > 0) {
     grid <- grid[, mod_id]
     mod_spec <- finalize_model(mod_spec, grid)
-    wflow_current <- set_workflow_spec(wflow_current, mod_spec)
+    wflow_current <- .set_workflow_spec(wflow_current, mod_spec)
   }
 
   # .catch_and_log_fit()

R/merge.R

@@ -75,9 +75,20 @@ merge.model_spec <- function(x, y, ...) {
   merger(x, y, ...)
 }
 
-update_model <- function(grid, object, pset, step_id, nms, ...) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.update_model <- function(
+  grid,
+  object,
+  pset,
+  step_id,
+  nms,
+  ...,
+  source = "model_spec"
+) {
   for (i in nms) {
-    param_info <- pset |> dplyr::filter(id == i & source == "model_spec")
+    param_info <- pset |> dplyr::filter(id == i & .data$source == .env$source)
     if (nrow(param_info) > 1) {
       cli::cli_abort("Cannot update; there are too many parameters.")
     }
@@ -94,7 +105,10 @@ update_model <- function(grid, object, pset, step_id, nms, ...) {
   object
 }
 
-update_recipe <- function(grid, object, pset, step_id, nms, ...) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.update_recipe <- function(grid, object, pset, step_id, nms, ...) {
   for (i in nms) {
     param_info <- pset |> dplyr::filter(id == i & source == "recipe")
     if (nrow(param_info) == 1) {
@@ -123,10 +137,10 @@ merger <- function(x, y, ...) {
   # We will deliberately allow `y` to lack some tunable parameters in `x`
 
   if (inherits(x, "recipe")) {
-    updater <- update_recipe
+    updater <- .update_recipe
     step_ids <- purrr::map_chr(x$steps, "id")
   } else {
-    updater <- update_model
+    updater <- .update_model
     step_ids <- NULL
   }
 

R/tune_bayes.R

@@ -396,7 +396,7 @@ tune_bayes_workflow <- function(
 
     # Preempt `estimate_tune_results()` error and rely
     # on `on.exit()` condition to return preliminary results
-    if (is_cataclysmic(unsummarized)) {
+    if (.is_cataclysmic(unsummarized)) {
       return()
     }
 
@@ -514,7 +514,7 @@ tune_bayes_workflow <- function(
 
       check_time(start_time, control$time_limit)
 
-      all_bad <- is_cataclysmic(tmp_res)
+      all_bad <- .is_cataclysmic(tmp_res)
       if (!inherits(tmp_res, "try-error") & !all_bad) {
         tmp_res[[".metrics"]] <- purrr::map(
           tmp_res[[".metrics"]],
@@ -574,7 +574,7 @@ tune_bayes_workflow <- function(
       check_time(start_time, control$time_limit)
     }
 
-    workflow_output <- set_workflow(object, control)
+    workflow_output <- .set_workflow(object, control)
 
     # Reset `on.exit()` hook
     on.exit()
@@ -597,7 +597,7 @@ tune_bayes_workflow <- function(
 }
 
 create_initial_set <- function(param, n = NULL, checks) {
-  check_param_objects(param)
+  .check_param_objects(param)
   if (is.null(n)) {
     n <- nrow(param) + 1
   }
@@ -799,7 +799,7 @@ more_results <- function(
       type = "danger"
     )
   } else {
-    all_bad <- is_cataclysmic(tmp_res)
+    all_bad <- .is_cataclysmic(tmp_res)
     if (all_bad) {
       p_chr <- glue::glue_collapse(
         p_chr,
@@ -822,7 +822,10 @@ more_results <- function(
 }
 
 
-is_cataclysmic <- function(x) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.is_cataclysmic <- function(x) {
   is_err <- purrr::map_lgl(x$.metrics, inherits, c("simpleError", "error"))
   if (any(!is_err)) {
     is_good <- purrr::map_lgl(

R/tune_grid.R

@@ -394,14 +394,14 @@ tune_grid_workflow <- function(
 
   y_name <- outcome_names(resamples)
 
-  if (is_cataclysmic(resamples)) {
+  if (.is_cataclysmic(resamples)) {
     cli::cli_warn(
       "All models failed. Run {.code show_notes(.Last.tune.result)} for more
        information."
     )
   }
 
-  workflow <- set_workflow(workflow, control)
+  workflow <- .set_workflow(workflow, control)
 
   new_tune_results(
     x = resamples,
@@ -441,7 +441,10 @@ pull_rset_attributes <- function(x) {
 
 # ------------------------------------------------------------------------------
 
-set_workflow <- function(workflow, control) {
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
+.set_workflow <- function(workflow, control) {
   if (control$save_workflow) {
     if (!is.null(workflow)) {
       w_size <- utils::object.size(workflow)

R/utils.R

@@ -76,6 +76,9 @@ should_run_examples <- function(suggests = NULL) {
 
 # new_tibble() currently doesn't strip attributes
 # https://github.com/tidyverse/tibble/pull/769
+#' @export
+#' @keywords internal
+#' @rdname empty_ellipses
 new_bare_tibble <- function(x, ..., class = character()) {
   x <- vctrs::new_data_frame(x)
   tibble::new_tibble(x, nrow = nrow(x), ..., class = class)