From c9b0a965bb91109d6704757bd59ce481666d5788 Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Mon, 5 Feb 2024 10:28:52 -0600 Subject: [PATCH 1/5] Document `scene_action` class. --- DESCRIPTION | 4 ++-- R/action-cookie.R | 6 +++--- R/action-method.R | 6 +++--- R/action-query.R | 14 +++++++------- R/action.R | 18 ++++++++++++++---- R/set.R | 2 +- man/construct_action.Rd | 4 ++-- man/dot-new_action.Rd | 3 +-- man/req_has_cookie.Rd | 6 +++--- man/req_has_query.Rd | 14 +++++++------- man/req_uses_method.Rd | 6 +++--- man/scene_action-class.Rd | 14 ++++++++++++++ man/scenes-package.Rd | 2 +- man/set_scene.Rd | 2 +- 14 files changed, 62 insertions(+), 39 deletions(-) create mode 100644 man/scene_action-class.Rd diff --git a/DESCRIPTION b/DESCRIPTION index e6b9af1..bb2ad37 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -9,7 +9,7 @@ Description: Sometimes it is useful to serve up alternative 'shiny' UIs value of a cookie or a query parameter. This packages facilitates such switches. License: MIT + file LICENSE -URL: https://shinyworks.github.io/scenes/, +URL: https://scenes.shinyworks.org/scenes/, https://github.com/shinyworks/scenes BugReports: https://github.com/shinyworks/scenes/issues Imports: @@ -31,4 +31,4 @@ VignetteBuilder: Config/testthat/edition: 3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.0 diff --git a/R/action-cookie.R b/R/action-cookie.R index f53bf53..1cb6063 100644 --- a/R/action-cookie.R +++ b/R/action-cookie.R @@ -1,12 +1,12 @@ #' Switch Scenes on Cookies #' -#' Create a `scene_action` specifying a cookie that must be present (or absent) -#' and optionally a check function for that cookie. +#' Create a [`scene_action`][scene_action-class] specifying a cookie that must +#' be present (or absent) and optionally a check function for that cookie. #' #' @inheritParams .req_has_cookie_impl #' @inheritParams construct_action #' -#' @return A `scene_action` object, to be used in [set_scene()]. +#' @return A [`scene_action`][scene_action-class], to be used in [set_scene()]. #' @export #' #' @examples diff --git a/R/action-method.R b/R/action-method.R index 4652497..bed4e8b 100644 --- a/R/action-method.R +++ b/R/action-method.R @@ -1,12 +1,12 @@ #' Switch Scenes on Method #' -#' Create a `scene_action` specifying the HTTP method that must be used (or not -#' used). +#' Create a [`scene_action`][scene_action-class] specifying the HTTP method that +#' must be used (or not used). #' #' @inheritParams .req_uses_method_impl #' @inheritParams construct_action #' -#' @return A `scene_action` object, to be used in [set_scene()]. +#' @return A [`scene_action`][scene_action-class], to be used in [set_scene()]. #' @export #' #' @examples diff --git a/R/action-query.R b/R/action-query.R index 56fed9a..dee450b 100644 --- a/R/action-query.R +++ b/R/action-query.R @@ -1,16 +1,16 @@ #' Switch Scenes on Query #' -#' Create a `scene_action` specifying a key that must be present (or absent) in -#' the query string (the part of the URL when the shiny app was called, after -#' "?"), and optionally a value or values for that key. For example, in -#' `myapps.shinyapps.io/myapp?param1=1¶m2=text`, `?param1=1¶m2=text` is -#' the query string, `param1` and `param2` are keys, and `1` and `text` are -#' their corresponding values. +#' Create a [`scene_action`][scene_action-class] specifying a key that must be +#' present (or absent) in the query string (the part of the URL when the shiny +#' app was called, after "?"), and optionally a value or values for that key. +#' For example, in `myapps.shinyapps.io/myapp?param1=1¶m2=text`, +#' `?param1=1¶m2=text` is the query string, `param1` and `param2` are keys, +#' and `1` and `text` are their corresponding values. #' #' @inheritParams .req_has_query_impl #' @inheritParams construct_action #' -#' @return A `scene_action` object, to be used in [set_scene()]. +#' @return A [`scene_action`][scene_action-class], to be used in [set_scene()]. #' @export #' #' @examples diff --git a/R/action.R b/R/action.R index 37d5b24..85a9f6c 100644 --- a/R/action.R +++ b/R/action.R @@ -1,7 +1,7 @@ #' Construct a Scene Action #' #' Generate the check function for an action, and use it to create a -#' `scene_action` object. +#' [`scene_action`][scene_action-class] object. #' #' @param fn A function that takes a request (and potentially other arguments) #' and returns `TRUE` or `FALSE`. @@ -11,7 +11,7 @@ #' @param methods The http methods which needs to be accepted in order for this #' function to make sense. Default "GET" should work in almost all cases. #' -#' @return A `scene_action` object. +#' @return A [`scene_action`][scene_action-class]. #' @export #' #' @examples @@ -69,8 +69,7 @@ construct_action <- function(fn, #' associated scene should be returned. #' @param methods The http methods supported by this action. #' -#' @return A `scene_action` object, which is a `list` with components `check_fn` -#' and `methods`. +#' @return A [`scene_action`][scene_action-class]. #' @keywords internal .new_action <- function(check_fn, methods) { return( @@ -83,3 +82,14 @@ construct_action <- function(fn, ) ) } + +#' `scene_action` class +#' +#' @description A `scene_action` object is a `list` with components `check_fn` +#' and `methods`. It is used to test whether a request should trigger a +#' particlar scene. +#' +#' @name scene_action-class +#' @aliases scene_action +#' @seealso [construct_action()] +NULL diff --git a/R/set.R b/R/set.R index e719f66..d7b5de4 100644 --- a/R/set.R +++ b/R/set.R @@ -3,7 +3,7 @@ #' A scene is a shiny ui and the actions that trigger it. #' #' @param ui A shiny ui. -#' @param ... One or more `scene_action` objects. +#' @param ... Zero or more [`scene_actions`][scene_action-class]. #' #' @return A `shiny_scene` object, which is a list with components `ui` and #' `actions`. diff --git a/man/construct_action.Rd b/man/construct_action.Rd index 2d0c331..2592c77 100644 --- a/man/construct_action.Rd +++ b/man/construct_action.Rd @@ -19,11 +19,11 @@ and returns \code{TRUE} or \code{FALSE}.} function to make sense. Default "GET" should work in almost all cases.} } \value{ -A \code{scene_action} object. +A \code{\link[=scene_action-class]{scene_action}}. } \description{ Generate the check function for an action, and use it to create a -\code{scene_action} object. +\code{\link[=scene_action-class]{scene_action}} object. } \examples{ simple_function <- function(request) { diff --git a/man/dot-new_action.Rd b/man/dot-new_action.Rd index d6e821a..2a275a4 100644 --- a/man/dot-new_action.Rd +++ b/man/dot-new_action.Rd @@ -13,8 +13,7 @@ associated scene should be returned.} \item{methods}{The http methods supported by this action.} } \value{ -A \code{scene_action} object, which is a \code{list} with components \code{check_fn} -and \code{methods}. +A \code{\link[=scene_action-class]{scene_action}}. } \description{ Structure a Scene Action diff --git a/man/req_has_cookie.Rd b/man/req_has_cookie.Rd index a399f5f..a32146c 100644 --- a/man/req_has_cookie.Rd +++ b/man/req_has_cookie.Rd @@ -20,11 +20,11 @@ otherwise.} \code{not} matched.} } \value{ -A \code{scene_action} object, to be used in \code{\link[=set_scene]{set_scene()}}. +A \code{\link[=scene_action-class]{scene_action}}, to be used in \code{\link[=set_scene]{set_scene()}}. } \description{ -Create a \code{scene_action} specifying a cookie that must be present (or absent) -and optionally a check function for that cookie. +Create a \code{\link[=scene_action-class]{scene_action}} specifying a cookie that must +be present (or absent) and optionally a check function for that cookie. } \examples{ # Specify an action to detect a cookie named "mycookie". diff --git a/man/req_has_query.Rd b/man/req_has_query.Rd index 3448370..cf31cc9 100644 --- a/man/req_has_query.Rd +++ b/man/req_has_query.Rd @@ -18,15 +18,15 @@ action. Otherwise the actual value of the query must be present in \code{not} matched.} } \value{ -A \code{scene_action} object, to be used in \code{\link[=set_scene]{set_scene()}}. +A \code{\link[=scene_action-class]{scene_action}}, to be used in \code{\link[=set_scene]{set_scene()}}. } \description{ -Create a \code{scene_action} specifying a key that must be present (or absent) in -the query string (the part of the URL when the shiny app was called, after -"?"), and optionally a value or values for that key. For example, in -\code{myapps.shinyapps.io/myapp?param1=1¶m2=text}, \code{?param1=1¶m2=text} is -the query string, \code{param1} and \code{param2} are keys, and \code{1} and \code{text} are -their corresponding values. +Create a \code{\link[=scene_action-class]{scene_action}} specifying a key that must be +present (or absent) in the query string (the part of the URL when the shiny +app was called, after "?"), and optionally a value or values for that key. +For example, in \code{myapps.shinyapps.io/myapp?param1=1¶m2=text}, +\code{?param1=1¶m2=text} is the query string, \code{param1} and \code{param2} are keys, +and \code{1} and \code{text} are their corresponding values. } \examples{ # Specify an action to detect a "code" parameter in the query. diff --git a/man/req_uses_method.Rd b/man/req_uses_method.Rd index c8bdf4f..9911066 100644 --- a/man/req_uses_method.Rd +++ b/man/req_uses_method.Rd @@ -19,11 +19,11 @@ req_uses_post(negate = FALSE) \code{not} matched.} } \value{ -A \code{scene_action} object, to be used in \code{\link[=set_scene]{set_scene()}}. +A \code{\link[=scene_action-class]{scene_action}}, to be used in \code{\link[=set_scene]{set_scene()}}. } \description{ -Create a \code{scene_action} specifying the HTTP method that must be used (or not -used). +Create a \code{\link[=scene_action-class]{scene_action}} specifying the HTTP method that +must be used (or not used). } \examples{ req_uses_method("GET") diff --git a/man/scene_action-class.Rd b/man/scene_action-class.Rd new file mode 100644 index 0000000..aed9061 --- /dev/null +++ b/man/scene_action-class.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/action.R +\name{scene_action-class} +\alias{scene_action-class} +\alias{scene_action} +\title{\code{scene_action} class} +\description{ +A \code{scene_action} object is a \code{list} with components \code{check_fn} +and \code{methods}. It is used to test whether a request should trigger a +particlar scene. +} +\seealso{ +\code{\link[=construct_action]{construct_action()}} +} diff --git a/man/scenes-package.Rd b/man/scenes-package.Rd index 653e84f..5612e5c 100644 --- a/man/scenes-package.Rd +++ b/man/scenes-package.Rd @@ -13,7 +13,7 @@ Sometimes it is useful to serve up alternative 'shiny' UIs depending on informat \seealso{ Useful links: \itemize{ - \item \url{https://shinyworks.github.io/scenes/} + \item \url{https://scenes.shinyworks.org/scenes/} \item \url{https://github.com/shinyworks/scenes} \item Report bugs at \url{https://github.com/shinyworks/scenes/issues} } diff --git a/man/set_scene.Rd b/man/set_scene.Rd index 9499e32..4e9f432 100644 --- a/man/set_scene.Rd +++ b/man/set_scene.Rd @@ -9,7 +9,7 @@ set_scene(ui, ...) \arguments{ \item{ui}{A shiny ui.} -\item{...}{One or more \code{scene_action} objects.} +\item{...}{Zero or more \code{\link[=scene_action-class]{scene_actions}}.} } \value{ A \code{shiny_scene} object, which is a list with components \code{ui} and From e03aaea7c67e9f8dd3403e7f0b3d26eba4441925 Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Mon, 5 Feb 2024 10:56:32 -0600 Subject: [PATCH 2/5] Refactor construct_action(). --- R/action.R | 59 +++++++++++++++++++++--------------- tests/testthat/test-action.R | 49 ++++++++++++++++++------------ 2 files changed, 64 insertions(+), 44 deletions(-) diff --git a/R/action.R b/R/action.R index 85a9f6c..bc9d0cb 100644 --- a/R/action.R +++ b/R/action.R @@ -26,41 +26,52 @@ construct_action <- function(fn, ..., negate = FALSE, methods = "GET") { + methods <- .validate_methods(methods) + negate <- .validate_logical_scalar(negate) + check_fn <- .decorate_check_fn(fn, ..., negate = negate) + return( + .new_action( + check_fn = check_fn, + methods = methods + ) + ) +} + +.validate_methods <- function(methods, call = rlang::caller_env()) { rlang::arg_match( methods, c( - "GET", - "POST", - "PUT", - "HEAD", - "DELETE", - "PATCH", - "OPTIONS", - "CONNECT", - "TRACE" + "GET", "POST", "PUT", "HEAD", "DELETE", + "PATCH", "OPTIONS", "CONNECT", "TRACE" ), - multiple = TRUE - ) - stopifnot( - is.logical(negate), - length(negate) == 1 + multiple = TRUE, + error_call = call ) +} - check_fn <- fn - if (...length()) { - check_fn <- purrr::partial({{ fn }}, ...) +.validate_logical_scalar <- function(x, + arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (rlang::is_scalar_logical(x)) { + return(x) } + cli::cli_abort( + c( + "Argument {.arg {arg}} must be a length-1 logical vector.", + x = "{.arg {arg}} is {.obj_type_friendly {x}}." + ), + call = call, + class = "scenes_error_logical_scalar" + ) +} +.decorate_check_fn <- function(fn, ..., negate) { + + check_fn <- purrr::partial({{ fn }}, ...) if (negate) { check_fn <- Negate(check_fn) } - - return( - .new_action( - check_fn = check_fn, - methods = methods - ) - ) + return(check_fn) } #' Structure a Scene Action diff --git a/tests/testthat/test-action.R b/tests/testthat/test-action.R index 5a9643e..b98bd55 100644 --- a/tests/testthat/test-action.R +++ b/tests/testthat/test-action.R @@ -1,31 +1,40 @@ -test_that("action constructors work.", { - simple_function <- function(request) { - !missing(request) && length(request) > 1 - } - - test_action <- construct_action( - fn = simple_function, - negate = FALSE +test_that("construct_action() rejects bad methods", { + expect_error( + construct_action( + fn = function() {}, + methods = "bad_method" + ), + "GET" ) - test_action_negate <- construct_action( - fn = simple_function, - negate = TRUE +}) + +test_that("construct_action() rejects bad value of negate", { + expect_error( + construct_action( + fn = function() {}, + methods = "GET", + negate = 27 + ), + class = "scenes_error_logical_scalar" ) +}) - # Check that they're the expected shape. +test_that("construct_actions() returns the expected object", { + test_action <- construct_action(fn = function(request) {}) expect_s3_class(test_action, c("scene_action", "list"), exact = TRUE) - expect_s3_class(test_action_negate, c("scene_action", "list"), exact = TRUE) expect_named(test_action, c("check_fn", "methods")) - expect_named(test_action_negate, c("check_fn", "methods")) - expect_type(test_action$check_fn, "closure") - expect_type(test_action_negate$check_fn, "closure") - expect_identical(test_action$methods, "GET") - expect_identical(test_action_negate$methods, "GET") +}) + +test_that("construct_actions() negates", { + simple_function <- function(request) { + !missing(request) && length(request) > 1 + } + + test_action <- construct_action(fn = simple_function) + test_action_negate <- construct_action(fn = simple_function, negate = TRUE) - # Make sure they work as expected. The function should be TRUE if I pass in - # something longer than length-1 (or the opposite for the negate). expect_false(test_action$check_fn(1)) expect_true(test_action$check_fn(1:2)) expect_true(test_action_negate$check_fn(1)) From 60bcada4458ad045a23d7630a1cca4a9d696cbdb Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Mon, 5 Feb 2024 11:42:43 -0600 Subject: [PATCH 3/5] Refactor action-*(). --- NAMESPACE | 3 - R/action-cookie.R | 23 +++--- R/action-method.R | 21 +---- R/action-query.R | 6 +- R/action.R | 23 ++---- R/messaging.R | 111 --------------------------- R/validate.R | 31 ++++++++ man/dot-error_message.Rd | 31 -------- man/dot-validate_character_scalar.Rd | 23 ------ man/dot-validate_values.Rd | 23 ------ man/req_has_cookie.Rd | 15 ++-- tests/testthat/test-action-cookie.R | 10 +-- tests/testthat/test-action-method.R | 19 ----- tests/testthat/test-action-query.R | 10 +-- 14 files changed, 62 insertions(+), 287 deletions(-) delete mode 100644 R/messaging.R create mode 100644 R/validate.R delete mode 100644 man/dot-error_message.Rd delete mode 100644 man/dot-validate_character_scalar.Rd delete mode 100644 man/dot-validate_values.Rd diff --git a/NAMESPACE b/NAMESPACE index 1cfb913..0126bf6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(.validate_character_scalar,"NULL") -S3method(.validate_character_scalar,character) -S3method(.validate_character_scalar,default) export(change_scene) export(construct_action) export(default_ui) diff --git a/R/action-cookie.R b/R/action-cookie.R index 1cb6063..a2d516c 100644 --- a/R/action-cookie.R +++ b/R/action-cookie.R @@ -25,28 +25,25 @@ #' } #' ) #' -#' # Specify an action to detect a cookie named "mycookie" that has N -#' # characters. This would make more sense in a case where validation_fn isn't -#' # an anonymous function. +#' # Specify an action to detect a cookie named "mycookie" that has a +#' # variable-defined number of characters. +#' expect_n_chars <- function(x, N) { +#' nchar(x) == N +#' } +#' my_N <- 27 # Perhaps set by an environment variable. #' req_has_cookie( #' cookie_name = "mycookie", -#' validation_fn = function(cookie_value, N) { -#' nchar(cookie_value) == N -#' }, -#' N = 27 +#' validation_fn = expect_n_chars, +#' N = my_N #' ) req_has_cookie <- function(cookie_name, validation_fn = NULL, ..., negate = FALSE) { - .validate_character_scalar( - parameter = cookie_name, - parameter_name = "cookie_name" - ) - + cookie_name <- .validate_character_scalar(cookie_name) return( construct_action( - fn = .req_has_cookie_impl, + .req_has_cookie_impl, cookie_name = cookie_name, validation_fn = validation_fn, ..., diff --git a/R/action-method.R b/R/action-method.R index bed4e8b..5b395fc 100644 --- a/R/action-method.R +++ b/R/action-method.R @@ -13,26 +13,7 @@ #' req_uses_method("GET") #' req_uses_method("POST") req_uses_method <- function(method, negate = FALSE) { - valid_methods <- c( - "GET", "POST", "PUT", - "HEAD", "DELETE", "PATCH", - "OPTIONS", "CONNECT", "TRACE" - ) - - if (missing(method)) { - # I combine error messaging for the various 0-length cases, since toupper - # coerces. - method <- character(0) - } - - method <- toupper(method) - - .validate_character_scalar( - parameter = method, - parameter_name = "method", - valid_values = valid_methods - ) - + method <- .validate_methods(method, multiple = FALSE) return( construct_action( fn = .req_uses_method_impl, diff --git a/R/action-query.R b/R/action-query.R index dee450b..3a65f6c 100644 --- a/R/action-query.R +++ b/R/action-query.R @@ -26,11 +26,7 @@ req_has_query <- function(key, values = NULL, negate = FALSE) { # I consciously decided NOT to vectorize this, because I think that would # complicate the call. - .validate_character_scalar( - parameter = key, - parameter_name = "key" - ) - + key <- .validate_character_scalar(key) return( construct_action( fn = .req_has_query_impl, diff --git a/R/action.R b/R/action.R index bc9d0cb..5947f5e 100644 --- a/R/action.R +++ b/R/action.R @@ -37,34 +37,21 @@ construct_action <- function(fn, ) } -.validate_methods <- function(methods, call = rlang::caller_env()) { +.validate_methods <- function(methods, + multiple = TRUE, + call = rlang::caller_env()) { + methods <- toupper(methods) rlang::arg_match( methods, c( "GET", "POST", "PUT", "HEAD", "DELETE", "PATCH", "OPTIONS", "CONNECT", "TRACE" ), - multiple = TRUE, + multiple = multiple, error_call = call ) } -.validate_logical_scalar <- function(x, - arg = rlang::caller_arg(x), - call = rlang::caller_env()) { - if (rlang::is_scalar_logical(x)) { - return(x) - } - cli::cli_abort( - c( - "Argument {.arg {arg}} must be a length-1 logical vector.", - x = "{.arg {arg}} is {.obj_type_friendly {x}}." - ), - call = call, - class = "scenes_error_logical_scalar" - ) -} - .decorate_check_fn <- function(fn, ..., negate) { check_fn <- purrr::partial({{ fn }}, ...) diff --git a/R/messaging.R b/R/messaging.R deleted file mode 100644 index b23b0b8..0000000 --- a/R/messaging.R +++ /dev/null @@ -1,111 +0,0 @@ -# Someday this should be a package. - -#' Ensure that an Argument is Length-1 Character -#' -#' @param parameter The argument to test. -#' @param parameter_name The argument's name. Eventually this should be -#' automatically handled through rlang or something, in theory. -#' @param valid_values (optional) Expected values of the parameter. -#' -#' @return The parameter if it is character-scalar. -#' @keywords internal -.validate_character_scalar <- function(parameter, - parameter_name, - valid_values) { - UseMethod(".validate_character_scalar") -} - -#' @export -.validate_character_scalar.default <- function(parameter, - parameter_name, - valid_values) { - .error_message( - parameter, - parameter_name, - valid_values, - special_message = paste( - "{parameter_name} is a {.cls {class(parameter)}} vector,", - "not a {.cls character} vector." - ) - ) -} - -#' @export -.validate_character_scalar.character <- function(parameter, - parameter_name, - valid_values) { - if (length(parameter) == 1) { - return(.validate_values(parameter, parameter_name, valid_values)) - } - - .error_message( - parameter, - parameter_name, - valid_values, - special_message = "{parameter_name} has {length(parameter)} values." - ) -} - -#' @export -.validate_character_scalar.NULL <- function(parameter, - parameter_name, - valid_values) { - .error_message( - parameter, - parameter_name, - valid_values, - special_message = "{parameter_name} is missing or NULL." - ) -} - -#' Ensure that an Argument has Certain Values -#' -#' @inheritParams .validate_character_scalar -#' -#' @return The parameter. -#' @keywords internal -.validate_values <- function(parameter, parameter_name, valid_values) { - if (!missing(valid_values) && !all(parameter %in% valid_values)) { - .error_message( - parameter, - parameter_name, - valid_values, - special_message = "Unknown {parameter_name}: '{parameter}'", - level = 3 - ) - } - return(parameter) -} - -#' Generate an Error Message -#' -#' @inheritParams .validate_character_scalar -#' @param special_message A message tailored to the type of error. -#' @param level How deep the check is relative to the original function. Default -#' = 2. -#' -#' @keywords internal -.error_message <- function(parameter, - parameter_name, - valid_values, - special_message, - level = 2) { - parameter_name <- glue::backtick(parameter_name) - error_message <- special_message - if (!missing(valid_values)) { - valid_values <- glue::glue_collapse( - valid_values, - sep = ", ", - last = " or " - ) - one <- cli::style_italic("one") - error_message <- c( - error_message, - i = "{parameter_name} must be {one} of {valid_values}." - ) - } - cli::cli_abort( - error_message, - call = rlang::caller_env(level) - ) -} diff --git a/R/validate.R b/R/validate.R new file mode 100644 index 0000000..ad91710 --- /dev/null +++ b/R/validate.R @@ -0,0 +1,31 @@ +# This may all be updated to use github.com/jonthegeek/stbl or something similar +# in the future. + +.validate_logical_scalar <- function(x, + arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (rlang::is_scalar_logical(x)) { + return(x) + } + .abort_obj_type_scalar(x, "logical", arg, call) +} + +.abort_obj_type_scalar <- function(x, target_class, arg, call) { + cli::cli_abort( + c( + "{.arg {arg}} must be a length-1 {target_class} vector.", + "{.arg {arg}} is {.obj_type_friendly {x}}." + ), + call = call, + class = glue::glue("scenes_error_{target_class}_scalar") + ) +} + +.validate_character_scalar <- function(x, + arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (rlang::is_scalar_character(x)) { + return(x) + } + .abort_obj_type_scalar(x, "character", arg, call) +} diff --git a/man/dot-error_message.Rd b/man/dot-error_message.Rd deleted file mode 100644 index 05fd61c..0000000 --- a/man/dot-error_message.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/messaging.R -\name{.error_message} -\alias{.error_message} -\title{Generate an Error Message} -\usage{ -.error_message( - parameter, - parameter_name, - valid_values, - special_message, - level = 2 -) -} -\arguments{ -\item{parameter}{The argument to test.} - -\item{parameter_name}{The argument's name. Eventually this should be -automatically handled through rlang or something, in theory.} - -\item{valid_values}{(optional) Expected values of the parameter.} - -\item{special_message}{A message tailored to the type of error.} - -\item{level}{How deep the check is relative to the original function. Default -= 2.} -} -\description{ -Generate an Error Message -} -\keyword{internal} diff --git a/man/dot-validate_character_scalar.Rd b/man/dot-validate_character_scalar.Rd deleted file mode 100644 index 0a1d7ec..0000000 --- a/man/dot-validate_character_scalar.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/messaging.R -\name{.validate_character_scalar} -\alias{.validate_character_scalar} -\title{Ensure that an Argument is Length-1 Character} -\usage{ -.validate_character_scalar(parameter, parameter_name, valid_values) -} -\arguments{ -\item{parameter}{The argument to test.} - -\item{parameter_name}{The argument's name. Eventually this should be -automatically handled through rlang or something, in theory.} - -\item{valid_values}{(optional) Expected values of the parameter.} -} -\value{ -The parameter if it is character-scalar. -} -\description{ -Ensure that an Argument is Length-1 Character -} -\keyword{internal} diff --git a/man/dot-validate_values.Rd b/man/dot-validate_values.Rd deleted file mode 100644 index 4e83b67..0000000 --- a/man/dot-validate_values.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/messaging.R -\name{.validate_values} -\alias{.validate_values} -\title{Ensure that an Argument has Certain Values} -\usage{ -.validate_values(parameter, parameter_name, valid_values) -} -\arguments{ -\item{parameter}{The argument to test.} - -\item{parameter_name}{The argument's name. Eventually this should be -automatically handled through rlang or something, in theory.} - -\item{valid_values}{(optional) Expected values of the parameter.} -} -\value{ -The parameter. -} -\description{ -Ensure that an Argument has Certain Values -} -\keyword{internal} diff --git a/man/req_has_cookie.Rd b/man/req_has_cookie.Rd index a32146c..da95624 100644 --- a/man/req_has_cookie.Rd +++ b/man/req_has_cookie.Rd @@ -42,14 +42,15 @@ req_has_cookie( } ) -# Specify an action to detect a cookie named "mycookie" that has N -# characters. This would make more sense in a case where validation_fn isn't -# an anonymous function. +# Specify an action to detect a cookie named "mycookie" that has a +# variable-defined number of characters. +expect_n_chars <- function(x, N) { + nchar(x) == N +} +my_N <- 27 # Perhaps set by an environment variable. req_has_cookie( cookie_name = "mycookie", - validation_fn = function(cookie_value, N) { - nchar(cookie_value) == N - }, - N = 27 + validation_fn = expect_n_chars, + N = my_N ) } diff --git a/tests/testthat/test-action-cookie.R b/tests/testthat/test-action-cookie.R index e8ce18b..0c9f4b1 100644 --- a/tests/testthat/test-action-cookie.R +++ b/tests/testthat/test-action-cookie.R @@ -120,20 +120,16 @@ test_that("req_has_cookie works.", { }) test_that("req_has_cookie errors cleanly.", { - expect_error( - req_has_cookie(), - "no default" - ) expect_error( req_has_cookie(NULL), - "is missing" + class = "scenes_error_character_scalar" ) expect_error( req_has_cookie(letters), - "26 values" + class = "scenes_error_character_scalar" ) expect_error( req_has_cookie(1), - " vector" + class = "scenes_error_character_scalar" ) }) diff --git a/tests/testthat/test-action-method.R b/tests/testthat/test-action-method.R index c5c54f3..0fbb0ea 100644 --- a/tests/testthat/test-action-method.R +++ b/tests/testthat/test-action-method.R @@ -98,25 +98,6 @@ test_that("req_uses_method works.", { expect_true(result_post2n$check_fn(request_other)) }) -test_that("req_uses_method errors meaningfully.", { - expect_error( - req_uses_method(), - "0 values" - ) - expect_error( - req_uses_method(NULL), - "0 values" - ) - expect_error( - req_uses_method(letters), - "26 values" - ) - expect_error( - req_uses_method("bad_method"), - "Unknown" - ) -}) - test_that("req_uses_get works.", { positive <- req_uses_get() negative <- req_uses_get(negate = TRUE) diff --git a/tests/testthat/test-action-query.R b/tests/testthat/test-action-query.R index 7a26eb7..c45a14e 100644 --- a/tests/testthat/test-action-query.R +++ b/tests/testthat/test-action-query.R @@ -90,20 +90,16 @@ test_that("req_has_query works.", { }) test_that("req_has_query errors cleanly.", { - expect_error( - req_has_query(), - "no default" - ) expect_error( req_has_query(NULL), - "is missing" + class = "scenes_error_character_scalar" ) expect_error( req_has_query(letters), - "26 values" + class = "scenes_error_character_scalar" ) expect_error( req_has_query(1), - " vector" + class = "scenes_error_character_scalar" ) }) From be95e993381e0b966c749ddd699f63dbbe3d182b Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Mon, 5 Feb 2024 12:44:36 -0600 Subject: [PATCH 4/5] Document shiny_scene class. --- R/change.R | 6 +++--- R/set.R | 25 +++++++++++++++---------- man/dot-new_shiny_scene.Rd | 3 +-- man/set_scene.Rd | 6 +++--- man/shiny_scene-class.Rd | 14 ++++++++++++++ tests/testthat/test-change.R | 2 +- 6 files changed, 37 insertions(+), 19 deletions(-) create mode 100644 man/shiny_scene-class.Rd diff --git a/R/change.R b/R/change.R index f32e4f6..68b68bb 100644 --- a/R/change.R +++ b/R/change.R @@ -1,9 +1,9 @@ #' Choose Between Scenes #' #' Specify a function that uses actions and the request object to choose which -#' Shiny UI to server. +#' Shiny UI to serve. #' -#' @param ... One or more `shiny_scene` objects. +#' @param ... One or more [`shiny_scenes`][shiny_scene-class]. #' @param fall_through A ui to display if no scenes are valid. The #' default value, [default_ui()], returns an HTTP 422 status code indicating #' that the request cannot be processed. @@ -31,7 +31,7 @@ change_scene <- function(..., fall_through = default_ui()) { if (!length(scenes)) { cli::cli_warn( "No scene provided. All users will see the fall_through ui.", - class = "no_scenes" + class = "scenes_warning_no_scenes" ) } diff --git a/R/set.R b/R/set.R index d7b5de4..2cd056e 100644 --- a/R/set.R +++ b/R/set.R @@ -1,12 +1,12 @@ #' Link a UI to Required Actions #' -#' A scene is a shiny ui and the actions that trigger it. +#' Define a [`shiny_scene`][shiny_scene-class] by linking a UI to zero or more +#' [`scene_action`][scene_action-class] requirements. #' #' @param ui A shiny ui. #' @param ... Zero or more [`scene_actions`][scene_action-class]. #' -#' @return A `shiny_scene` object, which is a list with components `ui` and -#' `actions`. +#' @return A [`shiny_scene`][shiny_scene-class]. #' @export #' @examples #' scene1 <- set_scene( @@ -21,12 +21,7 @@ #' scene2 set_scene <- function(ui, ...) { actions <- rlang::list2(...) - - # Standardize zero-length-vector actions and NULL actions to be the same - # thing. if (!length(actions)) actions <- NULL - - # Wrap them up and return them. return( .new_shiny_scene( ui = ui, @@ -40,8 +35,7 @@ set_scene <- function(ui, ...) { #' @param ui The ui to return for this set of actions. #' @param actions Zero or more actions required in order to invoke this ui. #' -#' @return A `shiny_scene` object, which is a `list` with components `ui` and -#' `actions`. +#' @return A [`shiny_scene`][shiny_scene-class]. #' @keywords internal .new_shiny_scene <- function(ui, actions) { return( @@ -54,3 +48,14 @@ set_scene <- function(ui, ...) { ) ) } + +#' `shiny_scene` class +#' +#' @description A `shiny_scene` object is a `list` with components `ui` and +#' `actions`. It is used to define what should display in a Shiny app in +#' different scenarios. +#' +#' @name shiny_scene-class +#' @aliases shiny_scene +#' @seealso [set_scene()] +NULL diff --git a/man/dot-new_shiny_scene.Rd b/man/dot-new_shiny_scene.Rd index 316ba1b..18d7be7 100644 --- a/man/dot-new_shiny_scene.Rd +++ b/man/dot-new_shiny_scene.Rd @@ -12,8 +12,7 @@ \item{actions}{Zero or more actions required in order to invoke this ui.} } \value{ -A \code{shiny_scene} object, which is a \code{list} with components \code{ui} and -\code{actions}. +A \code{\link[=shiny_scene-class]{shiny_scene}}. } \description{ Structure a Shiny Scene diff --git a/man/set_scene.Rd b/man/set_scene.Rd index 4e9f432..a81bb52 100644 --- a/man/set_scene.Rd +++ b/man/set_scene.Rd @@ -12,11 +12,11 @@ set_scene(ui, ...) \item{...}{Zero or more \code{\link[=scene_action-class]{scene_actions}}.} } \value{ -A \code{shiny_scene} object, which is a list with components \code{ui} and -\code{actions}. +A \code{\link[=shiny_scene-class]{shiny_scene}}. } \description{ -A scene is a shiny ui and the actions that trigger it. +Define a \code{\link[=shiny_scene-class]{shiny_scene}} by linking a UI to zero or more +\code{\link[=scene_action-class]{scene_action}} requirements. } \examples{ scene1 <- set_scene( diff --git a/man/shiny_scene-class.Rd b/man/shiny_scene-class.Rd new file mode 100644 index 0000000..ebbf293 --- /dev/null +++ b/man/shiny_scene-class.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/set.R +\name{shiny_scene-class} +\alias{shiny_scene-class} +\alias{shiny_scene} +\title{\code{shiny_scene} class} +\description{ +A \code{shiny_scene} object is a \code{list} with components \code{ui} and +\code{actions}. It is used to define what should display in a Shiny app in +different scenarios. +} +\seealso{ +\code{\link[=set_scene]{set_scene()}} +} diff --git a/tests/testthat/test-change.R b/tests/testthat/test-change.R index 420e399..dfa0db2 100644 --- a/tests/testthat/test-change.R +++ b/tests/testthat/test-change.R @@ -2,7 +2,7 @@ test_that("Basic scene change validation works.", { expect_warning( change_scene(), "No scene provided", - class = "no_scenes" + class = "scenes_warning_no_scenes" ) }) From 6a050f37c5981c7d1815afbbcbab58d0abef7680 Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Mon, 5 Feb 2024 13:20:24 -0600 Subject: [PATCH 5/5] Refactor change.R --- NAMESPACE | 1 + R/change.R | 94 ++++++++++++------------------------ R/scenes-package.R | 1 + man/change_scene.Rd | 6 +-- man/dot-parse_ui.Rd | 3 +- tests/testthat/test-change.R | 8 --- 6 files changed, 37 insertions(+), 76 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0126bf6..a564fbf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,3 +9,4 @@ export(req_uses_get) export(req_uses_method) export(req_uses_post) export(set_scene) +importFrom(rlang,"%||%") diff --git a/R/change.R b/R/change.R index 68b68bb..d676849 100644 --- a/R/change.R +++ b/R/change.R @@ -25,56 +25,34 @@ #' scene2 #' ) #' ui -change_scene <- function(..., fall_through = default_ui()) { +change_scene <- function(..., fall_through = default_ui) { scenes <- rlang::list2(...) + .multi_scene_ui <- .create_multi_scene_ui(scenes, fall_through) + attr(.multi_scene_ui, "http_methods_supported") <- .compile_methods(scenes) + return(.multi_scene_ui) +} - if (!length(scenes)) { - cli::cli_warn( - "No scene provided. All users will see the fall_through ui.", - class = "scenes_warning_no_scenes" - ) - } - - # Make sure the scenes object is "set" as far as this function is concerned. +.create_multi_scene_ui <- function(scenes, fall_through) { force(scenes) - - # This is covered but covr doesn't grok this. - + # This is covered but covr doesn't grok that it is. + # # nocov start - .multi_scene_ui <- function(request) { - # Loop through the scenes, in order. If one passes, process it and return - # it. The structure here is partially inspired by purrr::detect, at least - # in that it made it feel ok to do this with a for loop that we escape - # from. - for (scene in scenes) { - if ( - # A scene with no actions always triggers if we get to it. - !length(scene$actions) || - # This seems backwards, but isn't! scene$actions is a list of actions, - # each of which has a function, so we're taking each function, and - # using it to test the request. - purrr::every( - scene$actions, - ~ .x$check_fn(request) - ) - ) { - return( - .parse_ui(scene$ui, request) - ) + return( + function(request) { + # Structure partially inspired by purrr::detect, at least in that it made + # it feel ok to do this with a for loop from which we escape. + for (scene in scenes) { + if ( + !length(scene$actions) || + purrr::every(scene$actions, ~ .x$check_fn(request)) + ) { + return(.parse_ui(scene$ui, request)) + } } + return(.parse_ui(fall_through, request)) } - - # If nothing succeeded, fall through. - return(.parse_ui(fall_through, request)) - } + ) # nocov end - - # Extract method information from the actions. - methods <- .compile_methods(scenes) - - attr(.multi_scene_ui, "http_methods_supported") <- methods - - return(.multi_scene_ui) } #' Find Methods Used by Actions @@ -84,35 +62,23 @@ change_scene <- function(..., fall_through = default_ui()) { #' @return A character vector of methods accepted by those scenes. #' @keywords internal .compile_methods <- function(scenes) { - # Pull out the actions. We don't care which scene each action came from, so we - # flatten that level. - actions <- purrr::flatten(purrr::map(scenes, "actions")) - - # Extract the methods from inside each action. - methods <- unique( - unlist( - purrr::map(actions, "methods") - ) - ) - - # If there aren't any actions methods can be NULL at this point, so fix that. - if (!length(methods)) { - methods <- "GET" - } + return(.extract_methods(scenes) %||% "GET") +} - return(methods) +.extract_methods <- function(scenes) { + actions <- purrr::flatten(purrr::map(scenes, "actions")) + return(unique(unlist(purrr::map(actions, "methods")))) } #' Prepare a Shiny UI for Display #' -#' @param ui A function defining the UI of a Shiny app, or a [shiny::tagList()]. +#' @param ui A 0- or 1-argument function defining the UI of a Shiny app, or a +#' [shiny::tagList()]. #' @param request The shiny request object. #' #' @return A shiny ui as a [shiny::tagList()]. #' @keywords internal .parse_ui <- function(ui, request) { - # ui can be a tagList, a 0-argument function, or a 1-argument function. Deal - # with those. if (is.function(ui)) { if (length(formals(ui))) { ui <- ui(request) @@ -135,9 +101,9 @@ change_scene <- function(..., fall_through = default_ui()) { #' default_ui() default_ui <- function() { cli::cli_warn( - "No ui specified for this request. Loading default ui." + "No ui specified for this request. Loading default ui.", + class = "scenes_warning_default_ui" ) - shiny::httpResponse( status = 422, content_type = "text/plain", diff --git a/R/scenes-package.R b/R/scenes-package.R index 9aa1923..e697097 100644 --- a/R/scenes-package.R +++ b/R/scenes-package.R @@ -2,6 +2,7 @@ "_PACKAGE" ## usethis namespace: start +#' @importFrom rlang %||% ## usethis namespace: end NULL diff --git a/man/change_scene.Rd b/man/change_scene.Rd index 28615cb..c30aa0a 100644 --- a/man/change_scene.Rd +++ b/man/change_scene.Rd @@ -4,10 +4,10 @@ \alias{change_scene} \title{Choose Between Scenes} \usage{ -change_scene(..., fall_through = default_ui()) +change_scene(..., fall_through = default_ui) } \arguments{ -\item{...}{One or more \code{shiny_scene} objects.} +\item{...}{One or more \code{\link[=shiny_scene-class]{shiny_scenes}}.} \item{fall_through}{A ui to display if no scenes are valid. The default value, \code{\link[=default_ui]{default_ui()}}, returns an HTTP 422 status code indicating @@ -18,7 +18,7 @@ A function that processes the request object to deliver a Shiny ui. } \description{ Specify a function that uses actions and the request object to choose which -Shiny UI to server. +Shiny UI to serve. } \examples{ scene1 <- set_scene( diff --git a/man/dot-parse_ui.Rd b/man/dot-parse_ui.Rd index 78bf785..d178cb3 100644 --- a/man/dot-parse_ui.Rd +++ b/man/dot-parse_ui.Rd @@ -7,7 +7,8 @@ .parse_ui(ui, request) } \arguments{ -\item{ui}{A function defining the UI of a Shiny app, or a \code{\link[shiny:reexports]{shiny::tagList()}}.} +\item{ui}{A 0- or 1-argument function defining the UI of a Shiny app, or a +\code{\link[shiny:reexports]{shiny::tagList()}}.} \item{request}{The shiny request object.} } diff --git a/tests/testthat/test-change.R b/tests/testthat/test-change.R index dfa0db2..db89cd6 100644 --- a/tests/testthat/test-change.R +++ b/tests/testthat/test-change.R @@ -1,11 +1,3 @@ -test_that("Basic scene change validation works.", { - expect_warning( - change_scene(), - "No scene provided", - class = "scenes_warning_no_scenes" - ) -}) - test_that("Scene changing works in the most basic case.", { test_result <- change_scene( set_scene(ui = "default ui")