Add default param, use cli classes

Author: tjburch

R/control.R

@@ -73,43 +73,42 @@ control_grid <- function(
 }
 
 # Helper function to print control settings using cli
-print_control_settings <- function(x) {
+print_control_settings <- function(x, default = FALSE, defaults = NULL) {
   # Get the fields to print
   fields <- names(x)
 
+  # Optionally reduce to only non-defaults
+  if (default && !is.null(defaults)) {
+    fields <- fields[
+      !vapply(
+        fields,
+        function(field) {
+          identical(x[[field]], defaults[[field]])
+        },
+        logical(1)
+      )
+    ]
+  }
+
   # Build formatted lines for each field
   for (field in fields) {
     value <- x[[field]]
 
-    # Format the value based on type
-    if (is.null(value)) {
-      formatted_value <- "NULL"
-    } else if (is.function(value)) {
-      formatted_value <- "<function>"
-    } else if (is.logical(value)) {
-      formatted_value <- as.character(value)
-    } else if (is.numeric(value)) {
-      formatted_value <- format(value)
-    } else if (is.character(value)) {
-      if (length(value) == 1) {
-        formatted_value <- paste0("'", value, "'")
-      } else {
-        formatted_value <- paste0("[", paste(value, collapse = ", "), "]")
-      }
+    if (is.function(value)) {
+      cli::cli_bullets(c(" " = "{.arg {field}}: <function>"))
     } else if (inherits(value, "tune_backend_options")) {
-      formatted_value <- "<backend_options>"
+      cli::cli_bullets(c(" " = "{.arg {field}}: <backend_options>"))
     } else {
-      formatted_value <- paste0("<", class(value)[1], ">")
+      cli::cli_bullets(c(" " = "{.arg {field}}: {.val {value}}"))
     }
-
-    cli::cli_bullets(c(" " = paste0("{.field ", field, "}: ", formatted_value)))
   }
 }
 
 #' @export
-print.control_grid <- function(x, ...) {
+print.control_grid <- function(x, default = FALSE, ...) {
   cli::cli_text("{.emph Grid/resamples control object}")
-  print_control_settings(x)
+  defaults <- control_grid()
+  print_control_settings(x, default = default, defaults = defaults)
   invisible(x)
 }
 
@@ -150,9 +149,10 @@ control_last_fit <- function(
 }
 
 #' @export
-print.control_last_fit <- function(x, ...) {
+print.control_last_fit <- function(x, default = FALSE, ...) {
   cli::cli_text("{.emph Last fit control object}")
-  print_control_settings(x)
+  defaults <- control_last_fit()
+  print_control_settings(x, default = default, defaults = defaults)
   invisible(x)
 }
 
@@ -338,9 +338,10 @@ control_bayes <-
   }
 
 #' @export
-print.control_bayes <- function(x, ...) {
+print.control_bayes <- function(x, default = FALSE, ...) {
   cli::cli_text("{.emph Bayes control object}")
-  print_control_settings(x)
+  defaults <- control_bayes()
+  print_control_settings(x, default = default, defaults = defaults)
   invisible(x)
 }
 

tests/testthat/_snaps/checks.md

@@ -294,6 +294,165 @@
       Warning:
       Uncertainty sample scheduled after 5 poor iterations but the search will stop after 2.
 
+# control object print methods
+
+    Code
+      control_grid()
+    Message
+      Grid/resamples control object
+        `verbose`: FALSE
+        `allow_par`: TRUE
+        `extract`:
+        `save_pred`: FALSE
+        `pkgs`:
+        `save_workflow`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_grid(verbose = TRUE, save_pred = TRUE)
+    Message
+      Grid/resamples control object
+        `verbose`: TRUE
+        `allow_par`: TRUE
+        `extract`:
+        `save_pred`: TRUE
+        `pkgs`:
+        `save_workflow`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_grid(pkgs = c("pkg1", "pkg2"), extract = I)
+    Message
+      Grid/resamples control object
+        `verbose`: FALSE
+        `allow_par`: TRUE
+        `extract`: <function>
+        `save_pred`: FALSE
+        `pkgs`: "pkg1" and "pkg2"
+        `save_workflow`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_bayes()
+    Message
+      Bayes control object
+        `verbose`: FALSE
+        `verbose_iter`: FALSE
+        `allow_par`: TRUE
+        `no_improve`: 10
+        `uncertain`: Inf
+        `seed`: 51663
+        `extract`:
+        `save_pred`: FALSE
+        `time_limit`: NA
+        `pkgs`:
+        `save_workflow`: FALSE
+        `save_gp_scoring`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_bayes(verbose_iter = TRUE, no_improve = 5, save_gp_scoring = TRUE)
+    Message
+      Bayes control object
+        `verbose`: FALSE
+        `verbose_iter`: TRUE
+        `allow_par`: TRUE
+        `no_improve`: 5
+        `uncertain`: Inf
+        `seed`: 2986
+        `extract`:
+        `save_pred`: FALSE
+        `time_limit`: NA
+        `pkgs`:
+        `save_workflow`: FALSE
+        `save_gp_scoring`: TRUE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_last_fit()
+    Message
+      Last fit control object
+        `verbose`: FALSE
+        `allow_par`: FALSE
+        `extract`: <function>
+        `save_pred`: TRUE
+        `pkgs`:
+        `save_workflow`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+---
+
+    Code
+      control_last_fit(verbose = TRUE)
+    Message
+      Last fit control object
+        `verbose`: TRUE
+        `allow_par`: FALSE
+        `extract`: <function>
+        `save_pred`: TRUE
+        `pkgs`:
+        `save_workflow`: FALSE
+        `event_level`: "first"
+        `parallel_over`:
+        `backend_options`:
+        `workflow_size`: 100
+
+# control object print methods with default = TRUE
+
+    Code
+      print(control_grid(verbose = TRUE, pkgs = c("pkg1", "pkg2")), default = TRUE)
+    Message
+      Grid/resamples control object
+        `verbose`: TRUE
+        `pkgs`: "pkg1" and "pkg2"
+
+---
+
+    Code
+      print(control_bayes(verbose_iter = TRUE, no_improve = 5), default = TRUE)
+    Message
+      Bayes control object
+        `verbose_iter`: TRUE
+        `no_improve`: 5
+        `seed`: 13797
+
+---
+
+    Code
+      print(control_last_fit(verbose = TRUE), default = TRUE)
+    Message
+      Last fit control object
+        `verbose`: TRUE
+        `extract`: <function>
+
 # initial values
 
     Code

tests/testthat/test-checks.R

@@ -415,6 +415,19 @@ test_that("control object print methods", {
   expect_snapshot(control_last_fit(verbose = TRUE))
 })
 
+test_that("control object print methods with default = TRUE", {
+  expect_snapshot(print(
+    control_grid(verbose = TRUE, pkgs = c("pkg1", "pkg2")),
+    default = TRUE
+  ))
+  set.seed(456)
+  expect_snapshot(print(
+    control_bayes(verbose_iter = TRUE, no_improve = 5),
+    default = TRUE
+  ))
+  expect_snapshot(print(control_last_fit(verbose = TRUE), default = TRUE))
+})
+
 # ------------------------------------------------------------------------------
 
 test_that("initial values", {