Add opt-in lazy row details for Shiny

NEWS.md

@@ -2,6 +2,8 @@
 
 ## New features
 
+* Added opt-in `lazyDetails = TRUE` for R row details in Shiny (>= 1.5.0), including nested tables, fresh calculation on reopening, and cleanup on collapse. Open details retain a snapshot until closed. Data replacement requires rerendering; server-side processing and static rendering are not yet supported.
+
 * Experimental support for server-side data processing in Shiny apps. Use
   `reactable(server = TRUE)` to render a table using server-side data processing in Shiny.
   Server-side data processing requires the V8 package, which is not installed

R/lazy-details.R

@@ -0,0 +1,167 @@
+# One request observer per Shiny session, shared by top-level and nested tables.
+# Callbacks and rendered outputs never enter the widget's JSON payload.
+lazyDetailsRegistry <- function(session) {
+  session <- session$rootScope()
+  registry <- session$userData$reactableLazyDetails
+  if (!is.null(registry)) return(registry)
+  registry <- new.env(parent = emptyenv())
+  registry$tables <- new.env(parent = emptyenv())
+  registry$outputs <- new.env(parent = emptyenv())
+  registry$counter <- 0L
+  registry$current <- NULL
+  registry$inputId <- session$ns("__reactable_lazy__")
+  session$userData$reactableLazyDetails <- registry
+  registry$observer <- shiny::observeEvent(session$input[["__reactable_lazy__"]], {
+    requests <- session$input[["__reactable_lazy__"]]
+    if (is.character(requests) && length(requests) == 1L && !is.na(requests)) {
+      requests <- tryCatch(jsonlite::fromJSON(requests, simplifyVector = FALSE),
+        error = function(e) NULL)
+    }
+    if (!is.list(requests)) return()
+    for (request in requests) lazyDetailsRequest(registry, request)
+  }, domain = session)
+  session$onSessionEnded(function() {
+    for (id in ls(registry$tables)) destroyLazyTable(registry, id)
+    registry$observer$destroy()
+  })
+  registry
+}
+
+registerLazyDetails <- function(callbacks, rowCount, session) {
+  registry <- lazyDetailsRegistry(session)
+  registry$counter <- registry$counter + 1L
+  id <- paste0("table", registry$counter)
+  parent <- registry$current
+  outputId <- NULL
+  if (is.null(parent)) {
+    info <- shiny::getCurrentOutputInfo(session = session)
+    if (!is.null(info$name)) {
+      # Shiny output info already contains the fully namespaced output name.
+      outputId <- info$name
+      registry$outputs[[outputId]] <- c(registry$outputs[[outputId]], id)
+    }
+  }
+  entry <- new.env(parent = emptyenv())
+  entry$callbacks <- callbacks
+  entry$rowCount <- rowCount
+  entry$session <- session
+  entry$panels <- new.env(parent = emptyenv())
+  entry$outputId <- outputId
+  entry$parent <- parent
+  registry$tables[[id]] <- entry
+  if (!is.null(parent)) {
+    panel <- registry$tables[[parent$table]]$panels[[parent$request]]
+    panel$children <- c(panel$children, id)
+  }
+  list(id = id, inputId = registry$inputId)
+}
+
+destroyLazyPanel <- function(registry, table, request) {
+  entry <- registry$tables[[table]]
+  if (is.null(entry)) return(invisible(NULL))
+  panel <- entry$panels[[request]]
+  if (is.null(panel)) return(invisible(NULL))
+  for (child in panel$children) destroyLazyTable(registry, child)
+  entry$session$output[[panel$outputId]] <- NULL
+  rm(list = request, envir = entry$panels)
+  invisible(NULL)
+}
+
+destroyLazyTable <- function(registry, id) {
+  entry <- registry$tables[[id]]
+  if (is.null(entry)) return(invisible(NULL))
+  for (request in ls(entry$panels)) destroyLazyPanel(registry, id, request)
+  if (!is.null(entry$outputId)) {
+    remaining <- setdiff(registry$outputs[[entry$outputId]], id)
+    if (length(remaining)) {
+      registry$outputs[[entry$outputId]] <- remaining
+    } else if (exists(entry$outputId, envir = registry$outputs, inherits = FALSE)) {
+      rm(list = entry$outputId, envir = registry$outputs)
+    }
+  }
+  rm(list = id, envir = registry$tables)
+  invisible(NULL)
+}
+
+# A render may construct several candidate widgets. Invalidate the previous
+# render once, before construction, including when the new result is eager.
+clearLazyOutput <- function() {
+  session <- shiny::getDefaultReactiveDomain()
+  if (is.null(session)) return(invisible(NULL))
+  registry <- session$userData$reactableLazyDetails
+  if (is.null(registry)) return(invisible(NULL))
+  outputId <- shiny::getCurrentOutputInfo(session = session)$name
+  if (!is.null(outputId)) {
+    for (id in registry$outputs[[outputId]]) destroyLazyTable(registry, id)
+  }
+  invisible(NULL)
+}
+
+lazyDetailsString <- function(x) {
+  is.character(x) && length(x) == 1L && !is.na(x) && nzchar(x)
+}
+
+lazyDetailsRequest <- function(registry, request) {
+  if (!is.list(request) || !lazyDetailsString(request$table)) return(invisible(NULL))
+  entry <- registry$tables[[request$table]]
+  # A rerender or parent collapse invalidates all requests for that table.
+  if (is.null(entry)) return(invisible(NULL))
+  if (identical(request$action, "dispose")) {
+    destroyLazyTable(registry, request$table)
+    return(invisible(NULL))
+  }
+  if (!lazyDetailsString(request$request) || !grepl("^r[0-9]+$", request$request)) {
+    return(invisible(NULL))
+  }
+  if (identical(request$action, "close")) {
+    destroyLazyPanel(registry, request$table, request$request)
+    return(invisible(NULL))
+  }
+  if (!identical(request$action, "open")) return(invisible(NULL))
+  index <- request$index
+  if (!is.numeric(index) || length(index) != 1L || is.na(index) ||
+      !is.finite(index) || index != floor(index) || index < 1 || index > entry$rowCount ||
+      !lazyDetailsString(request$column) || is.null(entry$callbacks[[request$column]])) {
+    return(invisible(NULL))
+  }
+  if (!is.null(entry$panels[[request$request]])) return(invisible(NULL))
+
+  panel <- new.env(parent = emptyenv())
+  panel$children <- character()
+  panel$outputId <- paste0("__reactable_lazy_", request$table, "_", request$request)
+  entry$panels[[request$request]] <- panel
+  oldContext <- registry$current
+  registry$current <- list(table = request$table, request = request$request)
+  on.exit({ registry$current <- oldContext }, add = TRUE)
+
+  session <- entry$session
+  shiny::withReactiveDomain(session, {
+    content <- tryCatch(shiny::isolate({
+      callFunc(entry$callbacks[[request$column]], as.integer(index), request$column)
+    }), error = function(e) {
+      # Discard children constructed before a failed callback.
+      for (child in panel$children) destroyLazyTable(registry, child)
+      panel$children <- character()
+      if (inherits(e, "shiny.silent.error")) {
+        msg <- conditionMessage(e)
+        if (!nzchar(msg)) return(NULL)
+        return(htmltools::div(class = "shiny-output-error-validation", msg))
+      }
+      message("reactable lazy details: ", conditionMessage(e))
+      htmltools::div(class = "shiny-output-error", role = "alert",
+        if (isTRUE(getOption("shiny.sanitize.errors", FALSE))) {
+          "An error occurred while calculating these details."
+        } else conditionMessage(e)
+      )
+    })
+    # renderUI supplies Shiny's normal HTML dependency and htmlwidget handling.
+    # It captures a snapshot, so reactive reads above do not create a permanent
+    # reactive computation. Closing the panel removes this output explicitly.
+    session$output[[panel$outputId]] <- shiny::renderUI({ content })
+    session$sendCustomMessage("__reactable_lazy__", list(
+      table = request$table, request = request$request,
+      outputId = session$ns(panel$outputId)
+    ))
+  })
+  invisible(NULL)
+}

