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))
+ )
 })