Preview Evaluator results in R Markdown report

R/evaluator.R

@@ -203,6 +203,13 @@ Evaluator <- R6::R6Class(
     #'   `Evaluator`'s results as a table in the R Markdown report.
     doc_show = TRUE,
 
+    #' @field doc_nrows Maximum number of rows to show in the `Evaluator`'s
+    #'   results table in the R Markdown report. If the number of rows in the
+    #'   table exceeds this value, the table will be truncated and a message
+    #'   will be displayed indicating the number of rows that were omitted.
+    #'   Default is `NULL`, which shows all rows.
+    doc_nrows = NULL,
+
     # NOTE: R6 methods can't use the `@inheritParams` tag. If you want to update
     # the `@param` tags below, do so in the `create_evaluator()` docs above and
     # then copy-paste the corresponding `@param` tags below.
@@ -220,17 +227,23 @@ Evaluator <- R6::R6Class(
     #'   for this argument.
     #' @param .doc_show If `TRUE` (default), show `Evaluator`'s results as a table
     #'   in the R Markdown report; if `FALSE`, hide output in the R Markdown report.
+    #' @param .doc_nrows Maximum number of rows to show in the `Evaluator`'s results
+    #'   table in the R Markdown report. If the number of rows in the table exceeds
+    #'   this value, the table will be truncated and a message will be displayed
+    #'   indicating the number of rows that were omitted. Default is `NULL`, which
+    #'   shows all rows.
     #' @param ... User-defined arguments to pass into `.eval_fun()`.
     #'
     #' @return A new instance of `Evaluator`.
     initialize = function(.eval_fun, .name = NULL, .doc_options = list(),
-                          .doc_show = TRUE, ...) {
+                          .doc_show = TRUE, .doc_nrows = NULL, ...) {
       self$eval_fun <- .eval_fun
       self$name <- .name
       for (opt in names(.doc_options)) {
         self$doc_options[[opt]] <- .doc_options[[opt]]
       }
       self$doc_show <- .doc_show
+      self$doc_nrows <- .doc_nrows
       self$eval_params <- rlang::list2(...)
     },
 

R/experiment-helpers.R

@@ -1051,8 +1051,12 @@ get_cached_results <- function(experiment, results_type, verbose = 0) {
 #' @param name Name of `Evaluator` or `Visualizer` to set R Markdown
 #'   options.
 #' @param show If `TRUE`, show output; if `FALSE`, hide output in
-#'   R Markdown report. Default `NULL` does not change the "show" field
+#'   R Markdown report. Default `NULL` does not change the "doc_show" field
 #'   in `Evaluator`/`Visualizer`.
+#' @param nrows Maximum number of rows to show in the `Evaluator`'s results
+#'   table in the R Markdown report. If `NULL`, shows all rows. Default does
+#'   not change the "doc_nrows" field in the `Evaluator`. Argument is
+#'   ignored if `field_name = "visualizer"`.
 #' @param ... Named R Markdown options to set. If `field_name = "visualizer"`,
 #'   options are "height" and "width". If `field_name = "evaluator"`,
 #'   see options for [vthemes::pretty_DT()].
@@ -1126,10 +1130,10 @@ get_cached_results <- function(experiment, results_type, verbose = 0) {
 #'
 #' @export
 set_doc_options <- function(experiment, field_name = c("evaluator", "visualizer"),
-                            name, show = NULL, ...) {
+                            name, show = NULL, nrows, ...) {
   field_name <- match.arg(field_name)
   experiment$set_doc_options(field_name = field_name, name = name, show = show,
-                             ...)
+                             nrows = nrows, ...)
 }
 
 #' Set R Markdown options for `Evaluator` and `Visualizer` outputs in

R/experiment.R

@@ -1911,14 +1911,19 @@ Experiment <- R6::R6Class(
     #' @param name Name of `Evaluator` or `Visualizer` to set R Markdown
     #'   options.
     #' @param show If `TRUE`, show output; if `FALSE`, hide output in
-    #'   R Markdown report. Default `NULL` does not change the "show" field
+    #'   R Markdown report. Default `NULL` does not change the "doc_show" field
     #'   in `Evaluator`/`Visualizer`.
+    #' @param nrows Maximum number of rows to show in the `Evaluator`'s results
+    #'   table in the R Markdown report. If `NULL`, shows all rows. Default does
+    #'   not change the "doc_nrows" field in the `Evaluator`. Argument is
+    #'   ignored if `field_name = "visualizer"`.
     #' @param ... Named R Markdown options to set. If `field_name = "visualizer"`,
     #'   options are "height" and "width". If `field_name = "evaluator"`,
     #'   see options for [vthemes::pretty_DT()].
     #'
     #' @return The `Experiment` object, invisibly.
-    set_doc_options = function(field_name, name, show = NULL, ...) {
+    set_doc_options = function(field_name, name, show = NULL, nrows, ...) {
+      field_name <- match.arg(field_name, c("evaluator", "visualizer"))
       obj_list <- private$.get_obj_list(field_name)
       if (!name %in% names(obj_list)) {
         abort(
@@ -1933,6 +1938,11 @@ Experiment <- R6::R6Class(
       if (!is.null(show)) {
         private[[list_name]][[name]]$doc_show <- show
       }
+      if (field_name == "evaluator") {
+        if (!missing(nrows)) {
+          private[[list_name]][[name]]$doc_nrows <- nrows
+        }
+      }
       doc_options <- list(...)
       if (length(doc_options) > 0) {
         for (i in 1:length(doc_options)) {

inst/rmd/results.Rmd

@@ -453,6 +453,22 @@ show_results <- function(dir_name, depth, base = FALSE, show_header = TRUE,
           sprintf(figname_template, eval_name),
           old_text = results, write_flag = write_flag
         )
+        if (is.null(evaluator$doc_nrows)) {
+          eval_results_show <- eval_results[[eval_name]]
+        } else {
+          keep_rows <- 1:min(evaluator$doc_nrows, nrow(eval_results[[eval_name]]))
+          eval_results_show <- eval_results[[eval_name]][keep_rows, ]
+          if (nrow(eval_results[[eval_name]]) > evaluator$doc_nrows) {
+            omitted_nrows <- nrow(eval_results[[eval_name]]) - evaluator$doc_nrows
+            results <- write(
+              sprintf(
+                "Showing preview of %s results. %s rows have been omitted.\n\n",
+                eval_name, omitted_nrows
+              ),
+              old_text = results, write_flag = write_flag
+            )
+          }
+        }
         if (write_flag) {
           results <- sprintf(
             "show_results('%s', '%s', 'evaluator')", dir_name, eval_name
@@ -462,7 +478,7 @@ show_results <- function(dir_name, depth, base = FALSE, show_header = TRUE,
         } else {
           do.call(
             vthemes::pretty_DT,
-            c(list(eval_results[[eval_name]]), evaluator$doc_options)
+            c(list(eval_results_show), evaluator$doc_options)
           ) %>%
             vthemes::subchunkify(i = chunk_idx)
           chunk_idx <<- chunk_idx + 1

inst/rmd/results_header_template.Rmd

@@ -126,8 +126,15 @@ show_results <- function(dir_name, name,
   viz_results <- get_results(viz_fname)
 
   if (field_name == "evaluator") {
+    doc_nrows <- exp$get_evaluators()[[name]]$doc_nrows
+    if (is.null(doc_nrows)) {
+      eval_results_show <- eval_results[[name]]
+    } else {
+      keep_rows <- 1:min(doc_nrows, nrow(eval_results[[name]]))
+      eval_results_show <- eval_results[[name]][keep_rows, ]
+    }
     do.call(vthemes::pretty_DT,
-            c(list(eval_results[[name]]),
+            c(list(eval_results_show),
               exp$get_evaluators()[[name]]$doc_options))
   } else if (field_name == "visualizer") {
     viz_results[[name]]

tests/testthat/test-docs.R

@@ -243,6 +243,8 @@ withr::with_tempdir(pattern = "simChef-test-checkpointing-temp", code = {
       add_evaluator(evaluator4, "Evaluator (no show)") %>%
       set_doc_options(field_name = "evaluator", name = "Evaluator (digits = 4)",
                       digits = 4) %>%
+      set_doc_options(field_name = "evaluator", name = "Evaluator (digits = 4)",
+                      nrows = 10) %>%
       set_doc_options(field_name = "evaluator", name = "Evaluator (no show)",
                       show = FALSE) %>%
       add_visualizer(visualizer1, "Visualizer (height = 6)") %>%
@@ -267,6 +269,8 @@ withr::with_tempdir(pattern = "simChef-test-checkpointing-temp", code = {
     expect_equal(purrr::map_dbl(experiment$get_evaluators(),
                                 ~.x$doc_options$digits),
                  c(2, 3, 4, 2) %>% setNames(names(experiment$get_evaluators())))
+    expect_equal(purrr::map(experiment$get_evaluators(), "doc_nrows"),
+                 list(NULL, NULL, 10, NULL) %>% setNames(names(experiment$get_evaluators())))
     expect_equal(purrr::map_lgl(experiment$get_visualizers(), "doc_show"),
                  c(T, T, T, F) %>% setNames(names(experiment$get_visualizers())))
     expect_equal(purrr::map_dbl(experiment$get_visualizers(),

tests/testthat/test-evaluator.R

@@ -14,7 +14,7 @@ test_that("Evaluator initialization works properly", {
                                                   caption = "caption"))
   evaluator1f <- Evaluator$new(.eval_fun = eval_fun1,
                                a = 5, b = 1:5, c = data.frame(d = 1:2))
-  evaluator1g <- Evaluator$new(.eval_fun = eval_fun1, .doc_show = FALSE)
+  evaluator1g <- Evaluator$new(.eval_fun = eval_fun1, .doc_show = FALSE, .doc_nrows = 10)
   evaluator1h <- Evaluator$new(eval_fun1, n = 100)
   evaluator1i <- Evaluator$new(n = 100, func = func, eval_fun1)
   evaluator1j <- Evaluator$new(eval_fun1, n = 100, "Evaluator")
@@ -38,6 +38,7 @@ test_that("Evaluator initialization works properly", {
                list(digits = 2, sigfig = FALSE,
                     options = list(scrollX = TRUE, scrollCollapse = TRUE)))
   expect_equal(evaluator1$doc_show, TRUE)
+  expect_equal(evaluator1$doc_nrows, NULL)
 
   # basic initialization with name
   expect_equal(evaluator1b$name, "Evaluator")
@@ -66,6 +67,7 @@ test_that("Evaluator initialization works properly", {
 
   # show doc input
   expect_equal(evaluator1g$doc_show, FALSE)
+  expect_equal(evaluator1g$doc_nrows, 10)
 
   # preventing eval_fun arg partial matching
   expect_equal(evaluator1h$eval_params, list(n = 100))
@@ -120,7 +122,7 @@ test_that("Evaluator initialization works properly", {
                                                      caption = "caption"))
   evaluator2f <- create_evaluator(.eval_fun = eval_fun1,
                                   a = 5, b = 1:5, c = data.frame(d = 1:2))
-  evaluator2g <- create_evaluator(.eval_fun = eval_fun1, .doc_show = FALSE)
+  evaluator2g <- create_evaluator(.eval_fun = eval_fun1, .doc_show = FALSE, .doc_nrows = 10)
   evaluator2h <- create_evaluator(eval_fun1, n = 100)
   evaluator2i <- create_evaluator(n = 100, func = func, eval_fun1)
   evaluator2j <- create_evaluator(eval_fun1, n = 100, "Evaluator")

vignettes/simChef-full.Rmd

@@ -1057,6 +1057,7 @@ save_experiment(experiment)
 ```
 
 To hide the output of an `Evaluator` or `Visualizer` in the R Markdown report, use `set_doc_options(show = FALSE, ...)` or `create_*(.doc_show = FALSE, ...)`.
+Moreover, for an `Evaluator`, the maximum number of rows to display in the R Markdown report can be set via `set_doc_options(nrows = 10, ...)` or `create_*(.doc_nrows = 10, ...)`.
 Note that if document options are set after running the experiment, the experiment must be manually saved via `save_experiment(experiment)` in order for these changes to appear in the R Markdown output.
 
 ## Customizing aesthetics of R Markdown documentation