R/reactable.R

@@ -68,6 +68,18 @@
 #'   that takes the row index and column name as arguments, or a [JS()] function
 #'   that takes a row info object as an argument. Can also be a [colDef()] to
 #'   customize the details expander column.
+#' @param lazyDetails Calculate R row details only when opened, in a live Shiny session?
+#'   Defaults to `FALSE`. Works with ordinary `reactableOutput()` and `renderReactable()`,
+#'   including nested `reactable(..., lazyDetails = TRUE)` calls. The existing details
+#'   callback arguments (row index and column name) are unchanged. Open details are
+#'   snapshots; closing discards them and reopening recalculates them. Sorting, paging,
+#'   and virtual scrolling do not recalculate a detail that remains expanded.
+#'   Update data by rerendering the table, not `updateReactable(data = ...)` or the
+#'   JavaScript `setData()` API. Currently incompatible with `server` and `static`.
+#'   All rows have expanders, including callbacks that eventually return `NULL`.
+#'   Requires Shiny 1.5.0 or later. For nested lazy details, each parent must also
+#'   use `lazyDetails = TRUE`; lazy tables cannot be embedded in eager details or cells.
+#'   Do not cache rendered lazy widgets with Shiny's `bindCache()`.
 #' @param defaultExpanded Expand all rows by default?
 #' @param selection Enable row selection? Either `"multiple"` or `"single"` for
 #'   multiple or single row selection.
