From c22d0fd2f1d8139117bb45a4b33129798c8adb29 Mon Sep 17 00:00:00 2001 From: Stefan McKinnon Edwards Date: Tue, 14 Mar 2023 10:56:31 +0100 Subject: [PATCH] add: verifyInputMessage for mock-session New manner for testing the contents of `message` when unit testing methods that use `sendInputMessage`. Similar methods should be implemented for session$sendCustomMessage and session$sendBinaryMessage. --- NAMESPACE | 1 + NEWS.md | 2 + R/mock-session.R | 95 +++++++++++++++++++++++++- man/MockShinySession.Rd | 103 ++++++++++++++++++++++++++++- tests/testthat/test-mock-session.R | 46 ++++++++++++- tests/testthat/test-update-input.R | 51 +++++--------- 6 files changed, 260 insertions(+), 38 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index d13edda0f7..f266f1f4b6 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index e73e9ad6d5..d0265c33b6 100644 --- a/NEWS.md +++ b/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) diff --git a/R/mock-session.R b/R/mock-session.R index fd4227d295..ceccfefa19 100644 --- a/R/mock-session.R +++ b/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. diff --git a/man/MockShinySession.Rd b/man/MockShinySession.Rd index 68f0911469..4b49e0223c 100644 --- a/man/MockShinySession.Rd +++ b/man/MockShinySession.Rd @@ -28,6 +28,25 @@ of \code{\link[=testServer]{testServer()}}. \dontrun{ session$setInputs(x=1, y=2) } + +## ------------------------------------------------ +## Method `MockShinySession$verifyInputMessage` +## ------------------------------------------------ + +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(., "")) +} + } \section{Public fields}{ \if{html}{\out{
}} @@ -113,6 +132,8 @@ user. Always \code{NULL} for a \code{MockShinySesion}.} \item \href{#method-MockShinySession-onSessionEnded}{\code{MockShinySession$onSessionEnded()}} \item \href{#method-MockShinySession-registerDownload}{\code{MockShinySession$registerDownload()}} \item \href{#method-MockShinySession-getCurrentOutputInfo}{\code{MockShinySession$getCurrentOutputInfo()}} +\item \href{#method-MockShinySession-sendInputMessage}{\code{MockShinySession$sendInputMessage()}} +\item \href{#method-MockShinySession-verifyInputMessage}{\code{MockShinySession$verifyInputMessage()}} \item \href{#method-MockShinySession-clone}{\code{MockShinySession$clone()}} } } @@ -610,8 +631,88 @@ executed. \subsection{Returns}{ A list with with the \code{name} of the output. If no output is currently being executed, this will return \code{NULL}. -output, or \code{NULL} if no output is currently executing. } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-MockShinySession-sendInputMessage}{}}} +\subsection{Method \code{sendInputMessage()}}{ +Mocks a \code{session$sendInputMessage}-call +that can be later verified. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{MockShinySession$sendInputMessage(inputId, message)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{inputId, message}}{See \code{sendInputMessage} in \link{session}.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-MockShinySession-verifyInputMessage}{}}} +\subsection{Method \code{verifyInputMessage()}}{ +Verifies that a call to \code{session$sendInputMessage} has been performed. + +Use either simple expectations, e.g. \code{expect_equal(., "some value")}, +or functions, \code{function(x) is.list(x)} or +\code{function(x) expect_equal(x, list(1))}. + +For simple expectations, the sent message is accessed with \code{.}. + +For functions, they are called with the sent message as first argument. +If any of the expressions in the function throws an error, \code{verifyInputMessage} +fails. + +For both functions and expectations, their returned value must be +\code{NULL} or pass \code{\link{isTruthy}} for the assertion to succeed. + +NB! testthat's \verb{expect_*}-functions, when the expectations succeeds, +returns the tested value. I.e. if testing for any of the values on the +list in \code{\link{isTruthy}} (\code{FALSE}, \code{""}, \code{vector(0)}, etc.), \code{verifyInputMessage} +will fail if results not properly wrapped. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{MockShinySession$verifyInputMessage(inputId, ..., env = rlang::caller_env())}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{inputId}}{Expected inputId and message of the +last call to \code{session$sendInputMessage}.} + +\item{\code{...}}{Assertions to test against.} + +\item{\code{env}}{(advanced use only) the environment in which to evaluate +\code{...} assertions. +output, or \code{NULL} if no output is currently executing.} +} +\if{html}{\out{
}} +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{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(., "")) +} + +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/tests/testthat/test-mock-session.R b/tests/testthat/test-mock-session.R index 8a34696b58..5272933caf 100644 --- a/tests/testthat/test-mock-session.R +++ b/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", { diff --git a/tests/testthat/test-update-input.R b/tests/testthat/test-update-input.R index 369db4efc1..b236f88558 100644 --- a/tests/testthat/test-update-input.R +++ b/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)) + ) })