Skip the empty input messages Shiny sends after deferred inputs

DESCRIPTION

@@ -27,6 +27,7 @@ Suggests:
     dbplyr,
     RSQLite,
     testthat (>= 3.0.0),
+    V8,
     withr
 Remotes:
     BristolMyersSquibb/blockr.core

NAMESPACE

@@ -16,6 +16,7 @@ export(menu_divider)
 export(menu_item)
 export(menu_section)
 export(shiny_has_perf_dep)
+export(shiny_input_batch_dep)
 export(shortcut)
 export(small_icon)
 export(table_page)

NEWS.md

@@ -1,5 +1,13 @@
 # blockr.ui (development version)
 
+* The new `shiny_input_batch_dep()` dependency skips the empty input messages
+  Shiny 1.14.0 sends after every deferred input: its batcher never records
+  that a send is queued, so each deferred `setInput` queues one, and all but
+  the first go out empty. The server runs a full input cycle for each. On a
+  first visit to a 15-block dock view that was 177 of 218 messages, and the
+  dock's own messages waited 2 to 4 seconds behind them. Attach it once at
+  the page level. Reported upstream as rstudio/shiny#4436.
+
 * The new `small_icon()` draws the design system's small icons in markup
   built in R (#64), from the list `Blockr.icons` is now built from:
   `controls_dep()` writes the list into the page ahead of `blockr-ui.js`,

R/theme.R

@@ -118,3 +118,39 @@ shiny_has_perf_dep <- function() {
     all_files = FALSE
   )
 }
+
+#' Skip the empty input messages Shiny sends after deferred inputs
+#'
+#' Shiny's input batcher (1.14.0) checks whether a send is already queued but
+#' never records that one is, so every deferred `setInput` queues its own
+#' send. The first carries all pending inputs and the rest send an empty
+#' update. The server runs a full input cycle for each: it walks every output
+#' of the session to update its hidden state, then flushes. Mounting a block
+#' card sets about a dozen inputs, so a first visit to a 15-block dock view
+#' sent 218 messages, 177 of them empty, and the dock's own messages queued
+#' behind them for 2 to 4 seconds.
+#'
+#' The script wraps `Shiny.shinyapp.sendInput` to return early on an empty
+#' object. Nothing is lost: the inputs such a send would have carried went
+#' out with the first one. Once Shiny records the queued send itself
+#' (<https://github.com/rstudio/shiny/issues/4436>), no empty batch reaches
+#' the wrapper.
+#'
+#' Attach it once, at the page level, like [shiny_has_perf_dep()].
+#'
+#' @return An [htmltools::htmlDependency].
+#'
+#' @examples
+#' shiny::fluidPage(shiny_input_batch_dep())
+#'
+#' @export
+shiny_input_batch_dep <- function() {
+  htmltools::htmlDependency(
+    name = "blockr-shiny-input-batch",
+    version = utils::packageVersion("blockr.ui"),
+    package = "blockr.ui",
+    src = "assets",
+    script = "js/shiny-input-batch.js",
+    all_files = FALSE
+  )
+}

inst/assets/js/shiny-input-batch.js

