Merge pull request #25 from Boehringer-Ingelheim/formal_papo_iface

Formalize interface with papo.

tests/testthat/setup.R

@@ -84,3 +84,72 @@ expect_r2d3_svg <- function(app, query_list) {
   })
 }
 # nolint end
+
+#' Test harness for communication with `dv.papo`.
+#'
+#' @param mod Parameterized instance of the module to test. Should produce valid output and not trigger a `shiny::req`.
+#' @param data Data matching the previous parameterization.
+#' @param trigger_input_id Fully namespaced input ID that, when set to a subject ID value,
+#'                         should make the module send `dv.papo` a message.
+test_communication_with_papo <- function(mod, data, trigger_input_id) {
+  datasets <- shiny::reactive(data)
+
+  afmm <- list(
+    unfiltered_dataset = datasets,
+    filtered_dataset = datasets,
+    module_output = function() list(),
+    utils = list(switch2 = function(id) NULL),
+    dataset_metadata = list(name = shiny::reactive("dummy_dataset_name"))
+  )
+
+  app_ui <- function() {
+    shiny::fluidPage(mod[["ui"]](mod[["module_id"]]))
+  }
+
+  app_server <- function(input, output, session) {
+    ret_value <- mod[["server"]](afmm)
+
+    ret_value_update_count <- shiny::reactiveVal(0)
+    shiny::observeEvent(ret_value[["subj_id"]](), ret_value_update_count(ret_value_update_count() + 1))
+
+    shiny::exportTestValues(
+      ret_value = try(ret_value[["subj_id"]]()), # try because of https://github.com/rstudio/shiny/issues/3768
+      update_count = ret_value_update_count()
+    )
+    return(ret_value)
+  }
+
+  app <- shiny::shinyApp(ui = app_ui, server = app_server)
+
+  test_that("module adheres to send_subject_id_to_papo protocol", {
+    app <- shinytest2::AppDriver$new(app, name = "test_send_subject_id_to_papo_protocol")
+
+    app$wait_for_idle()
+
+    # Module starts and sends no message
+    exports <- app$get_values()[["export"]]
+    testthat::expect_equal(exports[["update_count"]], 0)
+
+    trigger_subject_selection <- function(subject_id) {
+      set_input_params <- append(
+        as.list(setNames(subject_id, trigger_input_id)),
+        list(allow_no_input_binding_ = TRUE, priority_ = "event")
+      )
+      do.call(app$set_inputs, set_input_params)
+    }
+
+    # Module sends exactly one message per trigger event, even if subject does not change
+    subject_ids <- c("A", "A", "B")
+    for (i in seq_along(subject_ids)) {
+      trigger_subject_selection(subject_ids[[i]])
+      app$wait_for_idle()
+
+      exports <- app$get_values()[["export"]]
+      # Module outputs selection once
+      testthat::expect_equal(exports[["ret_value"]], subject_ids[[i]])
+      testthat::expect_equal(exports[["update_count"]], i)
+    }
+
+    app$stop()
+  })
+}

tests/testthat/test-boxplot-message_papo.R

@@ -0,0 +1,15 @@
+mod <- mod_boxplot_papo(
+  module_id = "mod",
+  bm_dataset_name = "bm",
+  group_dataset_name = "sl",
+  subjid_var = "SUBJID",
+  cat_var = "PARCAT",
+  par_var = "PARAM",
+  visit_var = "VISIT",
+  value_vars = c("VALUE1", "VALUE2", "VALUE3"),
+  default_cat = "PARCAT1",
+  default_par = "PARAM11"
+)
+data <- test_data()
+trigger_input_id <- "mod-BOTON"
+test_communication_with_papo(mod, data, trigger_input_id)

tests/testthat/test-lineplot-message_papo.R

@@ -0,0 +1,16 @@
+mod <- mod_lineplot(
+  module_id = "mod",
+  bm_dataset_name = "bm",
+  group_dataset_name = "sl",
+  subjid_var = "SUBJID",
+  cat_var = "PARCAT",
+  par_var = "PARAM",
+  visit_vars = c("VISIT"),
+  value_vars = c("VALUE1"),
+  default_cat = "PARCAT1",
+  default_par = "PARAM11",
+  receiver_id = "papo"
+)
+data <- test_data()
+trigger_input_id <- "mod-selected_subject"
+test_communication_with_papo(mod, data, trigger_input_id)