shinyvalidate improvements

DESCRIPTION

@@ -23,15 +23,14 @@ Depends:
     osprey (>= 0.1.15),
     R (>= 3.6),
     shiny,
-    teal (>= 0.12.0)
+    teal (>= 0.12.0.9013)
 Imports:
     checkmate,
     dplyr,
     formatters (>= 0.3.1),
     ggplot2,
     lifecycle,
     logger (>= 0.2.0),
-    purrr,
     shinyvalidate,
     teal.code (>= 0.2.0),
     teal.logger (>= 0.1.1),
@@ -65,4 +64,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.2

NEWS.md

@@ -3,6 +3,9 @@
 * Examples now use `scda.2022` instead of `scda.2021`.
 * Fixed crash in `tm_g_heat_bygrade` when not plotting `Conmed`. 
 * Added validation to `tm_g_spiderplot.R` that checks if there are duplicates in X and Y facet variables.
+* Improved input validation and used the `teal::validate_inputs` mechanism to send validation messages to the output panel.
+* Removed `purrr` from dependencies.
+* Removed redundant formal arguments from add added argument checks to `tm_g_patient_profile`.
 
 ### Breaking changes
 

R/tm_g_ae_oview.R

@@ -120,7 +120,10 @@ 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 +235,35 @@ 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()
+    iv <- reactive({
+      ANL <- data[[dataname]]() # nolint
+
+      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[[.]])) {
+        "Arm Var must be a factor variable"
+      })
+      iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) {
+        "Selected Arm Var must have at least two levels"
+      })
+      iv$add_rule("flag_var_anl", shinyvalidate::sv_required(
+        message = "At least one Flag is required"
+      ))
+      rule_diff <- function(value, other) {
+        if (isTRUE(value == other)) "Control and Treatment must be different"
+      }
+      iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
+      iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
+      iv$enable()
+      iv
+    })
 
-    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 +309,15 @@ 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."))
+
+      teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
+
+      teal::validate_inputs(iv())
+
       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(
-        input$arm_ref,
-        message_fmt = "Must not be equal to Control"
+        input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
+        "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
       ))
-      iv_comp$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."))
-      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"))
 
       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,33 @@ 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()
+    iv <- reactive({
+      ANL <- data[[dataname]]() # nolint
+      ADSL <- data[["ADSL"]]() # nolint
+
+      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[[.]])) {
+        "Arm Var must be a factor variable, contact developer"
+      })
+      rule_diff <- function(value, other) {
+        if (isTRUE(value == other)) "Control and Treatment must be different"
+      }
+      iv$add_rule("arm_trt", rule_diff, other = input$arm_ref)
+      iv$add_rule("arm_ref", rule_diff, other = input$arm_trt)
+      iv$add_rule("groups", shinyvalidate::sv_in_set(
+        names(ANL),
+        message_fmt = sprintf("Groups must be a variable in %s", dataname)
+      ))
+      iv$add_rule("groups", shinyvalidate::sv_in_set(
+        names(ADSL),
+        message_fmt = "Groups must be a variable in ADSL"
+      ))
+      iv$enable()
+      iv
+    })
 
     decorate_output <- srv_g_decorate(
       id = NULL,
@@ -289,40 +313,15 @@ 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(
-        input$arm_ref,
-        message_fmt = "Must not be equal to Control"
-      ))
-      iv_comp$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."))
 
-      validate(need(iv$is_valid(), "Misspecification error: please observe red flags in the encodings."))
+      teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
+
+      teal::validate_inputs(iv())
+
       validate(need(
-        is.factor(ANL[[input$arm_var]]),
-        "Selected arm variable needs to be a factor. Contact the app developer."
+        input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]],
+        "Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?"
       ))
