Skip to content

Commit

Permalink
add: verifyInputMessage for mock-session
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
Stefan McKinnon Edwards committed Mar 14, 2023
1 parent 4d05a56 commit 9485723
Show file tree
Hide file tree
Showing 6 changed files with 260 additions and 38 deletions.
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
2 changes: 2 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
95 changes: 93 additions & 2 deletions R/mock-session.R
Original file line number Diff line number Diff line change
Expand Up @@ -149,7 +149,6 @@ makeExtraMethods <- function() {
"sendBinaryMessage",
"sendChangeTabVisibility",
"sendCustomMessage",
"sendInputMessage",
"sendInsertTab",
"sendInsertUI",
"sendModal",
Expand Down Expand Up @@ -209,6 +208,7 @@ addGeneratedInstanceMethods <- function(instance, methods = makeExtraMethods())
#' of [testServer()].
#'
#' @include timer.R
#' @importFrom rlang is_function
#' @export
MockShinySession <- R6Class(
'MockShinySession',
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -696,7 +785,9 @@ MockShinySession <- R6Class(
createVarPromiseDomain(private, "currentOutputName", name),
expr
)
}
},

inputMessage = list()
),
active = list(
#' @field files For internal use only.
Expand Down
103 changes: 102 additions & 1 deletion man/MockShinySession.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

46 changes: 45 additions & 1 deletion tests/testthat/test-mock-session.R
Original file line number Diff line number Diff line change
Expand Up @@ -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", {
Expand Down
51 changes: 17 additions & 34 deletions tests/testthat/test-update-input.R
Original file line number Diff line number Diff line change
@@ -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))
)
})

0 comments on commit 9485723

Please sign in to comment.