Create Test Update Functions

Given a set of functions from an R package, create a set of mocked functions that can be used as bindings to test UI updates within `testServer`.

Usage

create_test_update_fns(
  fn_names,
  id_arg = "inputId",
  value_args = c("value", "selected"),
  range_value_args = c("start", "end"),
  .package = "shiny"
)

Arguments

fn_names

A character vector (string) of function names to create wrappers for

id_arg

A character string of the argument in `fn_names` that relates to the HTML ID argument. Default is "inputId"

value_args

A character vector of the arguments in `fn_names` that relate to the input value arguments. Defaults are `"value"` and `"selected`.

range_value_args

A character vector of the arguments in `fn_names` that relate to the input value arguments when multiple arguments can be used to update the input. Defaults are `"start"` and `"end"`.

.package

Character string of the package that `fn_names` exist in. Default is `"shiny"`

Value

A named list of function expressions, one for each function supplied in `fn_names`.

Examples

create_test_update_fns(
  c("updateSelectInput", "updateTextInput"),
  .package = "shiny"
)
#> $updateSelectInput
#> function (session = getDefaultReactiveDomain(), inputId, label = NULL, 
#>     choices = NULL, selected = NULL) 
#> {
#>     fn_args <- rlang::fn_fmls_names()
#>     session_arg <- grep("session", fn_args, value = TRUE)
#>     if (length(session_arg) != 1L) {
#>         cli::cli_abort("Unable to determine session argument for {.fn {fn_name}}")
#>     }
#>     id_value <- get(id_arg)
#>     value_arg <- update_value(id = id_value, fn_args = fn_args, 
#>         value_args = value_args, range_value_args = range_value_args, 
#>         session = session)
#>     if (.package == "shiny") {
#>         id_choice_value <- paste(id_value, "choices", sep = ".")
#>         choice_args <- grep("choice(Names|Values)", fn_args, 
#>             value = TRUE)
#>         valid_choice_args <- length(choice_args) == 2L && "choices" %in% 
#>             fn_args && is.null(get("choices")) && !is.null(get("choiceNames"))
#>         if (valid_choice_args) {
#>             update_input(id = id_choice_value, value = stats::setNames(get("choiceValues"), 
#>                 get("choiceNames")), session = session)
#>         }
#>         data_arg <- grep("data", fn_args, value = TRUE)
#>         if (length(data_arg) == 1L && !is.null(get("data"))) {
#>             update_input(id = id_choice_value, value = names(get("data")), 
#>                 session = session)
#>         }
#>     }
#>     else {
#>         choice_args <- data_arg <- NULL
#>     }
#>     other_args <- setdiff(fn_args, c(session_arg, id_arg, value_arg, 
#>         choice_args, data_arg))
#>     for (other_arg in other_args) {
#>         update_input(id = paste(id_value, other_arg, sep = "."), 
#>             value = get(other_arg), session = session)
#>     }
#> }
#> <environment: 0x5591034c0630>
#> 
#> $updateTextInput
#> function (session = getDefaultReactiveDomain(), inputId, label = NULL, 
#>     value = NULL, placeholder = NULL) 
#> {
#>     fn_args <- rlang::fn_fmls_names()
#>     session_arg <- grep("session", fn_args, value = TRUE)
#>     if (length(session_arg) != 1L) {
#>         cli::cli_abort("Unable to determine session argument for {.fn {fn_name}}")
#>     }
#>     id_value <- get(id_arg)
#>     value_arg <- update_value(id = id_value, fn_args = fn_args, 
#>         value_args = value_args, range_value_args = range_value_args, 
#>         session = session)
#>     if (.package == "shiny") {
#>         id_choice_value <- paste(id_value, "choices", sep = ".")
#>         choice_args <- grep("choice(Names|Values)", fn_args, 
#>             value = TRUE)
#>         valid_choice_args <- length(choice_args) == 2L && "choices" %in% 
#>             fn_args && is.null(get("choices")) && !is.null(get("choiceNames"))
#>         if (valid_choice_args) {
#>             update_input(id = id_choice_value, value = stats::setNames(get("choiceValues"), 
#>                 get("choiceNames")), session = session)
#>         }
#>         data_arg <- grep("data", fn_args, value = TRUE)
#>         if (length(data_arg) == 1L && !is.null(get("data"))) {
#>             update_input(id = id_choice_value, value = names(get("data")), 
#>                 session = session)
#>         }
#>     }
#>     else {
#>         choice_args <- data_arg <- NULL
#>     }
#>     other_args <- setdiff(fn_args, c(session_arg, id_arg, value_arg, 
#>         choice_args, data_arg))
#>     for (other_arg in other_args) {
#>         update_input(id = paste(id_value, other_arg, sep = "."), 
#>             value = get(other_arg), session = session)
#>     }
#> }
#> <environment: 0x5591034d5478>
#>