Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

add: verifyInputMessage for mock-session #3791

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
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))
)
})