Skip to content

Commit

Permalink
Formalize interface with papo.
Browse files Browse the repository at this point in the history
  • Loading branch information
ml-ebs-ext committed Oct 11, 2024
1 parent f4f73ab commit 077144f
Show file tree
Hide file tree
Showing 2 changed files with 205 additions and 0 deletions.
102 changes: 102 additions & 0 deletions tests/testthat/test-boxplot-message_papo.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,102 @@
# YT#VH33e387131d296de57ba6b9be8368c156#VH00000000000000000000000000000000#
# This is a test template for modules that select a subject ID and send it to dv.papo.

# In order to fit it to your module, it needs three pieces of information:
# 1) An instance of the module you want to test, parameterized to produce valid output and not trigger a `shiny::req`.
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"
)

# 2) Data matching the previous parameterization.
data <- test_data()

# 3) Fully namespaced input ID that, when set to a subject ID value, should make the module send dv.papo a message.
trigger_input_id <- "mod-BOTON"

# This portion of the test template defines the expected protocol for sending a message to dv.papo and is shared across
# all modules that do so. The first line on this file is a hash of the contents of this `local` section. Its purpose
# is to maintain all copies of this portion of the file synchronized.
# See https://github.com/dull-systems/yours_truelib for more details.
test_harness <- local({
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 = function(input, output, session) {
ret_value <- app_server(input, output, session)

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()
)
}
)

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]])

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()
})
})
103 changes: 103 additions & 0 deletions tests/testthat/test-lineplot-message_papo.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,103 @@
# YT#VH33e387131d296de57ba6b9be8368c156#VH00000000000000000000000000000000#
# This is a test template for modules that select a subject ID and send it to dv.papo.

# In order to fit it to your module, it needs three pieces of information:
# 1) An instance of the module you want to test, parameterized to produce valid output and not trigger a `shiny::req`.
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"
)

# 2) Data matching the previous parameterization.
data <- test_data()

# 3) Fully namespaced input ID that, when set to a subject ID value, should make the module send dv.papo a message.
trigger_input_id <- "mod-selected_subject"

# This portion of the test template defines the expected protocol for sending a message to dv.papo and is shared across
# all modules that do so. The first line on this file is a hash of the contents of this `local` section. Its purpose
# is to maintain all copies of this portion of the file synchronized.
# See https://github.com/dull-systems/yours_truelib for more details.
test_harness <- local({
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 = function(input, output, session) {
ret_value <- app_server(input, output, session)

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()
)
}
)

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]])

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()
})
})

0 comments on commit 077144f

Please sign in to comment.