Merge pull request #27 from Boehringer-Ingelheim/rc/v0.0.13

Formalize interface with papo. Change receiver_id parameter interpretation from IDs to labels.

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: dv.explorer.parameter
 Type: Package
 Title: Parameter exploration modules
-Version: 0.0.12
+Version: 0.0.13
 Authors@R: c(
         person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
         person(given = "Luis", family = "Moris Fernandez", role = c("aut", "cre"), email = "luis.moris.fernandez@gmail.com"),

NEWS.md

@@ -1,7 +1,12 @@
+# dv.explorer.parameter 0.0.13
+
+* lineplot, boxplot:
+    * Make receiver_id accept module identifiers instead of labels.
+
 # dv.explorer.parameter 0.0.12
 
 * lineplot:
-    * Prevent spurious reactive update
+    * Prevent spurious reactive update.
 
 # dv.explorer.parameter 0.0.11
 

R/check_call_manual.R

@@ -3,7 +3,7 @@
 # TODO: Generate from mod_lineplot_API
 # This function has been written manually, but mod_lineplot_API carries
 # enough information to derive most of it automatically
-check_lineplot_call <- function(datasets, module_id, bm_dataset_name, group_dataset_name, receiver_id,
+check_lineplot_call <- function(afmm, datasets, module_id, bm_dataset_name, group_dataset_name, receiver_id,
                                 summary_functions, subjid_var, cat_var, par_var, visit_vars, cdisc_visit_vars,
                                 value_vars, additional_listing_vars, ref_line_vars, default_centrality_function,
                                 default_dispersion_function, default_cat, default_par, default_val, default_visit_var,
@@ -95,7 +95,12 @@ check_lineplot_call <- function(datasets, module_id, bm_dataset_name, group_data
     used_dataset_names[["group_dataset_name"]] <- group_dataset_name
   }
 
-  # TODO: receiver_id
+  # receiver_id
+  allowed_receiver_ids <- names(afmm$module_names)
+  assert_err(is.null(receiver_id) || (checkmate::test_string(receiver_id) && receiver_id %in% allowed_receiver_ids),
+             sprintf("`receiver_id` (%s) not found among module list. Possible choices are: %s",
+                     receiver_id, paste(allowed_receiver_ids, collapse = ", ")))
+
   # TODO: summary_functions
 
   # subjid_var

R/mod_boxplot.R

@@ -716,13 +716,13 @@ boxplot_server <- function(id,
 #' A function that will be applied to the server returned value.
 #' Only for advanced use. See the example in mod_box_plot_papo
 #'
-#' @param receiver_id Name of the tab containing the receiver module
+#' @param receiver_id `[character(1)]`
 #'
-#' @param ... Same set of parameters as [mod_boxplot]
+#' Shiny ID of the module receiving the selected subject ID in the data listing. This ID must
+#' be present in the app or be NULL.
 #'
 #' @keywords main
 #'
-#'
 #' @export
 
 mod_boxplot <- function(module_id,
@@ -767,7 +767,8 @@ mod_boxplot <- function(module_id,
         on_sbj_click_fun <- function() NULL
       } else {
         on_sbj_click_fun <- function() {
-          afmm[["utils"]][["switch2"]](receiver_id)
+          receiver_label <- afmm[["module_names"]][[receiver_id]]
+          afmm[["utils"]][["switch2"]](receiver_label)
         }
       }
 

R/mod_lineplot.R

@@ -1495,8 +1495,8 @@ lineplot_server <- function(id,
 #'
 #' @param receiver_id `[character(1)]`
 #'
-#' Name of the module receiving the selected subject ID in the single subject listing. The name must be present in
-#' the module list or NULL.
+#' Shiny ID of the module receiving the selected subject ID in the single subject listing. This ID must
+#' be present in the app or be NULL.
 #'
 #'
 #' @name mod_lineplot
@@ -1564,6 +1564,9 @@ mod_lineplot <- function(module_id,
         names(args)[[1]] <- "datasets"
         args[[1]] <- shiny::isolate(afmm[["unfiltered_dataset"]]())
 
+        # Prepend afmm to args to allow checking receiver_ids
+        args <- append(list(afmm = afmm), args)
+
         do.call(check_lineplot_call, args)
       })
 
@@ -1599,7 +1602,8 @@ mod_lineplot <- function(module_id,
 
       on_sbj_click_fun <- NULL
       if (!is.null(receiver_id)) {
-        on_sbj_click_fun <- function() afmm[["utils"]][["switch2"]](receiver_id)
+        receiver_label <- afmm[["module_names"]][[receiver_id]]
+        on_sbj_click_fun <- function() afmm[["utils"]][["switch2"]](receiver_label)
       }
 
       lineplot_server(

tests/testthat/setup.R

@@ -84,3 +84,73 @@ 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(),
+    module_names = list(papo = "Papo"),
+    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)