@@ -0,0 +1,52 @@
+// Drop the empty input messages Shiny sends after every deferred setInput.
+//
+// Shiny's InputBatchSender (shiny 1.14.0, srcts/src/inputPolicies/
+// inputBatchSender.ts) batches deferred inputs into one message per task. It
+// checks `sendIsEnqueued` before enqueueing the send, but never sets it, so
+// each deferred setInput enqueues its own send. The first carries every
+// pending input; the rest find the batch drained and send
+// `{"method":"update","data":{}}`.
+//
+// The server treats each of those as a full input cycle: manageInputs() walks
+// every output of the session to update its hidden state, then a reactive
+// flush runs. Mounting a block card sets about a dozen inputs, so a first
+// visit to a 15-block view sent 218 messages, 177 of them empty, at 3 to 11ms
+// each. They also sit in the websocket queue ahead of the messages that
+// matter: the dock's `initialized` report waited 1.9 to 3.7s behind them, and
+// nothing on the view evaluates before it is handled.
+//
+// An empty update carries nothing, so skipping it is behaviour-neutral: the
+// batch it would have sent was already sent by the first task. Once Shiny sets
+// the flag itself, no empty batch reaches this wrapper and it does nothing.
+(function () {
+  function patch() {
+    var app = window.Shiny && window.Shiny.shinyapp;
+
+    if (!app || typeof app.sendInput !== "function" || app.sendInput.blockrSkipsEmpty) {
+      return;
+    }
+
+    var sendInput = app.sendInput;
+
+    var wrapped = function (values) {
+      if (values && typeof values === "object" && Object.keys(values).length === 0) {
+        return;
+      }
+      return sendInput.apply(this, arguments);
+    };
+
+    wrapped.blockrSkipsEmpty = true;
+    app.sendInput = wrapped;
+  }
+
+  // shinyapp exists once Shiny initialises on document ready; the first
+  // deferred inputs go out after the socket connects, so patching at either
+  // point is early enough. Patch at both, the wrapper is applied once.
+  patch();
+
+  if (window.jQuery) {
+    window.jQuery(document).on("shiny:connected", patch);
+  }
+
+  document.addEventListener("DOMContentLoaded", patch);
+})();

tests/js/coverage.test.js

@@ -12,7 +12,10 @@ const { test } = require('node:test');
 const JS_DIR = path.join(__dirname, '..', '..', 'inst', 'assets', 'js');
 
 // Scripts whose tests are R tests, and where.
-const elsewhere = { 'shiny-has-perf.js': 'tests/testthat/test-shiny-has-perf.R' };
+const elsewhere = {
+  'shiny-has-perf.js': 'tests/testthat/test-shiny-has-perf.R',
+  'shiny-input-batch.js': 'tests/testthat/test-shiny-input-batch.R'
+};
 
 test('every shipped script has a test', () => {
   const tests = fs.readdirSync(__dirname)

tests/testthat/test-shiny-input-batch.R

@@ -0,0 +1,70 @@
+# Runs the shipped script against a stand-in for `Shiny.shinyapp`, so the test
+# covers what the browser executes.
+input_batch_ctx <- function() {
+
+  testthat::skip_if_not_installed("V8")
+
+  ctx <- V8::v8()
+
+  ctx$eval("
+    var sent = [];
+    var document = { addEventListener: function () {} };
+    var window = {
+      Shiny: {
+        shinyapp: {
+          sendInput: function (values) { sent.push(JSON.stringify(values)); }
+        }
+      }
+    };
+  ")
+
+  ctx$source(
+    system.file("assets", "js", "shiny-input-batch.js", package = "blockr.ui")
+  )
+
+  ctx
+}
+
+test_that("empty input batches are dropped, others pass through", {
+
+  ctx <- input_batch_ctx()
+
+  ctx$eval("
+    var app = window.Shiny.shinyapp;
+    app.sendInput({ a: 1, b: 'x' });
+    app.sendInput({});
+    app.sendInput({});
+    app.sendInput({ c: null });
+  ")
+
+  expect_identical(
+    ctx$get("sent"),
+    c('{"a":1,"b":"x"}', '{"c":null}')
+  )
+})
+
+test_that("the wrapper is applied once", {
+
+  ctx <- input_batch_ctx()
+
+  ctx$source(
+    system.file("assets", "js", "shiny-input-batch.js", package = "blockr.ui")
+  )
+
+  ctx$eval("window.Shiny.shinyapp.sendInput({ a: 1 });")
+
+  expect_identical(ctx$get("sent"), '{"a":1}')
+})
+
+test_that("shiny_input_batch_dep ships the script it documents", {
+
+  dep <- shiny_input_batch_dep()
+
+  expect_s3_class(dep, "html_dependency")
+  expect_identical(dep$script, "js/shiny-input-batch.js")
+  expect_true(
+    file.exists(
+      system.file("assets", dep$script, package = "blockr.ui")
+    )
+  )
+})