shinyvalidate improvements

R/gather_fails.R

@@ -0,0 +1,169 @@
+
+#' 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` 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 ... arguments passed to `shiny::validate`
+#' @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_fials
+#' @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_fials
+#' @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_fials
+#' @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
+}

R/tm_g_ae_oview.R

@@ -120,7 +120,8 @@ tm_g_ae_oview <- function(label,
     )
   )
   checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
-  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+  checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3],
+                            .var.name = "plot_height")
   checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
   checkmate::assert_numeric(
     plot_width[1],
@@ -232,14 +233,9 @@ srv_g_ae_oview <- function(id,
   checkmate::assert_class(data, "tdata")
 
   moduleServer(id, function(input, output, session) {
-    iv <- shinyvalidate::InputValidator$new()
-    iv$add_rule("arm_var", shinyvalidate::sv_required())
-    iv$add_rule("flag_var_anl", shinyvalidate::sv_required(
-      message = "Please select at least one flag"
-    ))
-    iv$enable()
 
-    decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width)
+    decorate_output <- srv_g_decorate(id = NULL, plt = plot_r,
+                                      plot_height = plot_height, plot_width = plot_width)
     font_size <- decorate_output$font_size
     pws <- decorate_output$pws
 
@@ -285,34 +281,32 @@ srv_g_ae_oview <- function(id,
 
     output_q <- reactive({
       ANL <- data[[dataname]]() # nolint
-      validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings."))
-      validate(need(
-        is.factor(ANL[[input$arm_var]]),
-        "Selected arm variable needs to be a factor."
-      ))
-      validate(need(input$flag_var_anl, "Please select at least one flag."))
-      iv_comp <- shinyvalidate::InputValidator$new()
-      iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal(
+
+      teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
+
+      # set up and enable input validator(s)
+      iv <- shinyvalidate::InputValidator$new()
+      iv$add_rule("arm_var", shinyvalidate::sv_required(
+        message = "Arm Variable is required"))
+      iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]]))
+        "Arm Var must be a factor variable")
+      iv$add_rule("arm_var", ~ if (length(unique(ANL[[req(.)]])) < 2)
+        "Selected Arm Var has not enough treatments to compare")
+      iv$add_rule("flag_var_anl", shinyvalidate::sv_required(
+        message = "At least one Flag is required"))
+      iv$add_rule("arm_trt", shinyvalidate::sv_not_equal(
         input$arm_ref,
-        message_fmt = "Must not be equal to Control"
-      ))
-      iv_comp$add_rule("arm_ref", shinyvalidate::sv_not_equal(
+        message_fmt = "Control and Treatment must be different"))
+      iv$add_rule("arm_ref", shinyvalidate::sv_not_equal(
         input$arm_trt,
-        message_fmt = "Must not be equal to Treatment"
-      ))
-      iv_comp$enable()
+        message_fmt = "Control and Treatment must be different"))
+      iv$enable()
 
-      validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings."))
-      validate(need(nlevels(ANL[[input$arm_var]]) > 1, "Arm needs to have at least 2 levels"))
-      validate_has_data(ANL, min_nrow = 10)
-      if (all(c(input$arm_trt, input$arm_ref) %in% ANL[[input$arm_var]])) {
-        iv_an <- shinyvalidate::InputValidator$new()
-        iv_an$add_rule("arm_ref", shinyvalidate::sv_in_set(set = ANL[[input$arm_var]]))
-        iv_an$add_rule("arm_trt", shinyvalidate::sv_in_set(set = ANL[[input$arm_var]]))
-        iv_an$enable()
-        validate(need(iv_an$is_valid(), "Misspecification error: please observe red flags in the encodings."))
-      }
-      validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])), "Plot loading"))
+      # collate validator messages
+      gather_fails(iv)
+
+      validate(need(all(c(input$arm_trt, input$arm_ref) %in% unique(ANL[[input$arm_var]])),
+                    "Plot loading"))
 
       q1 <- teal.code::eval_code(
         teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),

R/tm_g_ae_sub.R

@@ -184,9 +184,6 @@ srv_g_ae_sub <- function(id,
   checkmate::assert_class(data, "tdata")
 
   moduleServer(id, function(input, output, session) {
-    iv <- shinyvalidate::InputValidator$new()
-    iv$add_rule("arm_var", shinyvalidate::sv_required())
-    iv$enable()
 
     decorate_output <- srv_g_decorate(
       id = NULL,
@@ -289,40 +286,38 @@ srv_g_ae_sub <- function(id,
     output_q <- reactive({
       ANL <- data[[dataname]]() # nolint
       ADSL <- data[["ADSL"]]() # nolint
-      validate_has_data(ANL, min_nrow = 10)
-      iv_comp <- shinyvalidate::InputValidator$new()
-      iv_comp$add_rule("arm_trt", shinyvalidate::sv_not_equal(
+
+      teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
+
+      # set up and enable input validator(s)
+      iv <- shinyvalidate::InputValidator$new()
+      iv$add_rule("arm_var", shinyvalidate::sv_required(
+        message = "Arm Variable is required"))
+      iv$add_rule("arm_var", ~ if (!is.factor(ANL[[req(.)]]))
+        "Arm Var must be a factor variable, contact developer")
+      iv$add_rule("arm_trt", shinyvalidate::sv_not_equal(
         input$arm_ref,
-        message_fmt = "Must not be equal to Control"
-      ))
-      iv_comp$add_rule("arm_ref", shinyvalidate::sv_not_equal(
+        message_fmt = "Control and Treatment must be different"))
+      iv$add_rule("arm_ref", shinyvalidate::sv_not_equal(
         input$arm_trt,
-        message_fmt = "Must not be equal to Treatment"
-      ))
-      iv_comp$enable()
-      validate(need(iv_comp$is_valid(), "Misspecification error: please observe red flags in the encodings."))
+        message_fmt = "Control and Treatment must be different"))
+      iv$add_rule("groups", shinyvalidate::sv_in_set(
+        names(ANL),
+        message_fmt = "Groups must be a variable in ANL"))
+      iv$add_rule("groups", shinyvalidate::sv_in_set(
+        names(ADSL),
+        message_fmt = "Groups must be a variable in ADSL"))
+      iv$enable()
+
+      # collate validator messages
+      gather_fails(iv)
 
-      validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings."))
-      validate(need(
-        is.factor(ANL[[input$arm_var]]),
-        "Selected arm variable needs to be a factor. Contact the app developer."
-      ))
-      validate(
-        need(
-          all(c(input$arm_trt, input$arm_ref) %in% levels(ADSL[[input$arm_var]])),
-          "Updating treatment and control selections."
-        )
-      )
       validate(
         need(
-          all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])),
-          "The dataset does not contain subjects with AE events from both the control and treatment arms."
-        ),
-        need(
-          all(input$groups %in% names(ANL)) & all(input$groups %in% names(ADSL)),
-          "Check all selected subgroups are columns in ADAE and ADSL."
-        )
-      )
+          all(c(input$arm_trt, input$arm_ref) %in% levels(ADSL[[input$arm_var]])) &&
+            all(c(input$arm_trt, input$arm_ref) %in% levels(ANL[[input$arm_var]])),
+          "Plot loading"
+        ))
 
       group_labels <- lapply(seq_along(input$groups), function(x) {
         items <- input[[sprintf("groups__%s", x)]]