fix cran checks on no visible binding for global variables

R/evaluator-lib-feature-selection.R

@@ -145,6 +145,9 @@ eval_feature_selection_err <- function(fit_results, vary_params = NULL,
                                        estimate_col = NULL, imp_col,
                                        group_cols = NULL, metrics = NULL,
                                        na_rm = FALSE) {
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .estimator <- NULL
+  .eval_result <- NULL
 
   if (!is.null(metrics) && !inherits(metrics, "metric_set")) {
     abort("Unknown metrics. metrics must be of class 'yardstick::metric_set' or NULL.")
@@ -366,7 +369,9 @@ summarize_feature_selection_curve <- function(fit_results, vary_params = NULL,
                                               eval_id = ifelse(curve == "PR",
                                                                "precision",
                                                                "TPR")) {
-  curve_estimate <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  curve_estimate <- NULL
+
   if (curve == "PR") {
     xvar <- "recall"
     yvar <- "precision"

R/evaluator-lib-inference.R

@@ -138,6 +138,12 @@ eval_testing_err <- function(fit_results, vary_params = NULL,
                              nested_cols = NULL, truth_col, pval_col = NULL,
                              group_cols = NULL, metrics = NULL, alphas = 0.05,
                              na_rm = FALSE) {
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .pval_imp <- NULL
+  .alpha <- NULL
+  .metric <- NULL
+  .estimate <- NULL
+  .eval_result <- NULL
 
   if (!is.null(metrics) && !inherits(metrics, "metric_set")) {
     abort("Unknown metrics. metrics must be of class 'yardstick::metric_set' or NULL.")
@@ -331,7 +337,9 @@ eval_testing_curve <- function(fit_results, vary_params = NULL,
                                nested_cols = NULL, truth_col, pval_col,
                                group_cols = NULL, curve = c("ROC", "PR"),
                                na_rm = FALSE) {
-  curve_estimate <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  curve_estimate <- NULL
+
   if (is.null(nested_cols) || (pval_col %in% names(fit_results))) {
     fit_results <- fit_results |>
       dplyr::rowwise() |>
@@ -370,7 +378,9 @@ summarize_testing_curve <- function(fit_results, vary_params = NULL,
                                     custom_summary_funs = NULL,
                                     eval_id = ifelse(curve == "PR",
                                                      "precision", "TPR")) {
-  curve_estimate <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  curve_estimate <- NULL
+
   if (curve == "PR") {
     xvar <- "recall"
     yvar <- "precision"
@@ -469,7 +479,9 @@ summarize_testing_curve <- function(fit_results, vary_params = NULL,
 eval_reject_prob <- function(fit_results, vary_params = NULL,
                              nested_cols = NULL, feature_col = NULL, pval_col,
                              group_cols = NULL, alphas = NULL, na_rm = FALSE) {
-  .alpha <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .alpha <- NULL
+
   group_vars <- c(".dgp_name", ".method_name", vary_params,
                   group_cols, feature_col)
   if (!is.null(nested_cols)) {

R/evaluator-lib-prediction.R

@@ -204,6 +204,9 @@ NULL
 eval_pred_err <- function(fit_results, vary_params = NULL, nested_cols = NULL,
                           truth_col, estimate_col, prob_cols = NULL,
                           group_cols = NULL, metrics = NULL, na_rm = FALSE) {
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .estimator <- NULL
+  .eval_result <- NULL
 
   if (!is.null(metrics) && !inherits(metrics, "metric_set")) {
     abort("Unknown metrics. metrics must be of class 'yardstick::metric_set' or NULL.")
@@ -400,6 +403,12 @@ eval_pred_curve <- function(fit_results, vary_params = NULL, nested_cols = NULL,
                             curve = c("ROC", "PR"), na_rm = FALSE) {
   curve <- match.arg(curve)
 
+  # dummies to fix R CMD check note on no visible binding for global variable
+  specificity <- NULL
+  sensitivity <- NULL
+  FPR <- NULL
+  .eval_result <- NULL
+
   eval_pred_curve_fun <- function(data, truth_col, prob_cols, curve, na_rm) {
     if (identical(curve, "ROC")) {
       curve_df <- yardstick::roc_curve(
@@ -439,7 +448,9 @@ summarize_pred_curve <- function(fit_results, vary_params = NULL,
                                  custom_summary_funs = NULL,
                                  eval_id = ifelse(curve == "PR",
                                                   "precision", "TPR")) {
-  curve_estimate <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  curve_estimate <- NULL
+
   if (curve == "PR") {
     xvar <- "recall"
     yvar <- "precision"

R/evaluator-lib-utils.R

@@ -81,6 +81,9 @@ eval_constructor <- function(fit_results, vary_params = NULL, fun,
                              nested_cols = NULL, ..., group_cols = NULL,
                              fun_options = NULL, na_rm = FALSE) {
 
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .eval_result <- NULL
+
   eval_rowwise <- function(data) {
     if (!is.null(nested_cols)) {
       data <- data |> tidyr::unnest(tidyselect::all_of(nested_cols))

R/experiment-utils.R

@@ -1,5 +1,9 @@
 #' @keywords internal
 get_new_dgp_params <- function(method_params, new_fit_params) {
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .dgp <- NULL
+  .method <- NULL
+
   # get new dgp parameter combinations given method parameter set
   dgp_params_list <- new_fit_params |>
     dplyr::filter(sapply(.method, identical, method_params)) |>
@@ -10,6 +14,10 @@ get_new_dgp_params <- function(method_params, new_fit_params) {
 
 #' @keywords internal
 get_new_method_params <- function(dgp_params, new_fit_params) {
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .dgp <- NULL
+  .method <- NULL
+
   # get new method parameter combinations given dgp parameter set
   method_params_list <- new_fit_params |>
     dplyr::filter(sapply(.dgp, identical, dgp_params)) |>
@@ -59,53 +67,6 @@ maybe_add_debug_data <- function(tbl, debug = FALSE) {
 }
 
 
-#' Clean up `future` worker-local environments on exit.
-#'
-#' @keywords internal
-clean_up_worker_env <- function(what = c("future", "dgp", "method"),
-                                env = parent.frame()) {
-  what <- match.arg(what)
-
-  ## # debugging
-  ## print(paste("pid:", Sys.getpid()))
-  ## print(paste("what:", what))
-  ## print(capture.output(rlang::env_print(env)))
-
-  tryCatch(
-    warning = identity,
-    switch(
-      what,
-      future = {
-        rm(dgp_res,
-           error_state,
-           future_env,
-           envir = env)
-      },
-      dgp = {
-        rm(method_res,
-           data_list,
-           dgp_params,
-           dgp_name,
-           dgp_params,
-           dgp_env,
-           envir = env)
-      },
-      method = {
-        rm(method_params,
-           method_name,
-           param_df,
-           result,
-           method_env,
-           envir = env)
-      }
-    )
-  )
-  rm(env)
-  gc()
-
-}
-
-
 #' Distribute simulation computation by replicates.
 #'
 #' @keywords internal
@@ -170,14 +131,36 @@ compute_rep <- function(n_reps,
     ## )
 
     future_env <- rlang::current_env()
-    withr::defer(clean_up_worker_env("future", env = future_env))
+    # withr::defer(clean_up_worker_env("future", env = future_env))
+    withr::defer({
+      tryCatch(
+        warning = identity,
+        rm(dgp_res,
+           error_state,
+           envir = future_env)
+      )
+      rm(future_env)
+      gc()
+    })
 
     dgp_res <- purrr::list_rbind(purrr::map(
       dgp_params_list,
       function(dgp_params) {
 
         dgp_env <- rlang::current_env()
-        withr::defer(clean_up_worker_env("dgp", env = dgp_env))
+        # withr::defer(clean_up_worker_env("dgp", env = dgp_env))
+        withr::defer({
+          tryCatch(
+            warning = identity,
+            rm(method_res,
+               data_list,
+               dgp_params,
+               dgp_name,
+               envir = dgp_env)
+          )
+          rm(dgp_env)
+          gc()
+        })
 
         if (error_state[["error"]]) {
           return(NULL)
@@ -233,10 +216,22 @@ compute_rep <- function(n_reps,
           function(method_params) {
 
             method_env <- rlang::current_env()
-            withr::defer(
-              clean_up_worker_env("method", env = method_env),
-              envir = method_env
-            )
+            # withr::defer(
+            #   clean_up_worker_env("method", env = method_env),
+            #   envir = method_env
+            # )
+            withr::defer({
+              tryCatch(
+                warning = identity,
+                rm(method_params,
+                   method_name,
+                   param_df,
+                   result,
+                   envir = method_env)
+              )
+              rm(method_env)
+              gc()
+            })
 
             method_name <- method_params$.method_name
 

R/globals.R

@@ -1 +1,8 @@
-utils::globalVariables(c("where", ":=", "!!"))
+utils::globalVariables(
+  c(
+    "where", ":=", "!!",
+    "verbose", "dgp_list", "method_list",
+    "new_fit_params", "dgp_params_list", "method_params_list",
+    "duplicate_param_names", "do_call_wrapper"
+  )
+)

R/signals.R

@@ -66,9 +66,9 @@ abort_on_invalid_user_action <- function(cause_string,
                                          hint_string = NULL,
                                          call = rlang::caller_env(),
                                          ...) {
-  msg <- sprintf("Cause: %s.\n", state_string)
-  if (!is.null(how_to_fix_string)) {
-    msg <- paste(msg, sprintf("Hint: %s."))
+  msg <- sprintf("Cause: %s.\n", cause_string)
+  if (!is.null(hint_string)) {
+    msg <- paste(msg, sprintf("Hint: %s.", hint_string))
   }
   abort(msg, call = call, ...)
 }

R/use_templates.R

@@ -449,8 +449,8 @@ use_dgp_template <- function(ids = NULL, data_split = TRUE) {
           data_split = FALSE, return_support = TRUE
         )
       }
-      dgp <- function(n, p, beta = 1, err_sd = 1, data_split = TRUE,
-                      train_prop = 0.5, return_support = TRUE) {
+      regression_dgp <- function(n, p, beta = 1, err_sd = 1, data_split = TRUE,
+                                 train_prop = 0.5, return_support = TRUE) {
 
         X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
         beta_vec <- matrix(beta, ncol = 1, nrow = p)
@@ -474,6 +474,8 @@ use_dgp_template <- function(ids = NULL, data_split = TRUE) {
         return(out)
       }
 
+      dgp <- regression_dgp
+
       # dgp_str <- create_fun_str(
       #   name = "dgp",
       #   fun = "create_dgp",
@@ -501,8 +503,8 @@ use_dgp_template <- function(ids = NULL, data_split = TRUE) {
           data_split = FALSE, return_support = TRUE
         )
       }
-      dgp <- function(n, p, beta = 1, data_split = TRUE,
-                      train_prop = 0.5, return_support = TRUE) {
+      classification_dgp <- function(n, p, beta = 1, data_split = TRUE,
+                                     train_prop = 0.5, return_support = TRUE) {
 
         X <- matrix(stats::rnorm(n * p), nrow = n, ncol = p)
         beta_vec <- matrix(beta, ncol = 1, nrow = p)
@@ -529,6 +531,8 @@ use_dgp_template <- function(ids = NULL, data_split = TRUE) {
         return(out)
       }
 
+      dgp <- classification_dgp
+
       # dgp_str <- create_fun_str(
       #   name = "dgp",
       #   fun = "create_dgp",
@@ -570,7 +574,7 @@ use_method_template <- function(ids = NULL) {
   } else {
     ids <- match.arg(ids, choices = c("RF", "OLS"))
     if (ids == "RF") {
-      method <- function(X, y, Xtest, ytest, support, ...) {
+      rf_method <- function(X, y, Xtest, ytest, support, ...) {
 
         data <- as.data.frame(X) |>
           cbind(.y = y)
@@ -625,8 +629,9 @@ use_method_template <- function(ids = NULL) {
         )
         return(out)
       }
+      method <- rf_method
     } else if (ids == "OLS") {
-      method <- function(X, y, support, ...) {
+      ols_method <- function(X, y, support, ...) {
 
         data <- as.data.frame(X) |>
           cbind(.y = y)
@@ -652,6 +657,7 @@ use_method_template <- function(ids = NULL) {
         )
         return(out)
       }
+      method <- ols_method
     }
     cat(paste0(tolower(ids), "_method <- ", rlang::expr_text(method)), "\n\n")
     method_str <- create_fun_str(

R/visualizer-lib-feature-selection.R

@@ -71,7 +71,9 @@ plot_feature_importance <- function(fit_results = NULL,
                                     vary_params = NULL,
                                     feature_col, show_max_features = NULL,
                                     show = c("errorbar", "bar"), ...) {
-  .imp_est <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .imp_est <- NULL
+
   arg_list <- get_dot_args(
     user_args = rlang::list2(...),
     default_args = list(eval_id = "feature_importance",

R/visualizer-lib-inference.R

@@ -266,7 +266,9 @@ plot_reject_prob <- function(fit_results = NULL,
                              feature_col = NULL, show_features = NULL,
                              show_identity_line = FALSE, show = c("line"),
                              ...) {
-  .alpha <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .alpha <- NULL
+
   show <- match.arg(show, choices = c("point", "line", "bar"))
   if (!is.null(feature_col)) {
     arg_list <- get_dot_args(

R/visualizer-lib-prediction.R

@@ -59,7 +59,9 @@ plot_pred_err <- function(fit_results = NULL,
                           eval_fun_options = NULL,
                           vary_params = NULL, metrics = NULL,
                           show = c("point", "line"), ...) {
-  .metric <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .metric <- NULL
+
   arg_list <- get_dot_args(
     user_args = rlang::list2(...),
     default_args = list(eval_id = "pred_err",

R/visualizer-lib-utils.R

@@ -554,7 +554,9 @@ plot_eval_constructor <- function(eval_results = NULL, eval_names = NULL,
 #' @export
 plot_fit_constructor <- function(fit_results, vary_params = NULL, reps = 1,
                                  plot_fun, interactive = FALSE, ...) {
-  .rep <- NULL  # to fix no visible binding for global variable error
+  # dummies to fix R CMD check note on no visible binding for global variable
+  .rep <- NULL
+
   dots_list <- rlang::list2(...)
   if (identical(dots_list, list())) {
     dots_list <- NULL