@@ -239,8 +251,22 @@ reactable <- function(
   elementId = NULL,
   static = getOption("reactable.static", FALSE),
   server = FALSE,
-  selectionId = NULL
+  selectionId = NULL,
+  lazyDetails = FALSE
 ) {
+  if (!is.logical(lazyDetails) || length(lazyDetails) != 1L || is.na(lazyDetails)) {
+    stop("`lazyDetails` must be TRUE or FALSE")
+  }
+  lazySession <- NULL
+  if (lazyDetails) {
+    lazySession <- if (requireNamespace("shiny", quietly = TRUE)) shiny::getDefaultReactiveDomain()
+    if (is.null(lazySession)) stop("`lazyDetails = TRUE` requires an active Shiny session")
+    if (utils::packageVersion("shiny") < "1.5.0") {
+      stop("`lazyDetails = TRUE` requires Shiny 1.5.0 or later")
+    }
+    if (!isFALSE(server)) stop("`lazyDetails` cannot currently be combined with `server`")
+    if (isTRUE(static)) stop("`lazyDetails` cannot be combined with `static = TRUE`")
+  }
   crosstalkKey <- NULL
   crosstalkGroup <- NULL
   dependencies <- list()
@@ -571,6 +597,7 @@ reactable <- function(
     dependencies <<- htmltools::resolveDependencies(dependencies)
   }
 
+  lazyCallbacks <- list()
   cols <- lapply(columnKeys, function(key) {
     column <- list(
       id = key,
@@ -617,11 +644,16 @@ reactable <- function(
 
     details <- column[["details"]]
     if (is.function(details)) {
-      details <- lapply(seq_len(nrow(data)), function(index) {
-        callFunc(details, index, key)
-      })
-      column$details <- lapply(details, asReactTag)
-      addDependencies(column$details)
+      if (lazyDetails) {
+        lazyCallbacks[[key]] <<- details
+        column$details <- list(lazy = TRUE)
+      } else {
+        details <- lapply(seq_len(nrow(data)), function(index) {
+          callFunc(details, index, key)
+        })
+        column$details <- lapply(details, asReactTag)
+        addDependencies(column$details)
+      }
     }
 
     filterInput <- column[["filterInput"]]
@@ -673,6 +705,10 @@ reactable <- function(
     })
   }
 
+  lazyConfig <- if (length(lazyCallbacks)) {
+    registerLazyDetails(lazyCallbacks, nrow(data), lazySession)
+  }
+
   preRenderHook <- NULL
   serverRowCount <- NULL
   serverMaxRowCount <- NULL
@@ -791,6 +827,7 @@ reactable <- function(
     crosstalkGroup = crosstalkGroup,
     elementId = elementId,
     dataKey = dataKey,
+    lazyDetails = lazyConfig,
     static = static,
     serverRowCount = serverRowCount,
     serverMaxRowCount = serverMaxRowCount
@@ -909,7 +946,15 @@ reactableOutput <- function(outputId, width = "auto", height = "auto", inline =
 #' @export
 renderReactable <- function(expr, env = parent.frame(), quoted = FALSE) {
   if (!quoted) { expr <- substitute(expr) }
-  htmlwidgets::shinyRenderWidget(expr, reactableOutput, env, quoted = TRUE)
+  render <- htmlwidgets::shinyRenderWidget(expr, reactableOutput, env, quoted = TRUE)
+  func <- function(...) {
+    clearLazyOutput()
+    withCallingHandlers(render(...), error = function(e) clearLazyOutput())
+  }
+  # Preserve htmlwidgets/Shiny metadata, including the original cache hint for
+  # eager outputs. Different expressions must not share a cached result.
+  attributes(func) <- attributes(render)
+  func
 }
 
 #' Convert a reactable widget to HTML tags

R/shiny.R

@@ -112,6 +112,10 @@ updateReactable <- function(outputId, data = NULL, sortBy = NULL, page = NULL,
 
   dataKey <- NULL
   if (!is.null(data)) {
+    registry <- session$userData$reactableLazyDetails
+    if (!is.null(registry) && !is.null(registry$outputs[[outputId]])) {
+      stop("For lazy details, update data by rerendering with renderReactable(), not updateReactable(data = ...)")
+    }
     if (!is.data.frame(data) && !is.matrix(data)) {
       stop("`data` must be a data frame or matrix")
     }

R/utils.R

@@ -124,6 +124,9 @@ isTagList <- function(x) {
 }
 
 asReactTag <- function(x) {
+  if (inherits(x, "reactable") && !is.null(x$x$tag$attribs$lazyDetails)) {
+    stop("Nested lazy tables must be returned from a lazy details callback; set `lazyDetails = TRUE` on the parent")
+  }
   if (is.htmlwidget(x)) {
     if (inherits(x, "reactable")) {
       # Extract tag for nested tables

design/lazy-details/app.R

@@ -0,0 +1,55 @@
+library(shiny)
+library(reactable)
+
+if (!"lazyDetails" %in% names(formals(reactable))) {
+  stop("Install reactable from this checkout before running the app.")
+}
+
+ui <- fluidPage(
+  titlePanel("Nested lazy details"),
+  p("Expand a car, a system, then a check. Each opening adds one calculation to the log."),
+  actionButton("refresh", "Recreate tables"),
+  reactableOutput("cars"),
+  h3("Calculation log"),
+  verbatimTextOutput("events")
+)
+
+server <- function(input, output, session) {
+  events <- reactiveVal(character())
+  record <- function(path) {
+    events(c(isolate(events()), paste(path, format(Sys.time(), "%H:%M:%OS3"), sep = " | ")))
+  }
+  output$cars <- renderReactable({
+    input$refresh
+    cars <- data.frame(car = rownames(mtcars)[1:8], mtcars[1:8, ], row.names = NULL)
+    reactable(cars, lazyDetails = TRUE, searchable = TRUE, defaultPageSize = 4,
+      details = function(index) {
+        car <- cars$car[index]
+        record(car)
+        systems <- data.frame(system = c("Engine", "Brakes", "Tyres"))
+        tagList(h4(car), reactable(systems, lazyDetails = TRUE, pagination = FALSE,
+          details = function(index) {
+            system <- systems$system[index]
+            record(paste(car, system, sep = " / "))
+            checks <- data.frame(check = c("Condition", "Pressure", "Service history"))
+            tagList(h5(paste(car, system, sep = " / ")),
+              reactable(checks, lazyDetails = TRUE, pagination = FALSE,
+                details = function(index) {
+                  path <- paste(car, system, checks$check[index], sep = " / ")
+                  record(path)
+                  div(class = "check-result", paste("Checked:", path))
+                }
+              )
+            )
+          }
+        ))
+      }
+    )
+  })
+  output$events <- renderText({
+    log <- events()
+    paste(c(paste("Calculations:", length(log)), log), collapse = "\n")
+  })
+}
+
+shinyApp(ui, server)

design/lazy-details/lazy-details-test.Rmd

@@ -0,0 +1,26 @@
+---
+title: "Native lazy details acceptance tests"
+output: html_document
+runtime: shiny
+---
+
+::: {.callout}
+New in v0.4.5.9000
+:::
+
+```{r}
+library(reactable)
+library(shiny)
+calls <- reactiveVal(0L)
+renderText(paste("Detail calculations:", calls()))
+renderReactable({
+  reactable(mtcars, lazyDetails = TRUE, searchable = TRUE, details = function(index) {
+    calls(isolate(calls()) + 1L)
+    div(paste(rownames(mtcars)[index], "calculated", Sys.time()))
+  })
+})
+```
+
+Expect zero calculations initially. Open one car, then sort or page away and back: its retained detail should not
+recalculate. Close and reopen it: the count and timestamp should change. For nested tables, modules, data replacement,
+intentional errors and a downloadable report, run `test-lazy-reactable.R` in this directory.