shinyvalidate improvements (#199)

Closes [this issue](#185) Following the introduction of `validate_inputs` to `teal` by [#199](insightsengineering/teal#786), this PR: + changes all possible input validations from `validate` calls to `shinyvalidate` input validators + passes all validators to `validate_input` funcitons Signed-off-by: Aleksander Chlebowski <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Nikolas Burkoff <[email protected]> Co-authored-by: Dawid Kałędkowski <[email protected]> Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
insightsengineering · Jan 3, 2023 · 1ce7869 · 1ce7869
1 parent 531c64f
commit 1ce7869
Show file tree

Hide file tree

Showing 17 changed files with 1,176 additions and 1,270 deletions.
diff --git a/DESCRIPTION b/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.3
diff --git a/NEWS.md b/NEWS.md
@@ -3,12 +3,16 @@
 * 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.
+* Added argument checks to `tm_g_patient_profile`.
 
 ### Breaking changes
 
 * Replaced `chunks` with simpler `qenv` class.
 * Replaced `datasets` argument containing `FilteredData` with the new arguments `data` (`tdata` object) and `filter_panel_api` (`FilterPanelAPI`).
 * Updated `arm_var` to point to the factor column in `ANL`. It can't be a character column anymore.
+* Removed redundant formal arguments from `tm_g_patient_profile`.
 
 # teal.osprey 0.1.15
 

diff --git a/R/tm_g_ae_oview.R b/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
 
-    decorate_output <- srv_g_decorate(id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width)
+      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
+    )
     font_size <- decorate_output$font_size
     pws <- decorate_output$pws
 
@@ -283,69 +307,53 @@ 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(
-        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()
+    output_q <- shiny::debounce(
+      millis = 200,
+      r = reactive({
+        ANL <- data[[dataname]]() # nolint
 
-      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"))
+        teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
 
-      q1 <- teal.code::eval_code(
-        teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
-        code = as.expression(c(
-          bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)),
-          bquote(flags <- .(as.name(dataname)) %>%
-            select(all_of(.(input$flag_var_anl))) %>%
-            rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])))
-        ))
-      )
+        teal::validate_inputs(iv())
 
-      teal.code::eval_code(
-        q1,
-        code = as.expression(c(
-          bquote(
-            plot <- osprey::g_events_term_id(
-              term = flags,
-              id = .(as.name(dataname))[["USUBJID"]],
-              arm = .(as.name(dataname))[[.(input$arm_var)]],
-              arm_N = table(ADSL[[.(input$arm_var)]]),
-              ref = .(input$arm_ref),
-              trt = .(input$arm_trt),
-              diff_ci_method = .(input$diff_ci_method),
-              conf_level = .(input$conf_level),
-              axis_side = .(input$axis),
-              fontsize = .(font_size()),
-              draw = TRUE
-            )
-          ),
-          quote(plot)
+        validate(need(
+          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?"
         ))
-      )
-    })
+
+        q1 <- teal.code::eval_code(
+          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
+          code = as.expression(c(
+            bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)),
+            bquote(flags <- .(as.name(dataname)) %>%
+              select(all_of(.(input$flag_var_anl))) %>%
+              rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])))
+          ))
+        )
+
+        teal.code::eval_code(
+          q1,
+          code = as.expression(c(
+            bquote(
+              plot <- osprey::g_events_term_id(
+                term = flags,
+                id = .(as.name(dataname))[["USUBJID"]],
+                arm = .(as.name(dataname))[[.(input$arm_var)]],
+                arm_N = table(ADSL[[.(input$arm_var)]]),
+                ref = .(input$arm_ref),
+                trt = .(input$arm_trt),
+                diff_ci_method = .(input$diff_ci_method),
+                conf_level = .(input$conf_level),
+                axis_side = .(input$axis),
+                fontsize = .(font_size()),
+                draw = TRUE
+              )
+            ),
+            quote(plot)
+          ))
+        )
+      })
+    )
 
     plot_r <- reactive(output_q()[["plot"]])
 

diff --git a/R/tm_g_ae_sub.R b/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,
@@ -286,91 +310,69 @@ 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."))
-      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."
-        )
-      )
+    output_q <- shiny::debounce(
+      millis = 200,
+      r = reactive({
+        ANL <- data[[dataname]]() # nolint
+        ADSL <- data[["ADSL"]]() # nolint
 
-      group_labels <- lapply(seq_along(input$groups), function(x) {
-        items <- input[[sprintf("groups__%s", x)]]
-        if (length(items) > 0) {
-          l <- lapply(seq_along(items), function(y) {
-            input[[sprintf("groups__%s__level__%s", x, y)]]
-          })
-          names(l) <- items
-          l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]]
-          l
-        }
-      })
+        teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname))
 
-      group_labels_call <- if (length(unlist(group_labels)) == 0) {
-        quote(group_labels <- NULL)
-      } else {
-        bquote(group_labels <- setNames(.(group_labels), .(input$groups)))
-      }
+        teal::validate_inputs(iv())
 
-      q1 <- teal.code::eval_code(
-        teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
-        code = group_labels_call
-      )
-      q2 <- teal.code::eval_code(q1, code = "")
-      teal.code::eval_code(
-        q2,
-        code = as.expression(c(
-          bquote(
-            plot <- osprey::g_ae_sub(
-              id = .(as.name(dataname))$USUBJID,
-              arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]),
-              arm_sl = as.character(ADSL[[.(input$arm_var)]]),
-              trt = .(input$arm_trt),
-              ref = .(input$arm_ref),
-              subgroups = .(as.name(dataname))[.(input$groups)],
-              subgroups_sl = ADSL[.(input$groups)],
-              subgroups_levels = group_labels,
-              conf_level = .(input$conf_level),
-              diff_ci_method = .(input$ci),
-              fontsize = .(font_size()),
-              arm_n = .(input$arm_n),
-              draw = TRUE
-            )
-          ),
-          quote(plot)
+        validate(need(
+          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?"
         ))
-      )
-    })
+
+        group_labels <- lapply(seq_along(input$groups), function(x) {
+          items <- input[[sprintf("groups__%s", x)]]
+          if (length(items) > 0) {
+            l <- lapply(seq_along(items), function(y) {
+              input[[sprintf("groups__%s__level__%s", x, y)]]
+            })
+            names(l) <- items
+            l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]]
+            l
+          }
+        })
+
+        group_labels_call <- if (length(unlist(group_labels)) == 0) {
+          quote(group_labels <- NULL)
+        } else {
+          bquote(group_labels <- setNames(.(group_labels), .(input$groups)))
+        }
+
+        q1 <- teal.code::eval_code(
+          teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)),
+          code = group_labels_call
+        )
+        q2 <- teal.code::eval_code(q1, code = "")
+        teal.code::eval_code(
+          q2,
+          code = as.expression(c(
+            bquote(
+              plot <- osprey::g_ae_sub(
+                id = .(as.name(dataname))$USUBJID,
+                arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]),
+                arm_sl = as.character(ADSL[[.(input$arm_var)]]),
+                trt = .(input$arm_trt),
+                ref = .(input$arm_ref),
+                subgroups = .(as.name(dataname))[.(input$groups)],
+                subgroups_sl = ADSL[.(input$groups)],
+                subgroups_levels = group_labels,
+                conf_level = .(input$conf_level),
+                diff_ci_method = .(input$ci),
+                fontsize = .(font_size()),
+                arm_n = .(input$arm_n),
+                draw = TRUE
+              )
+            ),
+            quote(plot)
+          ))
+        )
+      })
+    )
 
     plot_r <- reactive(output_q()[["plot"]])