Proof of concept: (visually) simplify issue counter, add progress bar

R/logging.R

@@ -105,12 +105,12 @@ tune_env <- rlang::new_environment(
     progress_env = NULL,
     progress_active = FALSE,
     progress_catalog = NULL,
-    progress_started = FALSE
+    progress_status_ids = list(),
+    progress_modulus = 1L,
+    progress_in_unit = 0L
   )
 )
 
-lbls <- c(LETTERS, letters, 1:1e3)
-
 # determines whether a currently running tuning process uses the cataloger.
 uses_catalog <- function() {
   isTRUE(tune_env$progress_active && !is_testing())
@@ -185,40 +185,174 @@ initialize_catalog <- function(
     rlang::env_bind(tune_env, progress_active = FALSE),
     envir = env
   )
+
+  rlang::env_bind(tune_env, progress_status_ids = list())
   withr::defer(
-    rlang::env_bind(tune_env, progress_started = FALSE),
+    catalog_cleanup(),
     envir = env
   )
 
   invisible(NULL)
 }
 
-# given a catalog, summarize errors and warnings in a 1-length glue vector.
-# for use by the progress bar inside of `tune_catalog()`.
-summarize_catalog <- function(catalog, sep = "   ") {
-  if (nrow(catalog) == 0) {
-    return("")
+catalog_cleanup <- function() {
+  ids <- tune_env$progress_status_ids
+  catalog <- tune_env$progress_catalog
+
+  if (length(ids) > 0 && !is.null(catalog) && nrow(catalog) > 0) {
+    if (cli::is_dynamic_tty()) {
+      # Update headers with final counts, then keep as permanent output
+      for (i in seq_len(nrow(catalog))) {
+        entry_id <- catalog$id[i]
+        entry <- ids[[entry_id]]
+        if (!is.null(entry)) {
+          header <- catalog_header(catalog$type[i], catalog$n[i])
+          cli::cli_status_update(id = entry$header, msg = header)
+          cli::cli_status_clear(entry$header, result = "clear")
+          for (cont_id in entry$continuation) {
+            cli::cli_status_clear(cont_id, result = "clear")
+          }
+        }
+      }
+    } else {
+      # Non-dynamic: print compact summary, then clear silently
+      has_duplicates <- any(catalog$n > 1)
+      if (has_duplicates) {
+        parts <- vapply(
+          seq_len(nrow(catalog)),
+          function(i) {
+            color <- if (catalog$type[i] == "warning") {
+              cli::col_yellow
+            } else {
+              cli::col_red
+            }
+            color(paste0(catalog$type[i], " (x", catalog$n[i], ")"))
+          },
+          character(1)
+        )
+        cli::cli_inform(paste0(
+          "Issue totals: ",
+          paste(parts, collapse = ", ")
+        ))
+      }
+      suppressMessages(
+        for (entry in ids) {
+          for (cont_id in rev(entry$continuation)) {
+            try(cli::cli_status_clear(cont_id, result = "clear"), silent = TRUE)
+          }
+          try(
+            cli::cli_status_clear(entry$header, result = "clear"),
+            silent = TRUE
+          )
+        }
+      )
+    }
+  }
+
+  rlang::env_bind(tune_env, progress_status_ids = list())
+}
+
+# The catalog heartbeat: a single progress bar that sits at the top of the
+# progress area and advances once per model fit, so that a tuning run shows it's
+# making progress even when no issues are caught. Gated on `uses_catalog()`, so
+# it only appears in sequential, non-verbose, non-testing runs.
+#
+# `total` is the number of model fits across the whole run and `modulus` is the
+# number per resample (the per-resample tick budget). We force an initial render
+# at creation so the bar claims the top status-bar slot before any issue bar is
+# created during the first resample; otherwise issues caught mid-resample would
+# render above it. `progress_in_unit` counts ticks within the current resample so
+# `catalog_progress_trueup()` can pad the bar up to the next multiple of
+# `modulus` when upstream failures cause a resample to fit fewer models than the
+# schedule allows for.
+catalog_progress_init <- function(total, modulus = 1L) {
+  if (!uses_catalog()) {
+    return(invisible(NULL))
   }
 
-  res <- dplyr::arrange(catalog, id)
-  res <- dplyr::mutate(
-    res,
-    color = dplyr::if_else(
-      type == "warning",
-      list(cli::col_yellow),
-      list(cli::col_red)
-    )
+  rlang::env_bind(tune_env, progress_modulus = modulus, progress_in_unit = 0L)
+
+  rlang::with_options(
+    cli::cli_progress_bar(
+      total = total,
+      format = paste(
+        "{cli::pb_spin} tuning {cli::pb_bar}",
+        "{cli::pb_current}/{cli::pb_total} {cli::pb_eta_str}"
+      ),
+      format_done = "{cli::col_green(cli::symbol$tick)} tuning complete [{cli::pb_elapsed}]",
+      clear = FALSE,
+      .envir = tune_env$progress_env
+    ),
+    cli.progress_show_after = 0
   )
-  res <- dplyr::rowwise(res)
-  res <- dplyr::mutate(
-    res,
-    msg = glue::glue("{color(cli::style_bold(lbls[id]))}: x{n}")
+
+  cli::cli_progress_update(
+    set = 0,
+    force = TRUE,
+    .envir = tune_env$progress_env
   )
-  res <- dplyr::ungroup(res)
-  res <- dplyr::pull(res, msg)
-  res <- glue::glue_collapse(res, sep = sep)
 
-  res
+  invisible(NULL)
+}
+
+catalog_progress_tick <- function() {
+  if (!uses_catalog()) {
+    return(invisible(NULL))
+  }
+
+  # `force` so the displayed count keeps pace with the issue bars, which repaint
+  # on every occurrence; without it the throttled heartbeat lags behind and can
+  # show fewer fits than there are issues (#tune-heartbeat).
+  cli::cli_progress_update(force = TRUE, .envir = tune_env$progress_env)
+  tune_env$progress_in_unit <- tune_env$progress_in_unit + 1L
+
+  invisible(NULL)
+}
+
+catalog_progress_trueup <- function() {
+  if (!uses_catalog()) {
+    return(invisible(NULL))
+  }
+
+  pad <- tune_env$progress_modulus - tune_env$progress_in_unit
+  if (pad > 0) {
+    cli::cli_progress_update(
+      inc = pad,
+      force = TRUE,
+      .envir = tune_env$progress_env
+    )
+  }
+  tune_env$progress_in_unit <- 0L
+
+  invisible(NULL)
+}
+
+# The number of model fits the grid loop performs per resample, used as the
+# heartbeat's per-resample tick budget. The schedule depends only on the grid
+# and workflow (not the split), so it's the same for every resample. Submodel
+# parameters share a single fit, so a grid that only tunes submodel parameters
+# counts as one fit per resample.
+catalog_count_model_iters <- function(grid, workflow) {
+  if (is.null(grid) || nrow(grid) == 0) {
+    return(1L)
+  }
+
+  sched <- schedule_grid(grid, workflow)
+  as.integer(sum(vapply(
+    sched$model_stage,
+    function(m) max(nrow(m), 1L),
+    integer(1)
+  )))
+}
+
+catalog_progress_done <- function() {
+  if (!uses_catalog()) {
+    return(invisible(NULL))
+  }
+
+  cli::cli_progress_done(.envir = tune_env$progress_env)
+
+  invisible(NULL)
 }
 
 # catching and logging ---------------------------------------------------------
@@ -237,8 +371,10 @@ summarize_catalog <- function(catalog, sep = "   ") {
   tmp <- catcher(.expr)
 
   if (has_log_notes(tmp)) {
+    # log only the notes from this catch; `catalog_log()` increments counts, so
+    # passing the resample's accumulated `notes` would re-count earlier entries
+    catalog_log(append_log_notes(NULL, tmp, dots$location))
     notes <- append_log_notes(notes, tmp, dots$location)
-    catalog_log(notes)
   }
   tmp <- remove_log_notes(tmp)
   assign("notes", notes, envir = parent.frame())
@@ -356,6 +492,15 @@ catalog_log <- function(x) {
     if (x_note %in% catalog$note) {
       idx <- match(x_note, catalog$note)
       catalog$n[idx] <- catalog$n[idx] + 1
+
+      if (uses_catalog() && cli::is_dynamic_tty()) {
+        entry_id <- catalog$id[idx]
+        ids <- tune_env$progress_status_ids[[entry_id]]
+        if (!is.null(ids)) {
+          header <- catalog_header(x_type, catalog$n[idx])
+          cli::cli_status_update(id = ids$header, msg = header)
+        }
+      }
     } else {
       new_id <- nrow(catalog) + 1
       catalog <- tibble::add_row(
@@ -368,47 +513,66 @@ catalog_log <- function(x) {
         )
       )
 
-      # construct issue summary
-      color <- if (x_type == "warning") cli::col_yellow else cli::col_red
-      # pad by nchar(label) + nchar("warning") + additional spaces and symbols
-      pad <- nchar(new_id) + 14L
-      justify <- paste0("\n", strrep("\u00a0", pad))
-      note <- gsub("\n", justify, x_note)
-      # pad `nchar("warning") - nchar("error")` spaces to the right of the `:`
-      if (x_type == "error") {
-        note <- paste0("\u00a0\u00a0", note)
+      if (uses_catalog()) {
+        header <- catalog_header(x_type, 1L)
+        body_lines <- catalog_body_lines(x_note)
+
+        header_id <- cli::cli_status(
+          header,
+          msg_done = header,
+          .keep = TRUE,
+          .auto_close = FALSE
+        )
+        cont_ids <- vapply(
+          body_lines,
+          function(line) {
+            cli::cli_status(
+              line,
+              msg_done = line,
+              .keep = TRUE,
+              .auto_close = FALSE
+            )
+          },
+          character(1)
+        )
+
+        tune_env$progress_status_ids[[new_id]] <- list(
+          header = header_id,
+          continuation = cont_ids
+        )
+      } else {
+        color <- if (x_type == "warning") cli::col_yellow else cli::col_red
+        symbol <- if (x_type == "warning") "!" else cli::symbol$cross
+        header_text <- paste0(color(symbol), " ", color(x_type), " (x1):")
+        body_lines <- catalog_body_lines(x_note)
+        cli::cli_alert(paste0(
+          header_text,
+          "\n",
+          paste0(body_lines, collapse = "\n")
+        ))
       }
-      msg <- glue::glue(
-        "{color(cli::style_bold(lbls[new_id]))} | {color(x_type)}: {note}"
-      )
-      cli::cli_alert(msg)
     }
   }
 
   rlang::env_bind(tune_env, progress_catalog = catalog)
-  if (uses_catalog()) {
-    rlang::env_bind(
-      tune_env$progress_env,
-      catalog_summary = summarize_catalog(catalog)
-    )
 
-    if (!tune_env$progress_started) {
-      rlang::with_options(
-        cli::cli_progress_bar(
-          type = "custom",
-          format = "There were issues with some computations   {catalog_summary}",
-          clear = FALSE,
-          .envir = tune_env$progress_env
-        ),
-        cli.progress_show_after = 0
-      )
-      rlang::env_bind(tune_env, progress_started = TRUE)
-    }
+  return(NULL)
+}
 
-    cli::cli_progress_update(.envir = tune_env$progress_env)
-  }
+catalog_header <- function(type, n) {
+  color <- if (type == "warning") cli::col_yellow else cli::col_red
+  symbol <- if (type == "warning") "!" else cli::symbol$cross
+  paste0(color(symbol), " ", color(paste0(type, " (x", n, "):")))
+}
 
-  return(NULL)
+catalog_body_lines <- function(note) {
+  indent <- 2L
+  width <- cli::console_width() - indent
+  lines <- strsplit(note, "\n")[[1]]
+  wrapped <- unlist(lapply(lines, function(line) {
+    strwrap(line, width = width)
+  }))
+  paste0(strrep(" ", indent), wrapped)
 }
 
 remove_log_notes <- function(x) {

R/loop_over_all_stages.R

@@ -127,6 +127,8 @@
     grid_with_pre <- current_grid
 
     for (iter_model in seq_len(num_iterations_model)) {
+      catalog_progress_tick()
+
       current_sched_model <- current_sched_pre$model_stage[[1]][iter_model, ]
       current_grid <- extend_grid(grid_with_pre, current_sched_model)
 
@@ -525,6 +527,8 @@
     }
   }
 
+  catalog_progress_trueup()
+
   return_tbl
 }
 

R/tune_grid_loop.R

@@ -108,9 +108,26 @@ tune_grid_loop <- function(
     inds <- vec_list_rowwise(inds)
   }
 
+  if (control$parallel_over == "everything") {
+    # each unit is already a single resample x candidate, so one fit per unit
+    catalog_progress_init(length(inds), modulus = 1L)
+  } else {
+    fits_per_resample <- if (uses_catalog()) {
+      catalog_count_model_iters(grid, workflow)
+    } else {
+      1L
+    }
+    catalog_progress_init(
+      length(resamples) * fits_per_resample,
+      modulus = fits_per_resample
+    )
+  }
+
   cl <- loop_call(control$parallel_over, strategy, par_opt)
   res <- rlang::eval_bare(cl)
 
+  catalog_progress_done()
+
   # ----------------------------------------------------------------------------
   # Separate results into different components