add: verifyInputMessage for mock-session

NAMESPACE

@@ -403,6 +403,7 @@ importFrom(rlang,get_env)
 importFrom(rlang,get_expr)
 importFrom(rlang,inject)
 importFrom(rlang,is_false)
+importFrom(rlang,is_function)
 importFrom(rlang,is_missing)
 importFrom(rlang,is_na)
 importFrom(rlang,is_quosure)

NEWS.md

@@ -12,6 +12,8 @@
 
 * `Map` objects are now initialized at load time instead of build time. This avoids potential problems that could arise from storing `fastmap` objects into the built Shiny package. (#3775)
 
+* Added methods to `mock-session` for verifying that specific calls to `session$sendInputMessage` were performed; see `verifyInputMessage`. Fully supports unit testing with the `testthat`-package, but does not require it.
+
 ### Bug fixes
 
 * Fixed #3771: Sometimes the error `ion.rangeSlider.min.js: i.stopPropagation is not a function` would appear in the JavaScript console. (#3772)

R/mock-session.R

@@ -149,7 +149,6 @@ makeExtraMethods <- function() {
     "sendBinaryMessage",
     "sendChangeTabVisibility",
     "sendCustomMessage",
-    "sendInputMessage",
     "sendInsertTab",
     "sendInsertUI",
     "sendModal",
@@ -209,6 +208,7 @@ addGeneratedInstanceMethods <- function(instance, methods = makeExtraMethods())
 #'   of [testServer()].
 #'
 #' @include timer.R
+#' @importFrom rlang is_function
 #' @export
 MockShinySession <- R6Class(
   'MockShinySession',
@@ -609,6 +609,95 @@ MockShinySession <- R6Class(
     getCurrentOutputInfo = function() {
       name <- private$currentOutputName
       if (is.null(name)) NULL else list(name = name)
+    },
+
+    #' @description
+    #' Mocks a `session$sendInputMessage`-call
+    #' that can be later verified.
+    #' @param inputId,message See `sendInputMessage` in [session].
+    sendInputMessage = function(inputId, message) {
+      stopifnot(length(inputId) == 1) ## purely guessing on internal workings of session
+      private$inputMessage[[as.character(inputId)]] = message
+    },
+
+    #' @description
+    #' Verifies that a call to `session$sendInputMessage` has been performed.
+    #'
+    #' Use either simple expectations, e.g. `expect_equal(., "some value")`,
+    #' or functions, `function(x) is.list(x)` or
+    #' `function(x) expect_equal(x, list(1))`.
+    #'
+    #' For simple expectations, the sent message is accessed with `.`.
+    #'
+    #' For functions, they are called with the sent message as first argument.
+    #' If any of the expressions in the function throws an error, `verifyInputMessage`
+    #' fails.
+    #'
+    #' For both functions and expectations, their returned value must be
+    #' `NULL` or pass [`isTruthy`] for the assertion to succeed.
+    #'
+    #' NB! testthat's `expect_*`-functions, when the expectations succeeds,
+    #' returns the tested value. I.e. if testing for any of the values on the
+    #' list in [`isTruthy`] (`FALSE`, `""`, `vector(0)`, etc.), `verifyInputMessage`
+    #' will fail if results not properly wrapped.
+    #'
+    #' @examples
+    #' session <- MockShinySession$new()
+    #' session$sendInputMessage("foo", "")
+    #' session$sendInputMessage("bar", list(value=2, add=TRUE))
+    #' session$verifyInputMessage("foo", . == "")
+    #'\dontrun{
+    #'  # This should be wrapped in an if (requireNamespace("testthat)),
+    #'  # but expect_equal was still now found?!
+    #'   session$verifyInputMessage("bar", expect_equal(., list(value=2, add=TRUE)))
+    #'
+    #'  # Will fail, as `expect_equal` returns the value, which
+    #'  # in this case is not truthy.
+    #'  session$verifyInputMessage("foo", expect_equal(., ""))
+    #' }
+    #'
+    #' @param inputId Expected inputId and message of the
+    #'   last call to `session$sendInputMessage`.
+    #' @param ... Assertions to test against.
+    #' @param env (advanced use only) the environment in which to evaluate
+    #'   `...` assertions.
+    verifyInputMessage = function(inputId, ..., env = rlang::caller_env()) {
+      asserts <- eval(substitute(alist(...)))
+      test.env <- new.env(parent = env)
+      msg <- private$inputMessage[[as.character(inputId)]]
+      if (length(msg) == 0) {
+        stop(errorCondition(
+          sprintf("session$sendInputMessage(inputId=\"%s\") has not been called.", inputId),
+          class = c("failure","expectation")
+        ))
+      }
+
+      delayedAssign(".", msg, assign.env = test.env)
+      for (assertion in asserts) {
+        res <- tryCatch({
+          val <- eval(assertion, test.env)
+          if (is_function(val)) {
+            val <- val(msg)
+          }
+          outcome <- isTruthy(val %||% TRUE)
+          attr(outcome, "msg") <- attr(val, "msg")
+          outcome
+        }, assertError = function(e) {
+          structure(FALSE, msg = e$message)
+        }, error = function(e) {
+          stop(e)
+        })
+        if (!res) {
+          msg <- attr(res, "msg") %||% paste0(deparse(assertion), " is not TRUE")
+          stop(errorCondition(msg, class = c("failure", "expectation")))
+        }
+      }
+
+      # signal a (expectation?) condition, so testthat accepts this as a test.
+      cond <- simpleCondition(TRUE)
+      class(cond) <- c('expectation_success','expectation', class(cond))
+      withRestarts(signalCondition(cond), continue_test = function(e) NULL)
+      invisible(cond)
     }
   ),
   private = list(
@@ -696,7 +785,9 @@ MockShinySession <- R6Class(
         createVarPromiseDomain(private, "currentOutputName", name),
         expr
       )
-    }
+    },
+
+    inputMessage = list()
   ),
   active = list(
     #' @field files For internal use only.

tests/testthat/test-mock-session.R

@@ -245,7 +245,51 @@ test_that("session supports sendBinaryMessage", {
 test_that("session supports sendInputMessage", {
   session <- MockShinySession$new()
   session$sendInputMessage(inputId=1, message=2)
-  expect_true(TRUE) # testthat insists that every test must have an expectation
+  session$sendInputMessage(inputId="foo", message=list(bar=1, add=TRUE))
+  session$verifyInputMessage(1, expect_equal(., 2))
+  session$verifyInputMessage(1, function(x) {
+    expect_type(x, "double")
+    expect_equal(x, 2)
+  })
+  session$verifyInputMessage("foo", expect_true(.$add), expect_equal(.$bar, 1))
+})
+
+test_that("verifyInputMessage is itself enough for a `test_that`", {
+  session <- MockShinySession$new()
+  session$sendInputMessage(inputId=1, message=2)
+  session$verifyInputMessage(1, . == 2)
+})
+
+test_that("session supports failing verifyInputMessage", {
+  session <- MockShinySession$new()
+  expect_failure(
+    session$verifyInputMessage(1, expect_equal(., 1)),
+    message = "session$sendInputMessage(inputId=\"1\") has not been called.",
+    fixed = TRUE
+  )
+  session$sendInputMessage(inputId=1, message=2)
+  expect_success(session$verifyInputMessage(1, expect_equal(., 2)))
+  expect_failure(
+    session$verifyInputMessage(1, expect_equal(., 1)),
+    message = "`.` (`actual`) not equal to 1 (`expected`)",
+    fixed = TRUE
+  )
+  expect_failure(
+    session$verifyInputMessage(1, function(x) expect_equal(x, 1)),
+    message = "`x` (`actual`) not equal to 1 (`expected`)",
+    fixed = TRUE
+  )
+  expect_failure(
+    session$verifyInputMessage(1, . == 1),
+    message = ". == 1 is not TRUE",
+    fixed = TRUE
+  )
+  expect_failure(
+    session$verifyInputMessage(1, function(x) x == 1),
+    message = "function(x) x == 1 is not TRUE",
+    fixed = TRUE
+  )
+
 })
 
 test_that("session supports setBookmarkExclude", {

tests/testthat/test-update-input.R

@@ -1,36 +1,19 @@
 test_that("Radio buttons and checkboxes work with modules", {
-  createModuleSession <- function(moduleId) {
-    session <- as.environment(list(
-      ns = NS(moduleId),
-      sendInputMessage = function(inputId, message) {
-        session$lastInputMessage = list(id = inputId, message = message)
-      }
-    ))
-    class(session) <- "ShinySession"
-    session
-  }
-
-  sessA <- createModuleSession("modA")
-
-  updateRadioButtons(sessA, "test1", label = "Label", choices = letters[1:5])
-  resultA <- sessA$lastInputMessage
-
-  expect_equal("test1", resultA$id)
-  expect_equal("Label", resultA$message$label)
-  expect_equal("a", resultA$message$value)
-  expect_true(grepl('"modA-test1"', resultA$message$options))
-  expect_false(grepl('"test1"', resultA$message$options))
-
-
-  sessB <- createModuleSession("modB")
-
-  updateCheckboxGroupInput(sessB, "test2", label = "Label", choices = LETTERS[1:5])
-  resultB <- sessB$lastInputMessage
-
-  expect_equal("test2", resultB$id)
-  expect_equal("Label", resultB$message$label)
-  expect_null(resultB$message$value)
-  expect_true(grepl('"modB-test2"', resultB$message$options))
-  expect_false(grepl('"test2"', resultB$message$options))
-
+  session <- MockShinySession$new()
+
+  updateRadioButtons(session, "test1", label = "Label", choices = letters[1:5])
+  session$verifyInputMessage("test1",
+    expect_equal(.$label, "Label"),
+    expect_equal(.$value, "a"),
+    expect_true(grepl('"mock-session-test1"', .$options)),
+    !expect_false(grepl('"test1"', .$options)) ## negate returned FALSE from expect_false
+  )
+
+  updateCheckboxGroupInput(session, "test2", label = "Label", choices = LETTERS[1:5])
+  session$verifyInputMessage("test2",
+     expect_equal(.$label, "Label"),
+     expect_null(.$value),
+     expect_true(grepl('"mock-session-test2"', .$options)),
+     !expect_false(grepl('"test2"', .$options))
+  )
 })