-      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."
-        )
-      )
 
       group_labels <- lapply(seq_along(input$groups), function(x) {
         items <- input[[sprintf("groups__%s", x)]]

R/tm_g_butterfly.R

@@ -81,11 +81,11 @@
 #'       dataname = "ADAE",
 #'       right_var = choices_selected(
 #'         selected = "SEX",
-#'         choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3")
+#'         choices = c("SEX", "ARM", "RACE")
 #'       ),
 #'       left_var = choices_selected(
 #'         selected = "RACE",
-#'         choices = c("DOSE", "SEX", "ARM", "RACE", "flag1", "flag2", "flag3")
+#'         choices = c("SEX", "ARM", "RACE")
 #'       ),
 #'       category_var = choices_selected(selected = "AEBODSYS", choices = c("AEDECOD", "AEBODSYS")),
 #'       color_by_var = choices_selected(selected = "AETOXGR", choices = c("AETOXGR", "None")),
@@ -269,11 +269,35 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe
   checkmate::assert_class(data, "tdata")
 
   moduleServer(id, function(input, output, session) {
-    iv <- shinyvalidate::InputValidator$new()
-    iv$add_rule("category_var", shinyvalidate::sv_required())
-    iv$add_rule("right_var", shinyvalidate::sv_required())
-    iv$add_rule("left_var", shinyvalidate::sv_required())
-    iv$enable()
+    iv <- reactive({
+      ADSL <- data[["ADSL"]]() # nolint
+      ANL <- data[[dataname]]() # nolint
+
+      iv <- shinyvalidate::InputValidator$new()
+      iv$add_rule("category_var", shinyvalidate::sv_required(
+        message = "Category Variable is required"
+      ))
+      iv$add_rule("right_var", shinyvalidate::sv_required(
+        message = "Right Dichotomization Variable is required"
+      ))
+      iv$add_rule("left_var", shinyvalidate::sv_required(
+        message = "Left Dichotomization Variable is required"
+      ))
+      iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) {
+        "Right Dichotomization Variable must be a factor variable, contact developer"
+      })
+      iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) {
+        "Left Dichotomization Variable must be a factor variable, contact developer"
+      })
+      iv$add_rule("right_val", shinyvalidate::sv_required(
+        message = "At least one value of Right Dichotomization Variable must be selected"
+      ))
+      iv$add_rule("left_val", shinyvalidate::sv_required(
+        message = "At least one value of Left Dichotomization Variable must be selected"
+      ))
+      iv$enable()
+      iv
+    })
 
     options <- reactiveValues(r = NULL, l = NULL)
     vars <- reactiveValues(r = NULL, l = NULL)
@@ -360,6 +384,19 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe
       ADSL <- data[["ADSL"]]() # nolint
       ANL <- data[[dataname]]() # nolint
 
+      teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL"))
+      teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname))
+
+      teal::validate_inputs(iv())
+
+      validate(
+        need(
+          all(input$right_val %in% ADSL[[input$right_var]]) &&
+            all(input$left_val %in% ADSL[[input$left_var]]),
+          "No observations for selected dichotomization values (filtered out?)"
+        )
+      )
+
       right_var <- isolate(input$right_var)
       left_var <- isolate(input$left_var)
       right_val <- input$right_val
@@ -372,37 +409,6 @@ srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, labe
       sort_by_var <- input$sort_by_var
       filter_var <- input$filter_var
 
-      iv_len <- shinyvalidate::InputValidator$new()
-      iv_len$add_rule("right_val", shinyvalidate::sv_required("Please select at least one"))
-      iv_len$add_rule("left_val", shinyvalidate::sv_required("Please select at least one"))
-      iv_len$enable()
-      validate(need(iv_len$is_valid(), "Misspecification error: please observe red flags in the encodings."))
-
-      validate(
-        need(category_var, "Please select a category variable."),
-        need(nrow(ADSL) > 0, "ADSL Data has no rows"),
-        need(nrow(ANL) > 0, "ADAE Data has no rows"),
-        need(right_var, "'Right Dichotomization Variable' not selected"),
-        need(left_var, "'Left Dichotomization Variable' not selected")
-      )
-
-      validate(
-        need(length(right_val) > 0, "No values of 'Right Dichotomization Variable' are checked"),
-        need(length(left_val) > 0, "No values of 'Left Dichotomization Variable' are checked"),
-        need(
-          is.factor(ANL[[right_var]]),
-          "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer."
-        ),
-        need(
-          is.factor(ANL[[left_var]]),
-          "Selected 'Right Dichotomization Variable' variable needs to be a factor. Contact an app developer."
-        ),
-        need(
-          any(c(ADSL[[right_var]] %in% right_val, ADSL[[left_var]] %in% left_val)),
-          "ADSL Data contains no rows with either of the selected left or right dichotomization values (filtered out?)"
-        )
-      )
-
       # if variable is not in ADSL, then take from domain VADs
       varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var)
       varlist_from_adsl <- intersect(varlist, names(ADSL))