From bad88da6f905df545fdf4a1b5616604a16abb5d9 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:11:37 +0100 Subject: [PATCH 01/21] add gather_fails functions --- R/gather_fails.R | 170 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 R/gather_fails.R diff --git a/R/gather_fails.R b/R/gather_fails.R new file mode 100644 index 0000000000..e5c6a08dd4 --- /dev/null +++ b/R/gather_fails.R @@ -0,0 +1,170 @@ + +#' send input validation messages to output +#' +#' Captures messages from `InputValidator` objects and collates them +#' into one message passed to `validate`. +#' +#' `shiny::validate` is used to withhold rendering of an output element until +#' certain conditions are met and a print a validation message in place +#' of the output element. +#' `shinyvalidate::InputValidator` allows to validate input elements +#' and display specific messages in their respective input widgets. +#' This function is a hybrid solution. Given an `InputValidator` object, +#' it extracts messages from inputs that fail validation and places them all in one +#' validation message that is passed to a `validate`/`need` call. +#' This way the input validator messages are repeated in the output. +#' +#' \code{gather_fails} accepts one `InputValidator` +#' and can add a header to its validation messages. +#' \code{gather_fails_com} accepts an arbitrary number of `InputValidator`s +#' and prints all messages together under one header. +#' \code{gather_fails_grp} accepts a \strong{list} of `InputValidator`s +#' and prints messages in groups. If elements of \code{validators} are named, +#' the names are used as headers for their respective message groups. +#' +#' +#' @name gather_fails +#' +#' @param iv object of class `InputValidator` +#' @param header `character(1)` optional generic validation message +#' @param ... for \code{gather_fails} and \code{gather_fails_grp} arguments passed to `shiny::validate`\cr +#' for \code{gather_fails_com} any number of `InputValidator` objects +#' @param validators optionally named `list` of `InputValidator` objects, see \code{Details} +#' +#' @return +#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. +#' +#' @seealso \code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} +#' +#' @examples +#' library(shiny) +#' library(shinyvalidate) +#' +#' ui <- fluidPage( +#' selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), +#' sidebarLayout( +#' sidebarPanel( +#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), +#' selectInput("number", "select a number:", 1:6), +#' br(), +#' selectInput("color", "select a color:", +#' c("black", "indianred2", "springgreen2", "cornflowerblue"), +#' multiple = TRUE), +#' sliderInput("size", "select point size:", +#' min = 0.1, max = 4, value = 0.25) +#' ), +#' mainPanel(plotOutput('plot')) +#' ) +#' ) +#' +#' server <- function(input, output) { +#' # set up input validation +#' iv <- InputValidator$new() +#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) +#' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") +#' iv$enable() +#' # more input validation +#' iv_par <- InputValidator$new() +#' iv_par$add_rule("color", sv_required(message = "choose a color")) +#' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") +#' iv_par$add_rule("size", +#' sv_between(left = 0.5, right = 3, +#' message_fmt = "choose a value between {left} and {right}")) +#' iv_par$enable() +#' +#' output$plot <- renderPlot({ +#' # validate output +#' switch(input[["method"]], +#' "hierarchical" = { +#' gather_fails(iv) +#' gather_fails(iv_par, "Set proper graphical parameters") +#' }, +#' "combined" = gather_fails_com(iv, iv_par), +#' "grouped" = gather_fails_grp(list( +#' "Some inputs require attention" = iv, +#' "Set proper graphical parameters" = iv_par +#' ))) +#' +#' plot(eruptions ~ waiting, faithful, las = 1, pch = 16, +#' col = input[["color"]], cex = input[["size"]]) +#' }) +#' } +#' +#' if (interactive()) { +#' shinyApp(ui, server) +#' } + + +#' @rdname gather_fails +#' @export +gather_fails <- function(iv, header = "Some inputs require attention", ...) { + checkmate::assert_class(iv, "InputValidator") + checkmate::assert_string(header, null.ok = TRUE) + + fail_messages <- gather_messages(iv) + failings <- add_header(fail_messages, header) + + shiny::validate(shiny::need(is.null(failings), failings), ...) +} + + +#' @rdname gather_fails +#' @export +gather_fails_com <- function(..., header = "Some inputs require attention") { + vals <- list(...) + lapply(vals, checkmate::assert_class, "InputValidator") + checkmate::assert_string(header, null.ok = TRUE) + + fail_messages <- unlist(lapply(vals, gather_messages)) + failings <- add_header(fail_messages, header) + + shiny::validate(shiny::need(is.null(failings), failings)) +} + + +#' @rdname gather_fails +#' @export +gather_fails_grp <- function(validators, ...) { + checkmate::assert_list(validators, types = "InputValidator") + + # Since some or all names may be NULL, mapply cannot be used here, a loop is required. + fail_messages <- vector("list", length(validators)) + for (v in seq_along(validators)) { + fail_messages[[v]] <- gather_and_add(validators[[v]], names(validators)[v]) + } + + failings <- unlist(fail_messages) + + shiny::validate(shiny::need(is.null(failings), failings), ...) +} + + +### internal functions + +#' @keywords internal +# internal used by all methods +# collate failing messages from validator +gather_messages <- function(iv) { + status <- iv$validate() + failing_inputs <- Filter(Negate(is.null), status) + unique(lapply(failing_inputs, function(x) x[["message"]])) +} + + +#' @keywords internal +# internal used by all hierarchical and combined methods +# format failing messages with optional header message +add_header <- function(messages, header) { + if (length(messages) > 0L) { + c(paste0(header, "\n"), unlist(messages), "\n") + } else NULL +} + +#' @keywords internal +# collate failing messages with optional header message +# internal used by grouped method +gather_and_add <- function(iv, header) { + fail_messages <- gather_messages(iv) + failings <- add_header(fail_messages, header) + failings +} From 851f9db1def625f67b56e753e80235569975dea1 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:12:13 +0100 Subject: [PATCH 02/21] amend documentation --- DESCRIPTION | 3 +- NAMESPACE | 3 ++ man/gather_fails.Rd | 111 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 man/gather_fails.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 09c791e2b4..45b0ccfb5c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -73,10 +73,11 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.2 Collate: 'dummy_functions.R' 'example_module.R' + 'gather_fails.R' 'get_rcode.R' 'get_rcode_utils.R' 'include_css_js.R' diff --git a/NAMESPACE b/NAMESPACE index fa8a728074..6f6a8cadc9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,9 @@ S3method(ui_nested_tabs,teal_module) S3method(ui_nested_tabs,teal_modules) export("%>%") export(example_module) +export(gather_fails) +export(gather_fails_com) +export(gather_fails_grp) export(get_code_tdata) export(get_join_keys) export(get_metadata) diff --git a/man/gather_fails.Rd b/man/gather_fails.Rd new file mode 100644 index 0000000000..049a4b9cac --- /dev/null +++ b/man/gather_fails.Rd @@ -0,0 +1,111 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gather_fails.R +\name{gather_fails} +\alias{gather_fails} +\alias{gather_fails_com} +\alias{gather_fails_grp} +\title{send input validation messages to output} +\usage{ +gather_fails(iv, header = "Some inputs require attention", ...) + +gather_fails_com(..., header = "Some inputs require attention") + +gather_fails_grp(validators, ...) +} +\arguments{ +\item{iv}{object of class \code{InputValidator}} + +\item{header}{\code{character(1)} optional generic validation message} + +\item{...}{for \code{gather_fails} and \code{gather_fails_grp} arguments passed to \code{shiny::validate}\cr +for \code{gather_fails_com} any number of \code{InputValidator} objects} + +\item{validators}{optionally named \code{list} of \code{InputValidator} objects, see \code{Details}} +} +\value{ +Returns NULL if the final validation call passes and a \code{shiny.silent.error} if it fails. +} +\description{ +Captures messages from \code{InputValidator} objects and collates them +into one message passed to \code{validate}. +} +\details{ +\code{shiny::validate} is used to withhold rendering of an output element until +certain conditions are met and a print a validation message in place +of the output element. +\code{shinyvalidate::InputValidator} allows to validate input elements +and display specific messages in their respective input widgets. +This function is a hybrid solution. Given an \code{InputValidator} object, +it extracts messages from inputs that fail validation and places them all in one +validation message that is passed to a \code{validate}/\code{need} call. +This way the input validator messages are repeated in the output. + +\code{gather_fails} accepts one \code{InputValidator} +and can add a header to its validation messages. +\code{gather_fails_com} accepts an arbitrary number of \code{InputValidator}s +and prints all messages together under one header. +\code{gather_fails_grp} accepts a \strong{list} of \code{InputValidator}s +and prints messages in groups. If elements of \code{validators} are named, +the names are used as headers for their respective message groups. +} +\examples{ +library(shiny) +library(shinyvalidate) + +ui <- fluidPage( + selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), + sidebarLayout( + sidebarPanel( + selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), + selectInput("number", "select a number:", 1:6), + br(), + selectInput("color", "select a color:", + c("black", "indianred2", "springgreen2", "cornflowerblue"), + multiple = TRUE), + sliderInput("size", "select point size:", + min = 0.1, max = 4, value = 0.25) + ), + mainPanel(plotOutput('plot')) + ) +) + +server <- function(input, output) { + # set up input validation + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) \%\% 2L == 1L) "choose an even number") + iv$enable() + # more input validation + iv_par <- InputValidator$new() + iv_par$add_rule("color", sv_required(message = "choose a color")) + iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") + iv_par$add_rule("size", + sv_between(left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}")) + iv_par$enable() + + output$plot <- renderPlot({ + # validate output + switch(input[["method"]], + "hierarchical" = { + gather_fails(iv) + gather_fails(iv_par, "Set proper graphical parameters") + }, + "combined" = gather_fails_com(iv, iv_par), + "grouped" = gather_fails_grp(list( + "Some inputs require attention" = iv, + "Set proper graphical parameters" = iv_par + ))) + + plot(eruptions ~ waiting, faithful, las = 1, pch = 16, + col = input[["color"]], cex = input[["size"]]) + }) +} + +if (interactive()) { + shinyApp(ui, server) +} +} +\seealso{ +\code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} +} From 4320c68151c181e5564f3adfdbd77fd2ab6d3c69 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:12:23 +0100 Subject: [PATCH 03/21] update NEWS --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index d9869d5bfd..a7b21dd762 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # teal 0.12.0.9011 +### New features + +* Added the `gather_fails` function that produces informative error messages in app ouput. + ### Major breaking changes * The use of `datasets` argument in `teal` `modules` has been deprecated and will be removed in a future release. Please use `data` argument instead. `data` is of type `tdata`; see "Creating custom modules" vignettes and function documentation of `teal::new_tdata` for further details. From 55cc6e7bfa5f4d2727d0d3acfb0cbc14e7c42ca0 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 12:52:37 +0100 Subject: [PATCH 04/21] add dependency --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 45b0ccfb5c..5f38b1c199 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Imports: methods, rlang, shinyjs, + shinyvalidate, stats, styler, teal.code (>= 0.2.0), From 444af9a19dda0084a8df544bedc0c7a209849f37 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 17:00:11 +0100 Subject: [PATCH 05/21] add unit tests --- tests/testthat/test-gather_fails.R | 448 +++++++++++++++++++++++++++++ 1 file changed, 448 insertions(+) create mode 100644 tests/testthat/test-gather_fails.R diff --git a/tests/testthat/test-gather_fails.R b/tests/testthat/test-gather_fails.R new file mode 100644 index 0000000000..ce4433d343 --- /dev/null +++ b/tests/testthat/test-gather_fails.R @@ -0,0 +1,448 @@ +library(shiny) +library(shinyvalidate) + + +test_that("invalid arguments raise errors", { + expect_error(gather_files("string")) + expect_error(gather_files_com("string")) + expect_error(gather_files_grp(list("name" = "string"))) +}) + + +test_that("gather_fails: valid inputs produce desired output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails(iv) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 2L + ) + expect_identical(values(), list( + "letter" = input[["letter"]], + "number" = input[["number"]] + )) + }) +}) + +test_that("gather_fails_com: valid inputs produce desired output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails_com(iv) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 2L + ) + expect_identical(values(), list( + "letter" = input[["letter"]], + "number" = input[["number"]] + )) + }) +}) + +test_that("gather_fails_grp: valid inputs produce desired output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails_grp(list(iv)) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 2L + ) + expect_identical(values(), list( + "letter" = input[["letter"]], + "number" = input[["number"]] + )) + }) +}) + + +test_that("gather_fails: invalid inputs raise errors in output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails(iv) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 2L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 1L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 1L + ) + expect_error(values()) + }) +}) + +test_that("gather_fails_com: invalid inputs raise errors in output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails_com(iv) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 2L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 1L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 1L + ) + expect_error(values()) + }) +}) + +test_that("gather_fails_grp: invalid inputs raise errors in output", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + values <- reactive({ + gather_fails_grp(list(iv)) + list( + "letter" = input[["letter"]], + "number" = input[["number"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 2L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "A", + "number" = 1L + ) + expect_error(values()) + }) + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 1L + ) + expect_error(values()) + }) +}) + + +test_that("error message is formatted properly", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + iv_par <- InputValidator$new() + iv_par$add_rule("color", sv_required(message = "choose a color")) + iv_par$add_rule("size", + sv_between(left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}")) + iv_par$enable() + } + + shiny::testServer(server, { + session$setInputs( + "letter" = "a", + "number" = 1L, + "color" = "", + "size" = 0.25 + ) + # check error class + expect_error(gather_fails(iv), class = "shiny.silent.error") + expect_error(gather_fails_com(iv), class = "shiny.silent.error") + expect_error(gather_fails_com(iv, iv_par), class = "shiny.silent.error") + expect_error(gather_fails_grp(list(iv)), class = "shiny.silent.error") + expect_error(gather_fails_grp(list(iv, iv_par)), class = "shiny.silent.error") + + # check error message + errmess <- tryCatch(gather_fails(iv), error = function(e) e$message) + expect_identical(errmess, paste( + c("Some inputs require attention\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_com(iv), error = function(e) e$message) + expect_identical(errmess, paste( + c("Some inputs require attention\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_com(iv, iv_par), error = function(e) e$message) + expect_identical(errmess, paste( + c("Some inputs require attention\n", + "choose a capital letter", + "choose an even number", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_grp(list(iv)), error = function(e) e$message) + expect_identical(errmess, paste( + c("\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_grp(list(iv, iv_par)), error = function(e) e$message) + expect_identical(errmess, paste( + c("\n", + "choose a capital letter", + "choose an even number", + "\n", + "\n", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + # check custom headers + errmess <- tryCatch(gather_fails(iv, "Header message"), error = function(e) e$message) + expect_identical(errmess, paste( + c("Header message\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_com(iv, header = "Header message"), error = function(e) e$message) + expect_identical(errmess, paste( + c("Header message\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_com(iv, iv_par, header = "Header message"), error = function(e) e$message) + expect_identical(errmess, paste( + c("Header message\n", + "choose a capital letter", + "choose an even number", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_grp(list("Header message" = iv)), error = function(e) e$message) + expect_identical(errmess, paste( + c("Header message\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(gather_fails_grp(list("Header message 1" = iv, + "Header message 2" = iv_par)), + error = function(e) e$message) + expect_identical(errmess, paste( + c("Header message 1\n", + "choose a capital letter", + "choose an even number", + "\n", + "Header message 2\n", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + }) +}) + + +test_that("hierarchical validation", { + server <- function(input, output, session) { + iv <- InputValidator$new() + iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") + iv$enable() + iv_par <- InputValidator$new() + iv_par$add_rule("color", sv_required(message = "choose a color")) + iv_par$add_rule("size", + sv_between(left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}")) + iv_par$enable() + + values_h <- reactive({ + gather_fails(iv, header = "Main validator") + gather_fails(iv_par, header = "Graphical validator") + list( + "letter" = input[["letter"]], + "number" = input[["number"]], + "color" = input[["color"]], + "size" = input[["size"]] + ) + }) + values_c <- reactive({ + gather_fails_com(iv, iv_par, header = "Both validators") + list( + "letter" = input[["letter"]], + "number" = input[["number"]], + "color" = input[["color"]], + "size" = input[["size"]] + ) + }) + values_g <- reactive({ + gather_fails_grp(list("Main validator" = iv, "Graphical validator" = iv_par)) + list( + "letter" = input[["letter"]], + "number" = input[["number"]], + "color" = input[["color"]], + "size" = input[["size"]] + ) + }) + } + + shiny::testServer(server, { + session$setInputs( + "method" = "hierarchical", + "letter" = "a", + "number" = 1L, + "color" = "", + "size" = 0.25 + ) + + errmess <- tryCatch(values_h(), error = function(e) e$message) + expect_identical(errmess, paste( + c("Main validator\n", + "choose a capital letter", + "choose an even number", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(values_c(), error = function(e) e$message) + expect_identical(errmess, paste( + c("Both validators\n", + "choose a capital letter", + "choose an even number", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + errmess <- tryCatch(values_g(), error = function(e) e$message) + expect_identical(errmess, paste( + c("Main validator\n", + "choose a capital letter", + "choose an even number", + "\n", + "Graphical validator\n", + "choose a color", + "choose a value between 0.5 and 3", + "\n"), + collapse = "\n")) + + + + }) +}) + + + +# shiny::testServer(server, { +# session$setInputs( +# "method" = "hierarchical", +# "letter" = "a", +# "number" = 1L, +# "color" = "", +# "size" = 0.25 +# ) +# expect_error(gather_fails(iv)) +# +# errmess <- tryCatch(gather_fails(iv), +# error = function(e) e$message +# ) +# expect_identical(errmess, +# paste( +# c("Some inputs require attention\n", +# "choose a capital letter", +# "choose an even number", +# # "choose a color", +# # "choose a value between 0.5 and 3", +# "\n"), +# collapse = "\n")) +# From 4e92db34fc0b044348ab32e1af6b24c17bbcb47c Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 1 Dec 2022 16:03:49 +0000 Subject: [PATCH 06/21] [skip actions] Restyle files --- R/gather_fails.R | 50 ++++++---- tests/testthat/test-gather_fails.R | 151 +++++++++++++++++++---------- 2 files changed, 129 insertions(+), 72 deletions(-) diff --git a/R/gather_fails.R b/R/gather_fails.R index e5c6a08dd4..5979320d7f 100644 --- a/R/gather_fails.R +++ b/R/gather_fails.R @@ -48,12 +48,14 @@ #' selectInput("number", "select a number:", 1:6), #' br(), #' selectInput("color", "select a color:", -#' c("black", "indianred2", "springgreen2", "cornflowerblue"), -#' multiple = TRUE), +#' c("black", "indianred2", "springgreen2", "cornflowerblue"), +#' multiple = TRUE +#' ), #' sliderInput("size", "select point size:", -#' min = 0.1, max = 4, value = 0.25) +#' min = 0.1, max = 4, value = 0.25 +#' ) #' ), -#' mainPanel(plotOutput('plot')) +#' mainPanel(plotOutput("plot")) #' ) #' ) #' @@ -67,26 +69,33 @@ #' iv_par <- InputValidator$new() #' iv_par$add_rule("color", sv_required(message = "choose a color")) #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") -#' iv_par$add_rule("size", -#' sv_between(left = 0.5, right = 3, -#' message_fmt = "choose a value between {left} and {right}")) +#' iv_par$add_rule( +#' "size", +#' sv_between( +#' left = 0.5, right = 3, +#' message_fmt = "choose a value between {left} and {right}" +#' ) +#' ) #' iv_par$enable() #' #' output$plot <- renderPlot({ #' # validate output #' switch(input[["method"]], -#' "hierarchical" = { -#' gather_fails(iv) -#' gather_fails(iv_par, "Set proper graphical parameters") -#' }, -#' "combined" = gather_fails_com(iv, iv_par), -#' "grouped" = gather_fails_grp(list( -#' "Some inputs require attention" = iv, -#' "Set proper graphical parameters" = iv_par -#' ))) +#' "hierarchical" = { +#' gather_fails(iv) +#' gather_fails(iv_par, "Set proper graphical parameters") +#' }, +#' "combined" = gather_fails_com(iv, iv_par), +#' "grouped" = gather_fails_grp(list( +#' "Some inputs require attention" = iv, +#' "Set proper graphical parameters" = iv_par +#' )) +#' ) #' -#' plot(eruptions ~ waiting, faithful, las = 1, pch = 16, -#' col = input[["color"]], cex = input[["size"]]) +#' plot(eruptions ~ waiting, faithful, +#' las = 1, pch = 16, +#' col = input[["color"]], cex = input[["size"]] +#' ) #' }) #' } #' @@ -94,7 +103,6 @@ #' shinyApp(ui, server) #' } - #' @rdname gather_fails #' @export gather_fails <- function(iv, header = "Some inputs require attention", ...) { @@ -157,7 +165,9 @@ gather_messages <- function(iv) { add_header <- function(messages, header) { if (length(messages) > 0L) { c(paste0(header, "\n"), unlist(messages), "\n") - } else NULL + } else { + NULL + } } #' @keywords internal diff --git a/tests/testthat/test-gather_fails.R b/tests/testthat/test-gather_fails.R index ce4433d343..a94c899e4c 100644 --- a/tests/testthat/test-gather_fails.R +++ b/tests/testthat/test-gather_fails.R @@ -214,9 +214,13 @@ test_that("error message is formatted properly", { iv$enable() iv_par <- InputValidator$new() iv_par$add_rule("color", sv_required(message = "choose a color")) - iv_par$add_rule("size", - sv_between(left = 0.5, right = 3, - message_fmt = "choose a value between {left} and {right}")) + iv_par$add_rule( + "size", + sv_between( + left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}" + ) + ) iv_par$enable() } @@ -237,99 +241,132 @@ test_that("error message is formatted properly", { # check error message errmess <- tryCatch(gather_fails(iv), error = function(e) e$message) expect_identical(errmess, paste( - c("Some inputs require attention\n", + c( + "Some inputs require attention\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_com(iv), error = function(e) e$message) expect_identical(errmess, paste( - c("Some inputs require attention\n", + c( + "Some inputs require attention\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_com(iv, iv_par), error = function(e) e$message) expect_identical(errmess, paste( - c("Some inputs require attention\n", + c( + "Some inputs require attention\n", "choose a capital letter", "choose an even number", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_grp(list(iv)), error = function(e) e$message) expect_identical(errmess, paste( - c("\n", + c( + "\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_grp(list(iv, iv_par)), error = function(e) e$message) expect_identical(errmess, paste( - c("\n", + c( + "\n", "choose a capital letter", "choose an even number", "\n", "\n", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) # check custom headers errmess <- tryCatch(gather_fails(iv, "Header message"), error = function(e) e$message) expect_identical(errmess, paste( - c("Header message\n", + c( + "Header message\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_com(iv, header = "Header message"), error = function(e) e$message) expect_identical(errmess, paste( - c("Header message\n", + c( + "Header message\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_com(iv, iv_par, header = "Header message"), error = function(e) e$message) expect_identical(errmess, paste( - c("Header message\n", + c( + "Header message\n", "choose a capital letter", "choose an even number", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(gather_fails_grp(list("Header message" = iv)), error = function(e) e$message) expect_identical(errmess, paste( - c("Header message\n", + c( + "Header message\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) - errmess <- tryCatch(gather_fails_grp(list("Header message 1" = iv, - "Header message 2" = iv_par)), - error = function(e) e$message) + errmess <- tryCatch( + gather_fails_grp(list( + "Header message 1" = iv, + "Header message 2" = iv_par + )), + error = function(e) e$message + ) expect_identical(errmess, paste( - c("Header message 1\n", + c( + "Header message 1\n", "choose a capital letter", "choose an even number", "\n", "Header message 2\n", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) - + "\n" + ), + collapse = "\n" + )) }) }) @@ -342,9 +379,13 @@ test_that("hierarchical validation", { iv$enable() iv_par <- InputValidator$new() iv_par$add_rule("color", sv_required(message = "choose a color")) - iv_par$add_rule("size", - sv_between(left = 0.5, right = 3, - message_fmt = "choose a value between {left} and {right}")) + iv_par$add_rule( + "size", + sv_between( + left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}" + ) + ) iv_par$enable() values_h <- reactive({ @@ -388,36 +429,42 @@ test_that("hierarchical validation", { errmess <- tryCatch(values_h(), error = function(e) e$message) expect_identical(errmess, paste( - c("Main validator\n", + c( + "Main validator\n", "choose a capital letter", "choose an even number", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(values_c(), error = function(e) e$message) expect_identical(errmess, paste( - c("Both validators\n", + c( + "Both validators\n", "choose a capital letter", "choose an even number", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) + "\n" + ), + collapse = "\n" + )) errmess <- tryCatch(values_g(), error = function(e) e$message) expect_identical(errmess, paste( - c("Main validator\n", + c( + "Main validator\n", "choose a capital letter", "choose an even number", "\n", "Graphical validator\n", "choose a color", "choose a value between 0.5 and 3", - "\n"), - collapse = "\n")) - - - + "\n" + ), + collapse = "\n" + )) }) }) From 30bdddbb278ce9169d5f8b1bdc306f6939cd4c72 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 17:20:39 +0100 Subject: [PATCH 07/21] update pkgdown --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index c967bd16cb..2e503a7743 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -52,6 +52,7 @@ reference: - title: Validation functions contents: - starts_with("validate_") + - starts_with("gather_fails") - title: Deprecated functions contents: - get_rcode From 183fca66115f0bf94bc1af85b74194ee20dab4db Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 17:24:14 +0100 Subject: [PATCH 08/21] fix links in docs --- R/gather_fails.R | 2 +- man/gather_fails.Rd | 47 +++++++++++++++++++++++++++------------------ 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/R/gather_fails.R b/R/gather_fails.R index 5979320d7f..038f4ab952 100644 --- a/R/gather_fails.R +++ b/R/gather_fails.R @@ -34,7 +34,7 @@ #' @return #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. #' -#' @seealso \code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} +#' @seealso \code{[shinyvalidate::InputValidator]} \code{[shiny::validate]} #' #' @examples #' library(shiny) diff --git a/man/gather_fails.Rd b/man/gather_fails.Rd index 049a4b9cac..e8c932b925 100644 --- a/man/gather_fails.Rd +++ b/man/gather_fails.Rd @@ -60,12 +60,14 @@ ui <- fluidPage( selectInput("number", "select a number:", 1:6), br(), selectInput("color", "select a color:", - c("black", "indianred2", "springgreen2", "cornflowerblue"), - multiple = TRUE), + c("black", "indianred2", "springgreen2", "cornflowerblue"), + multiple = TRUE + ), sliderInput("size", "select point size:", - min = 0.1, max = 4, value = 0.25) + min = 0.1, max = 4, value = 0.25 + ) ), - mainPanel(plotOutput('plot')) + mainPanel(plotOutput("plot")) ) ) @@ -79,26 +81,33 @@ server <- function(input, output) { iv_par <- InputValidator$new() iv_par$add_rule("color", sv_required(message = "choose a color")) iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color") - iv_par$add_rule("size", - sv_between(left = 0.5, right = 3, - message_fmt = "choose a value between {left} and {right}")) + iv_par$add_rule( + "size", + sv_between( + left = 0.5, right = 3, + message_fmt = "choose a value between {left} and {right}" + ) + ) iv_par$enable() output$plot <- renderPlot({ # validate output switch(input[["method"]], - "hierarchical" = { - gather_fails(iv) - gather_fails(iv_par, "Set proper graphical parameters") - }, - "combined" = gather_fails_com(iv, iv_par), - "grouped" = gather_fails_grp(list( - "Some inputs require attention" = iv, - "Set proper graphical parameters" = iv_par - ))) + "hierarchical" = { + gather_fails(iv) + gather_fails(iv_par, "Set proper graphical parameters") + }, + "combined" = gather_fails_com(iv, iv_par), + "grouped" = gather_fails_grp(list( + "Some inputs require attention" = iv, + "Set proper graphical parameters" = iv_par + )) + ) - plot(eruptions ~ waiting, faithful, las = 1, pch = 16, - col = input[["color"]], cex = input[["size"]]) + plot(eruptions ~ waiting, faithful, + las = 1, pch = 16, + col = input[["color"]], cex = input[["size"]] + ) }) } @@ -107,5 +116,5 @@ if (interactive()) { } } \seealso{ -\code{\link{[shinyvalidate::InputValidator]}} \code{\link{[shiny::validate]}} +\code{[shinyvalidate::InputValidator]} \code{[shiny::validate]} } From 2d7d43a2445e0e3c5f9cedd3fa3198f224c3a73f Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 17:30:39 +0100 Subject: [PATCH 09/21] lintr --- _pkgdown.yml | 24 ++++++++++++------------ tests/testthat/test-gather_fails.R | 26 -------------------------- 2 files changed, 12 insertions(+), 38 deletions(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2e503a7743..0b9c474502 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -10,18 +10,18 @@ navbar: href: https://github.com/insightsengineering/teal articles: -- title: Articles - navbar: ~ - contents: - - teal - - including-general-data-in-teal - - including-adam-data-in-teal - - including-mae-data-in-teal - - preprocessing-data - - creating-custom-modules - - adding-support-for-reporting - - teal-options - - teal-bs-themes + - title: Articles + navbar: ~ + contents: + - teal + - including-general-data-in-teal + - including-adam-data-in-teal + - including-mae-data-in-teal + - preprocessing-data + - creating-custom-modules + - adding-support-for-reporting + - teal-options + - teal-bs-themes reference: - title: Teal Core Functions diff --git a/tests/testthat/test-gather_fails.R b/tests/testthat/test-gather_fails.R index a94c899e4c..479442026a 100644 --- a/tests/testthat/test-gather_fails.R +++ b/tests/testthat/test-gather_fails.R @@ -467,29 +467,3 @@ test_that("hierarchical validation", { )) }) }) - - - -# shiny::testServer(server, { -# session$setInputs( -# "method" = "hierarchical", -# "letter" = "a", -# "number" = 1L, -# "color" = "", -# "size" = 0.25 -# ) -# expect_error(gather_fails(iv)) -# -# errmess <- tryCatch(gather_fails(iv), -# error = function(e) e$message -# ) -# expect_identical(errmess, -# paste( -# c("Some inputs require attention\n", -# "choose a capital letter", -# "choose an even number", -# # "choose a color", -# # "choose a value between 0.5 and 3", -# "\n"), -# collapse = "\n")) -# From 5ea79ce3e3ddbbe01e0c971c57febdef8276fcfd Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 1 Dec 2022 17:34:27 +0100 Subject: [PATCH 10/21] spellcheck --- NEWS.md | 2 +- inst/WORDLIST | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index a7b21dd762..b4c5c0e140 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ ### New features -* Added the `gather_fails` function that produces informative error messages in app ouput. +* Added the `gather_fails` function that produces informative error messages in app output. ### Major breaking changes diff --git a/inst/WORDLIST b/inst/WORDLIST index c57542e24e..979afdc5d4 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -37,3 +37,4 @@ ui repo Forkers README +validator From 0d93eec2983a9d516c34c46a059c410303d773bd Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 2 Dec 2022 16:48:00 +0100 Subject: [PATCH 11/21] move shinyvalidate to Suggests --- DESCRIPTION | 2 +- tests/testthat/test-gather_fails.R | 149 ++++++++++++++--------------- 2 files changed, 74 insertions(+), 77 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5f38b1c199..c0680f468c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,7 +33,6 @@ Imports: methods, rlang, shinyjs, - shinyvalidate, stats, styler, teal.code (>= 0.2.0), @@ -52,6 +51,7 @@ Suggests: rmarkdown, scda (>= 0.1.5), scda.2022 (>= 0.1.3), + shinyvalidate, testthat (>= 2.0), withr, yaml diff --git a/tests/testthat/test-gather_fails.R b/tests/testthat/test-gather_fails.R index 479442026a..e2fae8e5de 100644 --- a/tests/testthat/test-gather_fails.R +++ b/tests/testthat/test-gather_fails.R @@ -1,21 +1,18 @@ -library(shiny) -library(shinyvalidate) - -test_that("invalid arguments raise errors", { - expect_error(gather_files("string")) - expect_error(gather_files_com("string")) - expect_error(gather_files_grp(list("name" = "string"))) +testthat::test_that("invalid arguments raise errors", { + testthat::expect_error(gather_files("string")) + testthat::expect_error(gather_files_com("string")) + testthat::expect_error(gather_files_grp(list("name" = "string"))) }) -test_that("gather_fails: valid inputs produce desired output", { +testthat::test_that("gather_fails: valid inputs produce desired output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails(iv) list( "letter" = input[["letter"]], @@ -29,20 +26,20 @@ test_that("gather_fails: valid inputs produce desired output", { "letter" = "A", "number" = 2L ) - expect_identical(values(), list( + testthat::expect_identical(values(), list( "letter" = input[["letter"]], "number" = input[["number"]] )) }) }) -test_that("gather_fails_com: valid inputs produce desired output", { +testthat::test_that("gather_fails_com: valid inputs produce desired output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails_com(iv) list( "letter" = input[["letter"]], @@ -56,20 +53,20 @@ test_that("gather_fails_com: valid inputs produce desired output", { "letter" = "A", "number" = 2L ) - expect_identical(values(), list( + testthat::expect_identical(values(), list( "letter" = input[["letter"]], "number" = input[["number"]] )) }) }) -test_that("gather_fails_grp: valid inputs produce desired output", { +testthat::test_that("gather_fails_grp: valid inputs produce desired output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails_grp(list(iv)) list( "letter" = input[["letter"]], @@ -83,7 +80,7 @@ test_that("gather_fails_grp: valid inputs produce desired output", { "letter" = "A", "number" = 2L ) - expect_identical(values(), list( + testthat::expect_identical(values(), list( "letter" = input[["letter"]], "number" = input[["number"]] )) @@ -91,13 +88,13 @@ test_that("gather_fails_grp: valid inputs produce desired output", { }) -test_that("gather_fails: invalid inputs raise errors in output", { +testthat::test_that("gather_fails: invalid inputs raise errors in output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails(iv) list( "letter" = input[["letter"]], @@ -111,31 +108,31 @@ test_that("gather_fails: invalid inputs raise errors in output", { "letter" = "a", "number" = 2L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "A", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "a", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) }) -test_that("gather_fails_com: invalid inputs raise errors in output", { +testthat::test_that("gather_fails_com: invalid inputs raise errors in output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails_com(iv) list( "letter" = input[["letter"]], @@ -149,31 +146,31 @@ test_that("gather_fails_com: invalid inputs raise errors in output", { "letter" = "a", "number" = 2L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "A", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "a", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) }) -test_that("gather_fails_grp: invalid inputs raise errors in output", { +testthat::test_that("gather_fails_grp: invalid inputs raise errors in output", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - values <- reactive({ + values <- shiny::reactive({ gather_fails_grp(list(iv)) list( "letter" = input[["letter"]], @@ -187,36 +184,36 @@ test_that("gather_fails_grp: invalid inputs raise errors in output", { "letter" = "a", "number" = 2L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "A", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) shiny::testServer(server, { session$setInputs( "letter" = "a", "number" = 1L ) - expect_error(values()) + testthat::expect_error(values()) }) }) -test_that("error message is formatted properly", { +testthat::test_that("error message is formatted properly", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - iv_par <- InputValidator$new() - iv_par$add_rule("color", sv_required(message = "choose a color")) + iv_par <- shinyvalidate::InputValidator$new() + iv_par$add_rule("color", shinyvalidate::sv_required(message = "choose a color")) iv_par$add_rule( "size", - sv_between( + shinyvalidate::sv_between( left = 0.5, right = 3, message_fmt = "choose a value between {left} and {right}" ) @@ -232,15 +229,15 @@ test_that("error message is formatted properly", { "size" = 0.25 ) # check error class - expect_error(gather_fails(iv), class = "shiny.silent.error") - expect_error(gather_fails_com(iv), class = "shiny.silent.error") - expect_error(gather_fails_com(iv, iv_par), class = "shiny.silent.error") - expect_error(gather_fails_grp(list(iv)), class = "shiny.silent.error") - expect_error(gather_fails_grp(list(iv, iv_par)), class = "shiny.silent.error") + testthat::expect_error(gather_fails(iv), class = "shiny.silent.error") + testthat::expect_error(gather_fails_com(iv), class = "shiny.silent.error") + testthat::expect_error(gather_fails_com(iv, iv_par), class = "shiny.silent.error") + testthat::expect_error(gather_fails_grp(list(iv)), class = "shiny.silent.error") + testthat::expect_error(gather_fails_grp(list(iv, iv_par)), class = "shiny.silent.error") # check error message errmess <- tryCatch(gather_fails(iv), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Some inputs require attention\n", "choose a capital letter", @@ -251,7 +248,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_com(iv), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Some inputs require attention\n", "choose a capital letter", @@ -262,7 +259,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_com(iv, iv_par), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Some inputs require attention\n", "choose a capital letter", @@ -275,7 +272,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_grp(list(iv)), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "\n", "choose a capital letter", @@ -286,7 +283,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_grp(list(iv, iv_par)), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "\n", "choose a capital letter", @@ -302,7 +299,7 @@ test_that("error message is formatted properly", { # check custom headers errmess <- tryCatch(gather_fails(iv, "Header message"), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Header message\n", "choose a capital letter", @@ -313,7 +310,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_com(iv, header = "Header message"), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Header message\n", "choose a capital letter", @@ -324,7 +321,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_com(iv, iv_par, header = "Header message"), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Header message\n", "choose a capital letter", @@ -337,7 +334,7 @@ test_that("error message is formatted properly", { )) errmess <- tryCatch(gather_fails_grp(list("Header message" = iv)), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Header message\n", "choose a capital letter", @@ -354,7 +351,7 @@ test_that("error message is formatted properly", { )), error = function(e) e$message ) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Header message 1\n", "choose a capital letter", @@ -371,24 +368,24 @@ test_that("error message is formatted properly", { }) -test_that("hierarchical validation", { +testthat::test_that("hierarchical validation", { server <- function(input, output, session) { - iv <- InputValidator$new() - iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() - iv_par <- InputValidator$new() - iv_par$add_rule("color", sv_required(message = "choose a color")) + iv_par <- shinyvalidate::InputValidator$new() + iv_par$add_rule("color", shinyvalidate::sv_required(message = "choose a color")) iv_par$add_rule( "size", - sv_between( + shinyvalidate::sv_between( left = 0.5, right = 3, message_fmt = "choose a value between {left} and {right}" ) ) iv_par$enable() - values_h <- reactive({ + values_h <- shiny::reactive({ gather_fails(iv, header = "Main validator") gather_fails(iv_par, header = "Graphical validator") list( @@ -398,7 +395,7 @@ test_that("hierarchical validation", { "size" = input[["size"]] ) }) - values_c <- reactive({ + values_c <- shiny::reactive({ gather_fails_com(iv, iv_par, header = "Both validators") list( "letter" = input[["letter"]], @@ -407,7 +404,7 @@ test_that("hierarchical validation", { "size" = input[["size"]] ) }) - values_g <- reactive({ + values_g <- shiny::reactive({ gather_fails_grp(list("Main validator" = iv, "Graphical validator" = iv_par)) list( "letter" = input[["letter"]], @@ -428,7 +425,7 @@ test_that("hierarchical validation", { ) errmess <- tryCatch(values_h(), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Main validator\n", "choose a capital letter", @@ -439,7 +436,7 @@ test_that("hierarchical validation", { )) errmess <- tryCatch(values_c(), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Both validators\n", "choose a capital letter", @@ -452,7 +449,7 @@ test_that("hierarchical validation", { )) errmess <- tryCatch(values_g(), error = function(e) e$message) - expect_identical(errmess, paste( + testthat::expect_identical(errmess, paste( c( "Main validator\n", "choose a capital letter", From 794777ff14c36ab91f1496a08c1c098b014a7d4b Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 5 Dec 2022 00:15:00 +0100 Subject: [PATCH 12/21] reduce and rename functions --- DESCRIPTION | 2 +- NAMESPACE | 5 +- NEWS.md | 2 +- R/{gather_fails.R => validate_inputs.R} | 46 ++---- man/{gather_fails.Rd => validate_inputs.Rd} | 39 ++--- ...-gather_fails.R => test-validate_inputs.R} | 145 ++++-------------- 6 files changed, 66 insertions(+), 173 deletions(-) rename R/{gather_fails.R => validate_inputs.R} (77%) rename man/{gather_fails.Rd => validate_inputs.Rd} (72%) rename tests/testthat/{test-gather_fails.R => test-validate_inputs.R} (66%) diff --git a/DESCRIPTION b/DESCRIPTION index c0680f468c..5c469daf13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -78,7 +78,6 @@ RoxygenNote: 7.2.2 Collate: 'dummy_functions.R' 'example_module.R' - 'gather_fails.R' 'get_rcode.R' 'get_rcode_utils.R' 'include_css_js.R' @@ -94,5 +93,6 @@ Collate: 'tdata.R' 'teal.R' 'utils.R' + 'validate_inputs.R' 'validations.R' 'zzz.R' diff --git a/NAMESPACE b/NAMESPACE index 6f6a8cadc9..b8695e1796 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,9 +21,6 @@ S3method(ui_nested_tabs,teal_module) S3method(ui_nested_tabs,teal_modules) export("%>%") export(example_module) -export(gather_fails) -export(gather_fails_com) -export(gather_fails_grp) export(get_code_tdata) export(get_join_keys) export(get_metadata) @@ -43,6 +40,8 @@ export(validate_has_data) export(validate_has_elements) export(validate_has_variable) export(validate_in) +export(validate_inputs) +export(validate_inputs_segregated) export(validate_n_levels) export(validate_no_intersection) export(validate_one_row_per_id) diff --git a/NEWS.md b/NEWS.md index b4c5c0e140..bbf046f70d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ ### New features -* Added the `gather_fails` function that produces informative error messages in app output. +* Added the `validate_inputs` function that produces informative error messages in app output. ### Major breaking changes diff --git a/R/gather_fails.R b/R/validate_inputs.R similarity index 77% rename from R/gather_fails.R rename to R/validate_inputs.R index 038f4ab952..b574d3100b 100644 --- a/R/gather_fails.R +++ b/R/validate_inputs.R @@ -14,21 +14,18 @@ #' validation message that is passed to a `validate`/`need` call. #' This way the input validator messages are repeated in the output. #' -#' \code{gather_fails} accepts one `InputValidator` -#' and can add a header to its validation messages. -#' \code{gather_fails_com} accepts an arbitrary number of `InputValidator`s -#' and prints all messages together under one header. -#' \code{gather_fails_grp} accepts a \strong{list} of `InputValidator`s -#' and prints messages in groups. If elements of \code{validators} are named, +#' \code{validate_inputs} accepts an arbitrary number of `InputValidator`s +#' and prints all messages together, adding one (optional) header. +#' \code{validate_inputs_segregated} accepts a list of `InputValidator`s +#' and prints messages grouped by validator. If elements of \code{validators} are named, #' the names are used as headers for their respective message groups. #' #' -#' @name gather_fails +#' @name validate_inputs #' -#' @param iv object of class `InputValidator` +#' @param ... for \code{validate_inputs} any number of `InputValidator` objects \cr +#' for \code{validate_inputs_segregated} arguments passed to `shiny::validate` #' @param header `character(1)` optional generic validation message -#' @param ... for \code{gather_fails} and \code{gather_fails_grp} arguments passed to `shiny::validate`\cr -#' for \code{gather_fails_com} any number of `InputValidator` objects #' @param validators optionally named `list` of `InputValidator` objects, see \code{Details} #' #' @return @@ -82,11 +79,11 @@ #' # validate output #' switch(input[["method"]], #' "hierarchical" = { -#' gather_fails(iv) -#' gather_fails(iv_par, "Set proper graphical parameters") +#' validate_inputs(iv) +#' validate_inputs(iv_par, "Set proper graphical parameters") #' }, -#' "combined" = gather_fails_com(iv, iv_par), -#' "grouped" = gather_fails_grp(list( +#' "combined" = validate_inputs(iv, iv_par), +#' "grouped" = validate_inputs_segregated(list( #' "Some inputs require attention" = iv, #' "Set proper graphical parameters" = iv_par #' )) @@ -103,22 +100,9 @@ #' shinyApp(ui, server) #' } -#' @rdname gather_fails +#' @rdname validate_inputs #' @export -gather_fails <- function(iv, header = "Some inputs require attention", ...) { - checkmate::assert_class(iv, "InputValidator") - checkmate::assert_string(header, null.ok = TRUE) - - fail_messages <- gather_messages(iv) - failings <- add_header(fail_messages, header) - - shiny::validate(shiny::need(is.null(failings), failings), ...) -} - - -#' @rdname gather_fails -#' @export -gather_fails_com <- function(..., header = "Some inputs require attention") { +validate_inputs <- function(..., header = "Some inputs require attention") { vals <- list(...) lapply(vals, checkmate::assert_class, "InputValidator") checkmate::assert_string(header, null.ok = TRUE) @@ -130,9 +114,9 @@ gather_fails_com <- function(..., header = "Some inputs require attention") { } -#' @rdname gather_fails +#' @rdname validate_inputs #' @export -gather_fails_grp <- function(validators, ...) { +validate_inputs_segregated <- function(validators, ...) { checkmate::assert_list(validators, types = "InputValidator") # Since some or all names may be NULL, mapply cannot be used here, a loop is required. diff --git a/man/gather_fails.Rd b/man/validate_inputs.Rd similarity index 72% rename from man/gather_fails.Rd rename to man/validate_inputs.Rd index e8c932b925..e65daaee98 100644 --- a/man/gather_fails.Rd +++ b/man/validate_inputs.Rd @@ -1,25 +1,20 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gather_fails.R -\name{gather_fails} -\alias{gather_fails} -\alias{gather_fails_com} -\alias{gather_fails_grp} +% Please edit documentation in R/validate_inputs.R +\name{validate_inputs} +\alias{validate_inputs} +\alias{validate_inputs_segregated} \title{send input validation messages to output} \usage{ -gather_fails(iv, header = "Some inputs require attention", ...) +validate_inputs(..., header = "Some inputs require attention") -gather_fails_com(..., header = "Some inputs require attention") - -gather_fails_grp(validators, ...) +validate_inputs_segregated(validators, ...) } \arguments{ -\item{iv}{object of class \code{InputValidator}} +\item{...}{for \code{validate_inputs} any number of \code{InputValidator} objects \cr +for \code{validate_inputs_segregated} arguments passed to \code{shiny::validate}} \item{header}{\code{character(1)} optional generic validation message} -\item{...}{for \code{gather_fails} and \code{gather_fails_grp} arguments passed to \code{shiny::validate}\cr -for \code{gather_fails_com} any number of \code{InputValidator} objects} - \item{validators}{optionally named \code{list} of \code{InputValidator} objects, see \code{Details}} } \value{ @@ -40,12 +35,10 @@ it extracts messages from inputs that fail validation and places them all in one validation message that is passed to a \code{validate}/\code{need} call. This way the input validator messages are repeated in the output. -\code{gather_fails} accepts one \code{InputValidator} -and can add a header to its validation messages. -\code{gather_fails_com} accepts an arbitrary number of \code{InputValidator}s -and prints all messages together under one header. -\code{gather_fails_grp} accepts a \strong{list} of \code{InputValidator}s -and prints messages in groups. If elements of \code{validators} are named, +\code{validate_inputs} accepts an arbitrary number of \code{InputValidator}s +and prints all messages together, adding one (optional) header. +\code{validate_inputs_segregated} accepts a list of \code{InputValidator}s +and prints messages grouped by validator. If elements of \code{validators} are named, the names are used as headers for their respective message groups. } \examples{ @@ -94,11 +87,11 @@ server <- function(input, output) { # validate output switch(input[["method"]], "hierarchical" = { - gather_fails(iv) - gather_fails(iv_par, "Set proper graphical parameters") + validate_inputs(iv) + validate_inputs(iv_par, "Set proper graphical parameters") }, - "combined" = gather_fails_com(iv, iv_par), - "grouped" = gather_fails_grp(list( + "combined" = validate_inputs(iv, iv_par), + "grouped" = validate_inputs_segregated(list( "Some inputs require attention" = iv, "Set proper graphical parameters" = iv_par )) diff --git a/tests/testthat/test-gather_fails.R b/tests/testthat/test-validate_inputs.R similarity index 66% rename from tests/testthat/test-gather_fails.R rename to tests/testthat/test-validate_inputs.R index e2fae8e5de..163fbf9a37 100644 --- a/tests/testthat/test-gather_fails.R +++ b/tests/testthat/test-validate_inputs.R @@ -1,19 +1,18 @@ testthat::test_that("invalid arguments raise errors", { - testthat::expect_error(gather_files("string")) - testthat::expect_error(gather_files_com("string")) - testthat::expect_error(gather_files_grp(list("name" = "string"))) + testthat::expect_error(validate_inputs("string")) + testthat::expect_error(validate_inputs_segregated(list("name" = "string"))) }) -testthat::test_that("gather_fails: valid inputs produce desired output", { +testthat::test_that("validate_inputs: valid inputs produce desired output", { server <- function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() values <- shiny::reactive({ - gather_fails(iv) + validate_inputs(iv) list( "letter" = input[["letter"]], "number" = input[["number"]] @@ -33,41 +32,15 @@ testthat::test_that("gather_fails: valid inputs produce desired output", { }) }) -testthat::test_that("gather_fails_com: valid inputs produce desired output", { - server <- function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) - iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") - iv$enable() - values <- shiny::reactive({ - gather_fails_com(iv) - list( - "letter" = input[["letter"]], - "number" = input[["number"]] - ) - }) - } - - shiny::testServer(server, { - session$setInputs( - "letter" = "A", - "number" = 2L - ) - testthat::expect_identical(values(), list( - "letter" = input[["letter"]], - "number" = input[["number"]] - )) - }) -}) -testthat::test_that("gather_fails_grp: valid inputs produce desired output", { +testthat::test_that("validate_inputs_segregated: valid inputs produce desired output", { server <- function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() values <- shiny::reactive({ - gather_fails_grp(list(iv)) + validate_inputs_segregated(list(iv)) list( "letter" = input[["letter"]], "number" = input[["number"]] @@ -88,14 +61,14 @@ testthat::test_that("gather_fails_grp: valid inputs produce desired output", { }) -testthat::test_that("gather_fails: invalid inputs raise errors in output", { +testthat::test_that("validate_inputs: invalid inputs raise errors in output", { server <- function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() values <- shiny::reactive({ - gather_fails(iv) + validate_inputs(iv) list( "letter" = input[["letter"]], "number" = input[["number"]] @@ -126,52 +99,15 @@ testthat::test_that("gather_fails: invalid inputs raise errors in output", { }) }) -testthat::test_that("gather_fails_com: invalid inputs raise errors in output", { - server <- function(input, output, session) { - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) - iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") - iv$enable() - values <- shiny::reactive({ - gather_fails_com(iv) - list( - "letter" = input[["letter"]], - "number" = input[["number"]] - ) - }) - } - shiny::testServer(server, { - session$setInputs( - "letter" = "a", - "number" = 2L - ) - testthat::expect_error(values()) - }) - shiny::testServer(server, { - session$setInputs( - "letter" = "A", - "number" = 1L - ) - testthat::expect_error(values()) - }) - shiny::testServer(server, { - session$setInputs( - "letter" = "a", - "number" = 1L - ) - testthat::expect_error(values()) - }) -}) - -testthat::test_that("gather_fails_grp: invalid inputs raise errors in output", { +testthat::test_that("validate_inputs_segregated: invalid inputs raise errors in output", { server <- function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number") iv$enable() values <- shiny::reactive({ - gather_fails_grp(list(iv)) + validate_inputs_segregated(list(iv)) list( "letter" = input[["letter"]], "number" = input[["number"]] @@ -229,14 +165,17 @@ testthat::test_that("error message is formatted properly", { "size" = 0.25 ) # check error class - testthat::expect_error(gather_fails(iv), class = "shiny.silent.error") - testthat::expect_error(gather_fails_com(iv), class = "shiny.silent.error") - testthat::expect_error(gather_fails_com(iv, iv_par), class = "shiny.silent.error") - testthat::expect_error(gather_fails_grp(list(iv)), class = "shiny.silent.error") - testthat::expect_error(gather_fails_grp(list(iv, iv_par)), class = "shiny.silent.error") + testthat::expect_error(validate_inputs(iv)) + testthat::expect_error(validate_inputs(iv, iv_par)) + testthat::expect_error(validate_inputs_segregated(list(iv)), class = "shiny.silent.error") + testthat::expect_error(validate_inputs_segregated(list(iv, iv_par)), class = "shiny.silent.error") + testthat::expect_error(validate_inputs_segregated(list(iv), errorClass = "custom.error.class"), + class = "custom.error.class") + testthat::expect_error(validate_inputs_segregated(list(iv, iv_par), errorClass = "custom.error.class"), + class = "custom.error.class") # check error message - errmess <- tryCatch(gather_fails(iv), error = function(e) e$message) + errmess <- tryCatch(validate_inputs(iv), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "Some inputs require attention\n", @@ -247,18 +186,7 @@ testthat::test_that("error message is formatted properly", { collapse = "\n" )) - errmess <- tryCatch(gather_fails_com(iv), error = function(e) e$message) - testthat::expect_identical(errmess, paste( - c( - "Some inputs require attention\n", - "choose a capital letter", - "choose an even number", - "\n" - ), - collapse = "\n" - )) - - errmess <- tryCatch(gather_fails_com(iv, iv_par), error = function(e) e$message) + errmess <- tryCatch(validate_inputs(iv, iv_par), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "Some inputs require attention\n", @@ -271,7 +199,7 @@ testthat::test_that("error message is formatted properly", { collapse = "\n" )) - errmess <- tryCatch(gather_fails_grp(list(iv)), error = function(e) e$message) + errmess <- tryCatch(validate_inputs_segregated(list(iv)), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "\n", @@ -282,7 +210,7 @@ testthat::test_that("error message is formatted properly", { collapse = "\n" )) - errmess <- tryCatch(gather_fails_grp(list(iv, iv_par)), error = function(e) e$message) + errmess <- tryCatch(validate_inputs_segregated(list(iv, iv_par)), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "\n", @@ -298,18 +226,7 @@ testthat::test_that("error message is formatted properly", { )) # check custom headers - errmess <- tryCatch(gather_fails(iv, "Header message"), error = function(e) e$message) - testthat::expect_identical(errmess, paste( - c( - "Header message\n", - "choose a capital letter", - "choose an even number", - "\n" - ), - collapse = "\n" - )) - - errmess <- tryCatch(gather_fails_com(iv, header = "Header message"), error = function(e) e$message) + errmess <- tryCatch(validate_inputs(iv, header = "Header message"), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "Header message\n", @@ -320,7 +237,7 @@ testthat::test_that("error message is formatted properly", { collapse = "\n" )) - errmess <- tryCatch(gather_fails_com(iv, iv_par, header = "Header message"), error = function(e) e$message) + errmess <- tryCatch(validate_inputs(iv, iv_par, header = "Header message"), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "Header message\n", @@ -333,7 +250,7 @@ testthat::test_that("error message is formatted properly", { collapse = "\n" )) - errmess <- tryCatch(gather_fails_grp(list("Header message" = iv)), error = function(e) e$message) + errmess <- tryCatch(validate_inputs_segregated(list("Header message" = iv)), error = function(e) e$message) testthat::expect_identical(errmess, paste( c( "Header message\n", @@ -345,7 +262,7 @@ testthat::test_that("error message is formatted properly", { )) errmess <- tryCatch( - gather_fails_grp(list( + validate_inputs_segregated(list( "Header message 1" = iv, "Header message 2" = iv_par )), @@ -368,7 +285,7 @@ testthat::test_that("error message is formatted properly", { }) -testthat::test_that("hierarchical validation", { +testthat::test_that("different validation modes produce proper messages", { server <- function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("letter", shinyvalidate::sv_in_set(LETTERS, "choose a capital letter")) @@ -386,8 +303,8 @@ testthat::test_that("hierarchical validation", { iv_par$enable() values_h <- shiny::reactive({ - gather_fails(iv, header = "Main validator") - gather_fails(iv_par, header = "Graphical validator") + validate_inputs(iv, header = "Main validator") + validate_inputs(iv_par, header = "Graphical validator") list( "letter" = input[["letter"]], "number" = input[["number"]], @@ -396,7 +313,7 @@ testthat::test_that("hierarchical validation", { ) }) values_c <- shiny::reactive({ - gather_fails_com(iv, iv_par, header = "Both validators") + validate_inputs(iv, iv_par, header = "Both validators") list( "letter" = input[["letter"]], "number" = input[["number"]], @@ -405,7 +322,7 @@ testthat::test_that("hierarchical validation", { ) }) values_g <- shiny::reactive({ - gather_fails_grp(list("Main validator" = iv, "Graphical validator" = iv_par)) + validate_inputs_segregated(list("Main validator" = iv, "Graphical validator" = iv_par)) list( "letter" = input[["letter"]], "number" = input[["number"]], From 2ce23b97d155f33b985767ae01b24d94b1851bbf Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Sun, 4 Dec 2022 23:17:32 +0000 Subject: [PATCH 13/21] [skip actions] Restyle files --- tests/testthat/test-validate_inputs.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-validate_inputs.R b/tests/testthat/test-validate_inputs.R index 163fbf9a37..c555e47dcd 100644 --- a/tests/testthat/test-validate_inputs.R +++ b/tests/testthat/test-validate_inputs.R @@ -170,9 +170,11 @@ testthat::test_that("error message is formatted properly", { testthat::expect_error(validate_inputs_segregated(list(iv)), class = "shiny.silent.error") testthat::expect_error(validate_inputs_segregated(list(iv, iv_par)), class = "shiny.silent.error") testthat::expect_error(validate_inputs_segregated(list(iv), errorClass = "custom.error.class"), - class = "custom.error.class") + class = "custom.error.class" + ) testthat::expect_error(validate_inputs_segregated(list(iv, iv_par), errorClass = "custom.error.class"), - class = "custom.error.class") + class = "custom.error.class" + ) # check error message errmess <- tryCatch(validate_inputs(iv), error = function(e) e$message) From b96e7cb90d6c170f569f064aebeea7de7ca7c22f Mon Sep 17 00:00:00 2001 From: Nikolas Burkoff Date: Tue, 6 Dec 2022 08:50:59 +0000 Subject: [PATCH 14/21] trigger From f5a87ffe14a483a898308da4106782cf4cdf82d9 Mon Sep 17 00:00:00 2001 From: Nikolas Burkoff Date: Tue, 6 Dec 2022 08:51:30 +0000 Subject: [PATCH 15/21] trigger From 7ffefe7e50d5e666bf784f68dbb794c7ef964c19 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 6 Dec 2022 10:31:00 +0100 Subject: [PATCH 16/21] fix example --- R/validate_inputs.R | 6 +++--- man/validate_inputs.Rd | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/validate_inputs.R b/R/validate_inputs.R index b574d3100b..d059c818e1 100644 --- a/R/validate_inputs.R +++ b/R/validate_inputs.R @@ -38,7 +38,7 @@ #' library(shinyvalidate) #' #' ui <- fluidPage( -#' selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), +#' selectInput("method", "validation method", c("sequential", "combined", "grouped")), #' sidebarLayout( #' sidebarPanel( #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), @@ -78,9 +78,9 @@ #' output$plot <- renderPlot({ #' # validate output #' switch(input[["method"]], -#' "hierarchical" = { +#' "sequential" = { #' validate_inputs(iv) -#' validate_inputs(iv_par, "Set proper graphical parameters") +#' validate_inputs(iv_par, header = "Set proper graphical parameters") #' }, #' "combined" = validate_inputs(iv, iv_par), #' "grouped" = validate_inputs_segregated(list( diff --git a/man/validate_inputs.Rd b/man/validate_inputs.Rd index e65daaee98..dbcb00d8d1 100644 --- a/man/validate_inputs.Rd +++ b/man/validate_inputs.Rd @@ -46,7 +46,7 @@ library(shiny) library(shinyvalidate) ui <- fluidPage( - selectInput("method", "validation method", c("hierarchical", "combined", "grouped")), + selectInput("method", "validation method", c("sequential", "combined", "grouped")), sidebarLayout( sidebarPanel( selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), @@ -86,9 +86,9 @@ server <- function(input, output) { output$plot <- renderPlot({ # validate output switch(input[["method"]], - "hierarchical" = { + "sequential" = { validate_inputs(iv) - validate_inputs(iv_par, "Set proper graphical parameters") + validate_inputs(iv_par, header = "Set proper graphical parameters") }, "combined" = validate_inputs(iv, iv_par), "grouped" = validate_inputs_segregated(list( From 8d8c3ac3cc627815b9269a1e6f60d6380e56e107 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 6 Dec 2022 10:31:10 +0100 Subject: [PATCH 17/21] fix pkgdown --- _pkgdown.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 0b9c474502..1898352a18 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -52,7 +52,7 @@ reference: - title: Validation functions contents: - starts_with("validate_") - - starts_with("gather_fails") + - starts_with("validate_inputs") - title: Deprecated functions contents: - get_rcode From bf0b0635e5758321efd3370974b23c8af4062428 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 6 Dec 2022 10:49:21 +0100 Subject: [PATCH 18/21] update documentation --- R/validate_inputs.R | 32 ++++++++++++++++---------------- man/validate_inputs.Rd | 10 +++++----- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/R/validate_inputs.R b/R/validate_inputs.R index d059c818e1..e867380314 100644 --- a/R/validate_inputs.R +++ b/R/validate_inputs.R @@ -1,37 +1,37 @@ #' send input validation messages to output #' -#' Captures messages from `InputValidator` objects and collates them -#' into one message passed to `validate`. +#' Captures messages from \code{InputValidator} objects and collates them +#' into one message passed to \code{validate}. #' -#' `shiny::validate` is used to withhold rendering of an output element until -#' certain conditions are met and a print a validation message in place +#' \code{shiny::validate} is used to withhold rendering of an output element until +#' certain conditions are met and to print a validation message in place #' of the output element. -#' `shinyvalidate::InputValidator` allows to validate input elements -#' and display specific messages in their respective input widgets. -#' This function is a hybrid solution. Given an `InputValidator` object, +#' \code{shinyvalidate::InputValidator} allows to validate input elements +#' and to display specific messages in their respective input widgets. +#' This function is a hybrid solution. Given an \code{InputValidator} object, #' it extracts messages from inputs that fail validation and places them all in one -#' validation message that is passed to a `validate`/`need` call. +#' validation message that is passed to a \code{validate}\code{need} call. #' This way the input validator messages are repeated in the output. #' -#' \code{validate_inputs} accepts an arbitrary number of `InputValidator`s +#' \code{validate_inputs} accepts an arbitrary number of \code{InputValidator}s #' and prints all messages together, adding one (optional) header. -#' \code{validate_inputs_segregated} accepts a list of `InputValidator`s +#' \code{validate_inputs_segregated} accepts a list of \code{InputValidator}s #' and prints messages grouped by validator. If elements of \code{validators} are named, #' the names are used as headers for their respective message groups. #' #' #' @name validate_inputs #' -#' @param ... for \code{validate_inputs} any number of `InputValidator` objects \cr -#' for \code{validate_inputs_segregated} arguments passed to `shiny::validate` -#' @param header `character(1)` optional generic validation message -#' @param validators optionally named `list` of `InputValidator` objects, see \code{Details} +#' @param ... for \code{validate_inputs} any number of \code{InputValidator} objects \cr +#' for \code{validate_inputs_segregated} arguments passed to \code{validate} +#' @param header \code{character(1)} optional generic validation message +#' @param validators optionally named \code{list} of \code{InputValidator} objects, see \code{Details} #' #' @return -#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. +#' Returns NULL if the final validation call passes and a \code{shiny.silent.error} if it fails. #' -#' @seealso \code{[shinyvalidate::InputValidator]} \code{[shiny::validate]} +#' @seealso \code{\link{shinyvalidate::InputValidator}} \code{\link{shiny::validate}} #' #' @examples #' library(shiny) diff --git a/man/validate_inputs.Rd b/man/validate_inputs.Rd index dbcb00d8d1..a0fe173605 100644 --- a/man/validate_inputs.Rd +++ b/man/validate_inputs.Rd @@ -11,7 +11,7 @@ validate_inputs_segregated(validators, ...) } \arguments{ \item{...}{for \code{validate_inputs} any number of \code{InputValidator} objects \cr -for \code{validate_inputs_segregated} arguments passed to \code{shiny::validate}} +for \code{validate_inputs_segregated} arguments passed to \code{validate}} \item{header}{\code{character(1)} optional generic validation message} @@ -26,13 +26,13 @@ into one message passed to \code{validate}. } \details{ \code{shiny::validate} is used to withhold rendering of an output element until -certain conditions are met and a print a validation message in place +certain conditions are met and to print a validation message in place of the output element. \code{shinyvalidate::InputValidator} allows to validate input elements -and display specific messages in their respective input widgets. +and to display specific messages in their respective input widgets. This function is a hybrid solution. Given an \code{InputValidator} object, it extracts messages from inputs that fail validation and places them all in one -validation message that is passed to a \code{validate}/\code{need} call. +validation message that is passed to a \code{validate}\code{need} call. This way the input validator messages are repeated in the output. \code{validate_inputs} accepts an arbitrary number of \code{InputValidator}s @@ -109,5 +109,5 @@ if (interactive()) { } } \seealso{ -\code{[shinyvalidate::InputValidator]} \code{[shiny::validate]} +\code{\link{shinyvalidate::InputValidator}} \code{\link{shiny::validate}} } From 1048640ded9dba36cbdc67b4c7cd9748557f2835 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 6 Dec 2022 10:49:32 +0100 Subject: [PATCH 19/21] update NEWS --- NEWS.md | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index bbf046f70d..dc9efe0162 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,5 @@ # teal 0.12.0.9011 -### New features - -* Added the `validate_inputs` function that produces informative error messages in app output. - ### Major breaking changes * The use of `datasets` argument in `teal` `modules` has been deprecated and will be removed in a future release. Please use `data` argument instead. `data` is of type `tdata`; see "Creating custom modules" vignettes and function documentation of `teal::new_tdata` for further details. @@ -12,6 +8,9 @@ * Due to deprecation of `chunks` in `teal.code`, the `teal` framework now uses their replacement (`qenv`) instead. The documentation in `teal` has been updated to reflect this and custom modules written with `chunks` should be updated to use `qenv`. +### New features + +* Added the `validate_inputs` and `validate_inputs_segregated` functions that produce informative error messages in app output. ### Miscellaneous From b899785c6deb1cfa67959cdd20a61d9b5540e98e Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 6 Dec 2022 12:41:55 +0100 Subject: [PATCH 20/21] fix links in docs --- R/validate_inputs.R | 2 +- man/validate_inputs.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/validate_inputs.R b/R/validate_inputs.R index e867380314..69ab0fee26 100644 --- a/R/validate_inputs.R +++ b/R/validate_inputs.R @@ -31,7 +31,7 @@ #' @return #' Returns NULL if the final validation call passes and a \code{shiny.silent.error} if it fails. #' -#' @seealso \code{\link{shinyvalidate::InputValidator}} \code{\link{shiny::validate}} +#' @seealso [`shinyvalidate::InputValidator`] [`shiny::validate`] #' #' @examples #' library(shiny) diff --git a/man/validate_inputs.Rd b/man/validate_inputs.Rd index a0fe173605..7491b86bcc 100644 --- a/man/validate_inputs.Rd +++ b/man/validate_inputs.Rd @@ -109,5 +109,5 @@ if (interactive()) { } } \seealso{ -\code{\link{shinyvalidate::InputValidator}} \code{\link{shiny::validate}} +\code{\link[shinyvalidate:InputValidator]{shinyvalidate::InputValidator}} \code{\link[shiny:validate]{shiny::validate}} } From e469ba1a7f11aacf91fbee397a26362a2c76af37 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 7 Dec 2022 12:38:33 +0100 Subject: [PATCH 21/21] final review --- NEWS.md | 2 +- R/validate_inputs.R | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index dc9efe0162..fe5d4d35be 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,7 +10,7 @@ ### New features -* Added the `validate_inputs` and `validate_inputs_segregated` functions that produce informative error messages in app output. +* Added the `validate_inputs` and `validate_inputs_segregated` functions transfer input validation messages to app output. ### Miscellaneous diff --git a/R/validate_inputs.R b/R/validate_inputs.R index 69ab0fee26..3e715be0b6 100644 --- a/R/validate_inputs.R +++ b/R/validate_inputs.R @@ -134,7 +134,6 @@ validate_inputs_segregated <- function(validators, ...) { ### internal functions #' @keywords internal -# internal used by all methods # collate failing messages from validator gather_messages <- function(iv) { status <- iv$validate() @@ -144,7 +143,6 @@ gather_messages <- function(iv) { #' @keywords internal -# internal used by all hierarchical and combined methods # format failing messages with optional header message add_header <- function(messages, header) { if (length(messages) > 0L) { @@ -156,7 +154,7 @@ add_header <- function(messages, header) { #' @keywords internal # collate failing messages with optional header message -# internal used by grouped method +# used by segregated method gather_and_add <- function(iv, header) { fail_messages <- gather_messages(iv) failings <- add_header(fail_messages, header)