diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index d5060a1..1e87205 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -11,8 +11,6 @@ on:
branches:
- main
push:
- branches:
- - main
workflow_dispatch:
jobs:
diff --git a/.lintr.R b/.lintr.R
new file mode 100644
index 0000000..669a395
--- /dev/null
+++ b/.lintr.R
@@ -0,0 +1,21 @@
+linters <- lintr::default_linters # -[ diff with dv.templates 3ca8d7a10cfc7ad2307644dcac603e1f1f0feb72]-
+linters <- lintr::modify_defaults(
+ linters
+ , line_length_linter = NULL # we see how long lines are when we write them
+ , indentation_linter = NULL
+ , trailing_whitespace_linter = NULL
+ , cyclocomp_linter = NULL # prevents trivial amount of nesting and long but straightforward functions
+ , object_name_linter = NULL # we have reasons to capitalize. nobody in our team CamelCase. shiny does
+ , object_length_linter = NULL # we don't type long var names just because
+ , pipe_continuation_linter = NULL # wickham being overly prescriptive
+ , trailing_blank_lines_linter = NULL # natural extension of trailing_whitespace_linter, present on the template
+)
+
+if(identical(Sys.getenv('CI'), "true")){
+ linters <- lintr::modify_defaults(
+ linters
+ , object_usage_linter = NULL # R lacks var declarations; it's easy to assign to the wrong variable by mistake
+ ) # We only disable this lint rule on github because it fails there because
+} # of a long-standing lintr bug
+
+exclusions <- list("tests")
diff --git a/DESCRIPTION b/DESCRIPTION
index 3580a5c..84c819a 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: dv.listings
Type: Package
Title: Data listings module
-Version: 4.0.1
+Version: 4.0.1.9000
Authors@R:
c(
person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
diff --git a/NEWS.md b/NEWS.md
index c57e10e..d8ab946 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,8 @@
+# dv.listings 4.0.1.9000
+
+- Remove support for data dispatchers.
+- Provide early feedback of module misconfiguration.
+
# dv.listings 4.0.1
The module allows now to
diff --git a/R/CM.R b/R/CM.R
new file mode 100644
index 0000000..15de061
--- /dev/null
+++ b/R/CM.R
@@ -0,0 +1,639 @@
+# YT#VH0ae1b0c3bf862b3b93194fa0f023686d#VHd74cfd54b905c92b95c251b87af2e842#
+CM <- local({ # _C_hecked _M_odule
+ message_well <- function(title, contents, color = "f5f5f5") { # repeats #iewahg
+ style <- sprintf(r"---(
+ padding: 0.5rem;
+ padding-left: 1rem;
+ margin-bottom: 20px;
+ background-color: %s;
+ border: 1px solid #e3e3e3;
+ border-radius: 4px;
+ -webkit-box-shadow: inset 0 1px 1px rgba(0,0,0,.05);
+ box-shadow: inset 0 1px 1px rgba(0,0,0,.05);
+ )---", color)
+
+ res <- list(shiny::h3(title))
+ if (length(contents)) res <- append(res, list(shiny::tags[["div"]](contents, style = style)))
+ return(res)
+ }
+
+ app_creator_feedback_ui <- function(id, ui) {
+ id <- paste(c(id, "validator"), collapse = "-")
+ ns <- shiny::NS(id)
+
+ hide <- function(e) shiny::tags[["div"]](e, style = "display: none")
+
+ res <- list(
+ shiny::uiOutput(ns("ui")),
+ hide(shiny::checkboxInput(inputId = ns("show_ui"), label = NULL)),
+ shiny::conditionalPanel(condition = "input.show_ui == true", ui, ns = ns)
+ )
+ return(res)
+ }
+
+ app_creator_feedback_server <- function(id, warning_messages, error_messages) {
+ id <- paste(c(id, "validator"), collapse = "-")
+ module <- shiny::moduleServer(
+ id,
+ function(input, output, session) {
+ output[["ui"]] <- shiny::renderUI({
+ res <- list()
+ warn <- warning_messages
+ if (length(warn)) {
+ res[[length(res) + 1]] <-
+ message_well("Module configuration warnings",
+ Map(function(x) htmltools::p(htmltools::HTML(paste("\u2022", x))), warn),
+ color = "#fff7ef"
+ )
+ }
+
+ err <- error_messages
+ if (length(err)) {
+ res[[length(res) + 1]] <-
+ message_well("Module configuration errors",
+ Map(function(x) htmltools::p(htmltools::HTML(paste("\u2022", x))), err),
+ color = "#f4d7d7"
+ )
+ }
+
+ return(res)
+ })
+ shiny::outputOptions(output, "ui", suspendWhenHidden = FALSE)
+
+ if (length(error_messages) == 0) {
+ shiny::updateCheckboxInput(inputId = "show_ui", value = TRUE)
+ }
+ }
+ )
+
+ return(module)
+ }
+
+ # Wrap the UI and server of a module so that, once parameterized, they go through a check function prior to running.
+ module <- function(module, check_mod_fn, dataset_info_fn) {
+ local({
+ # Make sure that the signature of `check_mod_fn` matches that of `module` except for the expected differences
+ check_formals <- names(formals(check_mod_fn))
+ if (!identical(head(check_formals, 2), c("afmm", "datasets"))) {
+ stop("The first two arguments of check functions passed onto `module` should be `afmm` and `datasets`")
+ }
+ check_formals <- check_formals[c(-1, -2)]
+
+ mod_formals <- names(formals(module))
+ if (!identical(check_formals, mod_formals)) {
+ stop(paste(
+ "Check function arguments do not exactly match those of the module function",
+ "(after discarding `afmm` and `datasets`)"
+ ))
+ }
+ })
+
+ mandatory_module_args <- local({
+ args <- formals(module)
+ names(args)[sapply(args, function(x) is.name(x) && nchar(x) == 0)]
+ })
+
+ wrapper <- function(...) {
+ # Match arguments explicitly to provide graphical error feedback
+ # https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Argument-matching
+
+ module_ui <- function(...) list()
+ module_server <- function(...) NULL
+ module_id <- "error_id"
+
+ matched_args <- try(as.list(match.call(module)), silent = TRUE)
+ error_message <- attr(matched_args, "condition")$message
+ if (is.null(error_message)) {
+ missing_args <- setdiff(mandatory_module_args, names(matched_args))
+ if (length(missing_args)) {
+ error_message <- sprintf("Missing mandatory arguments: `%s`.", paste(missing_args, collapse = ", "))
+ }
+ }
+
+ if (is.null(error_message)) {
+ args <- list(...)
+ evaluated_module <- do.call(module, args)
+ module_ui <- evaluated_module[["ui"]]
+ module_server <- evaluated_module[["server"]]
+ module_id <- evaluated_module[["module_id"]]
+ }
+
+ res <- list(
+ ui = function(module_id) app_creator_feedback_ui(module_id, module_ui(module_id)), # `module` UI gated by app_creator_feedback_server
+ server = function(afmm) {
+ fb <- local({
+ res <- NULL
+ if (!is.null(error_message)) {
+ res <- list(
+ warnings = character(0),
+ errors = error_message
+ )
+ } else {
+ # NOTE: We check the call here and not inside the module server function because:
+ # - app creators interact with the davinci module and not with the ui-server combo, so
+ # errors reported with respect to the module signature will make sense to them.
+ # The module server function might use a different function signature.
+ # - Here we also have access to the original datasets, which allows us to ensure call
+ # correctness independent of filter state or operation in a single pass.
+ # - "catch errors early"
+
+ args <- append(
+ list(
+ afmm = afmm, # To check receiver_ids, among others
+ datasets = afmm[["data"]][[1]] # Allows data checks prior to reactive time
+ ),
+ args
+ )
+
+ # check functions do not have defaults, so we extract them from the formals of the module for consistency
+ missing_args <- setdiff(names(formals(module)), names(args))
+ res <- do.call(check_mod_fn, args)
+ }
+ return(res)
+ })
+
+ app_creator_feedback_server(
+ id = module_id, warning_messages = fb[["warnings"]], error_messages = fb[["errors"]]
+ )
+
+ # TODO: Modify afmm to the `map_to` flags in the API. `dv.papo` relies on this
+ # nolint start
+ if (FALSE) {
+ filtered_mapped_datasets <- shiny::reactive(
+ TC$honor_map_to_flag(afmm$filtered_dataset(), mod_lineplot_API, args)
+ )
+
+ bm_dataset <- shiny::reactive({
+ shiny::req(bm_dataset_name)
+ ds <- filtered_mapped_datasets()[[bm_dataset_name]]
+ shiny::validate(
+ shiny::need(!is.null(ds), paste("Could not find dataset", bm_dataset_name))
+ )
+ return(ds)
+ })
+
+ # TODO:
+ corr_hm_server(
+ id = module_id,
+ bm_dataset = bm_dataset,
+ default_value = default_value, subjid_var = subjid_var, cat_var = cat_var, par_var = par_var,
+ visit_var = visit_var, value_vars = value_vars
+ )
+ }
+ # nolint end
+
+ if (length(fb[["errors"]]) == 0) {
+ res <- try(module_server(afmm), silent = TRUE)
+ }
+
+ return(res)
+ },
+ module_id = module_id,
+ meta = list(
+ dataset_info = {
+ # extract defaults from the formals for consistency
+ missing_args <- setdiff(names(formals(module)), names(matched_args))
+ args <- c(args, formals(module)[missing_args])
+ do.call(dataset_info_fn, args)
+ }
+ )
+ )
+
+ return(res)
+ }
+
+ roxygen_wrapper <- function() { # to keep parameters in the reference docs
+ args <- (match.call() |> as.list())[c(-1)]
+ do.call(wrapper, args, env = parent.frame())
+ }
+ formals(roxygen_wrapper) <- formals(module)
+ return(roxygen_wrapper)
+ }
+
+ container <- function() list2env(x = list(messages = character(0)), parent = emptyenv())
+ assert <- function(container, cond, msg) {
+ ok <- isTRUE(cond)
+ if (!ok) container[["messages"]] <- c(container[["messages"]], msg)
+ return(ok)
+ }
+
+ is_valid_shiny_id <- function(s) grepl("^$|^[a-zA-Z][a-zA-Z0-9_-]*$", s)
+
+ generate_check_function <- function(spec) {
+ stopifnot(spec$kind == "group")
+
+ # TODO: Check that arguments that depend on arguments TC$flagged as `optional` are optional too.
+
+ res <- character(0)
+ push <- function(s) res <<- c(res, s)
+ push("function(afmm, datasets,")
+ param_names <- paste(names(spec$elements), collapse = ",")
+ push(param_names)
+ push(", warn, err){\n")
+
+ push("OK <- logical(0)\n")
+ push("used_dataset_names <- new.env(parent = emptyenv())\n")
+
+ subjid_vars <- character(0)
+
+ for (elem_name in names(spec$elements)) {
+ elem <- spec$elements[[elem_name]]
+ attrs_ids <- setdiff(names(attributes(elem)), c("names", "docs"))
+ attrs <- attributes(elem)[attrs_ids]
+
+ if (isTRUE(attrs[["subjid_var"]])) {
+ subjid_vars <- c(subjid_vars, elem_name)
+ }
+
+ if (elem$kind == "mod") {
+ push(sprintf("OK[['%s']] <- CM$check_module_id('%s', %s, warn, err)\n", elem_name, elem_name, elem_name))
+ } else if (elem$kind == "dataset_name") {
+ push(sprintf("flags <- %s\n", deparse(attrs) |> paste(collapse = "")))
+ push(sprintf(
+ "OK[['%s']] <- CM$check_dataset_name('%s', %s, flags, datasets, used_dataset_names, warn, err)\n",
+ elem_name, elem_name, elem_name
+ ))
+ } else if (elem$kind == "col") {
+ push(sprintf("subkind <- %s\n", deparse(elem$sub_kind) |> paste(collapse = "")))
+ push(sprintf("flags <- %s\n", deparse(attrs) |> paste(collapse = "")))
+ push(sprintf(
+ "OK[['%s']] <- OK[['%s']] && CM$check_dataset_colum_name('%s', %s, subkind, flags, %s, datasets[[%s]], warn, err)\n",
+ elem_name, elem$dataset_name, elem_name, elem_name, elem$dataset_name, elem$dataset_name
+ ))
+ } else if (elem$kind == "choice_from_col_contents") {
+ dataset_param_name <- spec$elements[[elem$param]]$dataset_name
+ push(sprintf("flags <- %s\n", deparse(attrs) |> paste(collapse = "")))
+ push(sprintf(
+ "OK[['%s']] <- OK[['%s']] && CM$check_choice_from_col_contents('%s', %s, flags, '%s', datasets[[%s]], %s, warn, err)\n",
+ elem_name, elem$param, elem_name, elem_name, dataset_param_name, dataset_param_name, elem$param
+ ))
+ } else if (elem$kind == "choice") {
+ push(sprintf("flags <- %s\n", deparse(attrs) |> paste(collapse = "")))
+ push(sprintf(
+ "OK[['%s']] <- OK[['%s']] && CM$check_choice('%s', %s, flags, '%s', %s, warn, err)\n",
+ elem_name, elem$param, elem_name, elem_name, elem$param, elem$param
+ ))
+ } else if (elem$kind == "function") {
+ push(sprintf("flags <- %s\n", deparse(attrs) |> paste(collapse = "")))
+ push(sprintf(
+ "OK[['%s']] <- CM$check_function('%s', %s, %d, flags, warn, err)\n",
+ elem_name, elem_name, elem_name, elem$arg_count
+ ))
+ } else {
+ push(sprintf("'NOTE: %s (%s) has no associated automated checks'\n", elem_name, elem$kind))
+ push(sprintf("' The expectation is that it either does not require them or that'\n"))
+ push(sprintf("' the caller of this function has written manual checks near the call site.'\n"))
+ }
+ }
+
+ if (length(subjid_vars) > 1) {
+ stop(sprintf("This API specifies more than one subjid variable: ", paste(subjid_vars, collapse = ", ")))
+ }
+
+ if (length(subjid_vars) == 1) {
+ subjid_var <- subjid_vars[[1]]
+ push("for(ds_name in names(used_dataset_names)){\n")
+ push(sprintf(
+ "OK[['%s']] <- OK[['%s']] && CM$check_subjid_col(datasets, ds_name, get(ds_name), '%s', %s, warn, err)",
+ subjid_var, subjid_var, subjid_var, subjid_var
+ ))
+ push("}\n")
+ # TODO: If there is a dataset flagged as `subject_level_dataset_name`:
+ # [ ] check that subjid_var is unique
+ # [ ] check that the subjid_var values of all other datasets are a subset of its values
+ }
+
+ push(sprintf("return(OK)\n"))
+
+ push("}\n")
+
+ return(res)
+ }
+
+ # NOTE: For the moment call by running: devtools::load_all(); CM$generate_check_functions()
+ generate_check_functions <- function(specs = module_specifications, output_file = "R/check_call_auto.R") {
+ styler_off <- "({\n# styler: off"
+ styler_on <- "\n\n})\n# styler: on\n"
+
+ res <- c("# Automatically generated module API check functions. Think twice before editing them manually.\n")
+ res <- c(res, styler_off)
+
+ style_code <- function(code) {
+ s <- paste(code, collapse = "")
+ s <- parse(text = s, keep.source = FALSE)[[1]] |>
+ deparse(width.cutoff = 100) |>
+ trimws("right") |>
+ paste(collapse = "\n")
+ return(s)
+ }
+
+ for (spec_name in names(specs)) {
+ if (!grepl("::", spec_name, fixed = TRUE)) stop(paste("Expected API spec name to be namespaced (`::`):", spec_name))
+ denamespaced_spec_name <- strsplit(spec_name, "::")[[1]][[2]]
+ check_function_name <- paste0("check_", denamespaced_spec_name, "_auto")
+ res <- c(res, sprintf("\n\n# %s\n", spec_name))
+ res <- c(
+ res,
+ c(check_function_name, "<-", generate_check_function(specs[[spec_name]])) |> style_code()
+ )
+ }
+
+ res <- c(res, styler_on)
+
+ contents <- paste(res, collapse = "")
+ writeChar(contents, output_file, eos = NULL)
+
+ return(NULL)
+ }
+
+ test_string <- function(s) {
+ is.character(s) && length(s) == 1
+ }
+
+ check_module_id <- function(name, value, warn, err) {
+ assert(err, test_string(value), sprintf("`%s` should be a string", name)) &&
+ assert(warn, nchar(value) > 0, sprintf("Consider providing a non-empty `%s`.", name)) &&
+ assert(
+ err,
+ is_valid_shiny_id(value),
+ paste(
+ sprintf("`%s` should be a valid identifier, starting with a letter and followed by", name),
+ "alphanumeric characters, hyphens and underscores."
+ )
+ )
+ }
+
+ check_dataset_name <- function(name, value, flags, available_datasets, used_dataset_names, warn, err) {
+ ok <- check_flags(name, value, flags, warn, err)
+
+ if (ok) {
+ zero_or_more <- isTRUE(flags[["zero_or_more"]])
+ one_or_more <- isTRUE(flags[["one_or_more"]])
+ zero_or_one_or_more <- zero_or_more || one_or_more
+ if (zero_or_one_or_more) {
+ min_len <- 0
+ if (one_or_more) min_len <- 1
+ ok <- assert(
+ err,
+ is.character(value) &&
+ all(value %in% names(available_datasets)) &&
+ length(value) >= min_len,
+ paste(
+ sprintf(
+ "`%s` should be a character vector of length greater than %s referring to the following dataset names: ",
+ name, c("zero", "one")[[min_len + 1]]
+ ),
+ paste(sprintf('"%s"', names(available_datasets)), collapse = ", "), "."
+ )
+ )
+ } else {
+ ok <- (
+ assert(err, !missing(value), sprintf("`%s` missing", name)) && # TODO: ? Remove this one
+ assert(
+ err,
+ test_string(value) &&
+ value %in% names(available_datasets),
+ paste(
+ sprintf("`%s` should be a string referring to one of the available dataset names: ", name),
+ paste(sprintf('"%s"', names(available_datasets)), collapse = ", "), "."
+ )
+ )
+ )
+ if (ok) used_dataset_names[[name]] <- value
+ }
+ }
+ return(ok)
+ }
+
+ list_columns_of_kind <- function(dataset, type) {
+ res <- names(dataset)[sapply(seq_len(ncol(dataset)), function(x) TC$is_of_kind(dataset[[x]], type))]
+ return(res)
+ }
+
+ # TODO: use check_flags instead and remove
+ optional_and_empty <- function(flags, value) {
+ return(isTRUE(flags[["optional"]]) && length(value) == 0)
+ }
+
+ check_dataset_colum_name <- function(name, value, subkind, flags, dataset_name, dataset_value, warn, err) {
+ if (optional_and_empty(flags, value)) {
+ return(TRUE)
+ }
+
+ ok <- FALSE
+
+ valid_column_names <- list_columns_of_kind(dataset_value, subkind)
+
+ zero_or_more <- isTRUE(flags[["zero_or_more"]])
+ one_or_more <- isTRUE(flags[["one_or_more"]])
+ zero_or_one_or_more <- zero_or_more || one_or_more
+ if (zero_or_one_or_more) {
+ min_len <- 0
+ if (one_or_more) min_len <- 1
+ ok <- assert(
+ err,
+ is.character(value) &&
+ all(value %in% valid_column_names) &&
+ length(value) >= min_len,
+ paste(
+ sprintf(
+ "`%s` should be a character vector of length greater than %s referring to one of the following columns of dataset `%s`: ",
+ name, c("zero", "one")[[min_len + 1]], dataset_name
+ ),
+ paste(sprintf('"%s"', valid_column_names), collapse = ", "), "."
+ )
+ )
+ } else {
+ ok <- assert(
+ err,
+ test_string(value) &&
+ all(value %in% valid_column_names),
+ paste(
+ sprintf("`%s` should be a string referring to one of the following columns of dataset `%s`: ", name, dataset_name),
+ paste(sprintf('"%s"', valid_column_names), collapse = ", "), "."
+ )
+ )
+ }
+ return(ok)
+ }
+
+ list_values <- function(v) {
+ res <- ""
+ if (is.factor(v)) {
+ res <- sprintf('"%s"', levels(v))
+ } else if (is.character(v)) {
+ res <- sprintf('"%s"', unique(v))
+ } else {
+ browser()
+ }
+
+ res <- paste(res, collapse = ", ")
+
+ return(res)
+ }
+
+ check_flags <- function(name, value, flags, warn, err) {
+ ok <- FALSE
+ min_len <- max_len <- 1L
+ if (isTRUE(flags[["optional"]]) && is.null(value)) {
+ ok <- TRUE
+ } else {
+ if (isTRUE(flags[["zero_or_more"]])) {
+ min_len <- 0L
+ max_len <- +Inf
+ } else if (isTRUE(flags[["one_or_more"]])) {
+ min_len <- 1L
+ max_len <- +Inf
+ }
+
+ ok <- assert(
+ err, min_len <= length(value) && length(value) <= max_len,
+ ifelse(min_len < max_len,
+ sprintf(
+ "`%s` has length %s but should have length in the range [%s, %s].",
+ name, length(value), min_len, max_len
+ ),
+ sprintf(
+ "`%s` has length %s but should have length %s.",
+ name, length(value), min_len
+ )
+ )
+ )
+ }
+
+ if (ok && isTRUE(flags[["named"]])) {
+ ok <- assert(
+ err, length(value) == length(names(value)) && all(nchar(names(value)) > 0),
+ sprintf("All elements of `%s` should be named", name)
+ )
+ }
+
+ return(ok)
+ }
+
+ check_choice_from_col_contents <- function(name, value, flags, dataset_name, dataset_value, column, warn, err) {
+ ok <- check_flags(name, value, flags, warn, err) &&
+ assert(
+ err, all(value %in% dataset_value[[column]]),
+ sprintf(
+ "`%s` should contain only values present in column `%s` of dataset `%s`: %s.",
+ name, column, dataset_name, list_values(dataset_value[[column]])
+ )
+ )
+
+ return(ok)
+ }
+
+ check_choice <- function(name, value, flags, values_name, values, warn, err) {
+ ok <- check_flags(name, value, flags, warn, err) &&
+ assert(
+ err, all(value %in% values),
+ sprintf(
+ "`%s` should contain only the following values: %s.",
+ name, list_values(values)
+ )
+ )
+
+ return(ok)
+ }
+
+ format_inline_asis <- function(s) {
+ paste("", s, "")
+ }
+
+ check_function <- function(name, value, arg_count, flags, warn, err) {
+ ok <- check_flags(name, value, flags, warn, err)
+ if (ok) {
+ if (is.function(value)) {
+ value <- list(value) # make single functions behave like vectors of one element, for simplicity
+ }
+
+ for (i in seq_along(value)) {
+ f <- value[[i]]
+ ok <- ok && assert(
+ err, is.function(f) && length(formals(f)) == arg_count,
+ sprintf("`%s[[%d]]` should be a function of %d arguments", name, i, arg_count)
+ )
+ }
+ }
+
+ return(ok)
+ }
+
+ check_subjid_col <- function(datasets, ds_name, ds_value, col_name, col_var, warn, err) {
+ ok <- assert(
+ err, col_var %in% names(datasets[[ds_value]]),
+ sprintf(
+ "Expected `%s` value (%s) to be present in the dataset indicated by name `%s` (%s)",
+ col_name, col_var, ds_name, ds_value
+ )
+ )
+ return(ok)
+ }
+
+ check_unique_sub_cat_par_vis <- function(datasets, ds_name, ds_value, sub, cat, par, vis, warn, err) {
+ ok <- TRUE
+
+ df_to_string <- function(df) {
+ names(df) <- sprintf("[%s] ", names(df))
+ lines <- capture.output(print(as.data.frame(df), right = FALSE, row.names = FALSE, quote = TRUE)) |> trimws()
+ return(paste(lines, collapse = "\n"))
+ }
+
+ dataset <- datasets[[ds_value]]
+
+ unique_cat_par_combinations <- unique(dataset[c(cat, par)])
+ dup_params_across_categories <- duplicated(unique_cat_par_combinations[par])
+
+ ok <- assert(err, !any(dup_params_across_categories), {
+ prefixes <- c(rep("Category:", length(cat)), rep("Parameter:", length(par)))
+ first_duplicates <- head(unique_cat_par_combinations[dup_params_across_categories, ], 5)
+
+ names(first_duplicates) <- paste(prefixes, names(first_duplicates))
+ dups <- df_to_string(first_duplicates)
+ paste(
+ sprintf("The dataset provided by `%s` (%s) contains parameter names that repeat across categories.", ds_name, ds_value),
+ "This module expects them to be unique. Here are the first few duplicates:",
+ paste0("", dups, "
")
+ )
+ })
+
+ supposedly_unique <- dataset[c(sub, cat, par, vis)]
+ dups <- duplicated(supposedly_unique)
+
+ ok <- ok && assert(err, !any(dups), {
+ prefixes <- c(
+ rep("Subject:", length(sub)), rep("Category:", length(cat)),
+ rep("Parameter:", length(par)), rep("Visit:", length(vis))
+ )
+
+ first_duplicates <- head(supposedly_unique[dups, ], 5)
+ names(first_duplicates) <- paste(prefixes, names(first_duplicates))
+ dups <- df_to_string(first_duplicates)
+ paste(
+ sprintf("The dataset provided by `%s` (%s) contains repeated rows with identical subject, category, parameter", ds_name, ds_value),
+ "and visit values. This module expects them to be unique. Here are the first few duplicates:",
+ paste0("", dups, "
")
+ )
+ })
+
+ return(ok)
+ }
+
+ list(
+ module = module,
+ container = container,
+ assert = assert,
+ generate_check_functions = generate_check_functions,
+ check_module_id = check_module_id,
+ check_dataset_name = check_dataset_name,
+ check_dataset_colum_name = check_dataset_colum_name,
+ check_flags = check_flags,
+ check_choice_from_col_contents = check_choice_from_col_contents,
+ check_choice = check_choice,
+ check_function = check_function,
+ check_subjid_col = check_subjid_col,
+ check_unique_sub_cat_par_vis = check_unique_sub_cat_par_vis,
+ message_well = message_well
+ )
+})
diff --git a/R/TC.R b/R/TC.R
new file mode 100644
index 0000000..2d916c4
--- /dev/null
+++ b/R/TC.R
@@ -0,0 +1,367 @@
+# YT#VH5cf018ae9cef0cbf83422a7d2b6b6b04#VH00000000000000000000000000000000#
+TC <- local({ # _T_ype C_hecks
+ # basic types
+ T_logical <- function() list(kind = "logical")
+ T_factor <- function() list(kind = "factor")
+ T_character <- function() list(kind = "character")
+ T_date <- function() list(kind = "date")
+ T_datetime <- function() list(kind = "datetime")
+ T_integer <- function(min = NA, max = NA) list(kind = "integer", min = min, max = max) # allows numeric if all values are integer
+ T_numeric <- function(min = NA, max = NA) list(kind = "numeric", min = min, max = max)
+
+ # permissive types
+ T_anything <- function() list(kind = "anything")
+
+ # sum types
+ T_or <- function(...) list(kind = "or", options = list(...))
+
+ # known- and variable-length collections
+ T_group <- function(...) list(kind = "group", elements = list(...))
+
+ # domain-specific types
+ T_mod_ID <- function() list(kind = "mod")
+ T_dataset_name <- function() list(kind = "dataset_name")
+ T_col <- function(dataset_name, sub_kind = T_anything()) {
+ list(kind = "col", dataset_name = dataset_name, sub_kind = sub_kind)
+ }
+ T_color <- function() list(kind = "color")
+ T_CDISC_study_day <- function() list(kind = "cdisc_study_day", min = NA, max = NA)
+ T_YN <- function() list(kind = "YN")
+ T_choice_from_col_contents <- function(param) list(kind = "choice_from_col_contents", param = param)
+ T_choice <- function(param) list(kind = "choice", param = param)
+ T_fn <- function(arg_count) list(kind = "function", arg_count = arg_count)
+
+ T_is_of_kind <- function(var, type) {
+ res <- FALSE
+ if (length(type) == 1 && is.na(type)) browser()
+
+ if (type[["kind"]] == "or") {
+ for (option in type[["options"]]) res <- res || T_is_of_kind(var, option)
+ } else if (type[["kind"]] == "anything") {
+ res <- TRUE
+ } else if (type[["kind"]] == "factor") {
+ res <- is.factor(var)
+ } else if (type[["kind"]] == "character") {
+ res <- is.character(var)
+ } else if (type[["kind"]] == "date") {
+ res <- inherits(var, "Date")
+ } else if (type[["kind"]] == "datetime") {
+ res <- inherits(var, "POSIXt")
+ } else if (type[["kind"]] == "numeric") {
+ res <- is.numeric(var)
+ } else if (type[["kind"]] == "integer") {
+ res <- is.integer(var) || (is.numeric(var) && all(var[is.finite(var)] %% 1 == 0))
+ } else if (type[["kind"]] == "logical") {
+ res <- is.logical(var)
+ } else if (type[["kind"]] == "cdisc_study_day") {
+ res <- (is.integer(var) || (is.numeric(var) && all(var[is.finite(var)] %% 1 == 0))) && all(var[is.finite(var)] != 0)
+ } else if (type[["kind"]] == "YN") {
+ res <- ((is.character(var) && setequal(unique(var), c("Y", "N"))) ||
+ is.factor(var) && setequal(levels(var), c("Y", "N")))
+ } else {
+ browser()
+ }
+ return(res)
+ }
+
+ # flags
+ T_flag <- function(x, ...) {
+ flag_names <- list(...)
+
+ unknown_flags <- setdiff(
+ flag_names,
+ c( # common flags
+ "optional", "zero_or_more", "one_or_more", "as_array", "named", "ignore",
+ # domain-specific flags
+ "subject_level_dataset_name", "subjid_var"
+ )
+ )
+ if (length(unknown_flags)) browser()
+
+ flag_values <- as.list(rep(TRUE, length(flag_names)))
+ flags <- stats::setNames(flag_values, flag_names)
+ return(do.call(structure, append(list(x), flags)))
+ }
+
+ T_map_to <- function(orig, dest) structure(orig, map_to = dest) # maps dataset col to a type the module understands
+
+ # Pair documentation with module API ----
+
+ T_get_type_as_text <- function(elem) {
+ res <- ""
+
+ types <- list(
+ group = "list",
+ logical = "logical",
+ factor = "factor",
+ integer = "integer",
+ cdisc_study_day = "integer",
+ numeric = "numeric",
+ mod = "character",
+ dataset_name = "character",
+ col = "character",
+ color = "character",
+ character = "character",
+ date = "Date",
+ datetime = "POSIXt",
+ YN = '"Y"/"N"',
+ `function` = "function"
+ )
+
+ if (elem$kind == "or") {
+ res <- paste(Map(T_get_type_as_text, elem$options), collapse = "|")
+ } else if (elem$kind == "choice") {
+ res <- "character" # FIXME: Refer to the type of the column
+ } else if (elem$kind == "choice_from_col_contents") {
+ res <- "character" # FIXME: Refer to the type of the column
+ } else if (!(elem$kind %in% names(types))) {
+ message(paste("Missing kind", elem$kind))
+ } else {
+ res <- types[[elem$kind]]
+ }
+
+ return(res)
+ }
+
+ T_get_use_as_text_lines <- function(elem) {
+ res <- character(0)
+
+ if (elem$kind == "mod") {
+ res <- "Unique Shiny module identifier"
+ } else if (elem$kind == "dataset_name") {
+ if (isTRUE(attr(elem, "subject_level_dataset_name"))) {
+ res <- "Subject-level dataset name"
+ } else {
+ res <- "Dataset name"
+ }
+ } else if (elem$kind == "col") {
+ if (isTRUE(attr(elem, "subjid_var"))) {
+ res <- "Unique subject identifier column"
+ } else {
+ res <- sprintf("Indexes into dataset `%s`", elem$dataset_name)
+ if (!identical(elem$sub_kind, T_anything())) {
+ res <- c(res, sprintf("Expects `[%s]` values", T_get_type_as_text(elem$sub_kind)))
+ }
+ }
+ } else if (elem$kind == "cdisc_study_day") {
+ res <- "Represents a CDISC (non-zero) Study Day"
+ } else if (elem$kind == "color") {
+ res <- "Contains either an HTML (#xxxxxx) or an R color"
+ } else if (elem$kind == "choice") {
+ res <- "" # TODO: Refer to the actual column
+ } else if (elem$kind == "choice_from_col_contents") {
+ res <- "" # TODO: Refer to the actual column
+ } else if (elem$kind %in% c("logical", "integer", "numeric", "character", "group", "function")) {
+ # nothing
+ } else {
+ message(paste("Missing use for kind", elem$kind))
+ }
+
+ return(res)
+ }
+
+ T_attach_docs <- function(api, docs) {
+ stopifnot(is.character(docs[[1]]))
+
+ attr(api, "docs") <- list(
+ type = T_get_type_as_text(api),
+ auto_desc = T_get_use_as_text_lines(api),
+ manual_desc = docs[[1]]
+ )
+
+ if (api$kind == "group") {
+ docs[[1]] <- NULL
+
+ if (length(api$elements) != length(docs)) {
+ stop(sprintf("api and docs are of different lengths (%d and %d)", length(api), length(docs)))
+ } else if (!identical(names(api$elements), names(docs))) {
+ stop(sprintf(
+ "api and docs have different names (%s and %s)",
+ paste(names(api$elements), collapse = ","), paste(names(docs), collapse = ",")
+ ))
+ }
+
+ for (i in seq_along(api$elements)) {
+ api$elements[[i]] <- T_attach_docs(api$elements[[i]], docs[[i]])
+ }
+ }
+
+ return(api)
+ }
+
+ T_eval_args <- function(args, eval_env) {
+ # evaluate arguments before handing them down to arg-rewriting routines
+ arg_names <- names(args)
+ for (i_arg in seq_along(args)) {
+ name <- arg_names[[i_arg]]
+ eval_res <- eval(args[[i_arg]], envir = eval_env)
+ args[i_arg] <- stats::setNames(list(eval_res), name) # R inferno 8.1.55
+ }
+ return(args)
+ }
+
+ # Permit caller to provide lists when arrays are desired by the module ----
+
+ T_honor_as_array_flag_inner <- function(api_field, elem) {
+ if (isTRUE(attr(api_field, "zero_or_more")) || isTRUE(attr(api_field, "zero_or_more"))) {
+ attr(api_field, "zero_or_more") <- FALSE
+ attr(api_field, "one_or_more") <- FALSE
+ for (i in seq_along(elem)) {
+ elem[[i]] <- T_honor_as_array_flag_inner(api_field, elem[[i]])
+ }
+ } else if (api_field$kind == "group") {
+ elem_names <- names(elem)
+ for (i in seq_along(elem)) {
+ name <- elem_names[[i]]
+ if (!is.null(name) && name %in% names(api_field[["elements"]]) && !is.null(elem[[i]])) {
+ elem[i] <- stats::setNames(
+ list(T_honor_as_array_flag_inner(api_field[["elements"]][[name]], elem[[i]])), name
+ ) # R inferno 8.1.55
+ }
+ }
+ }
+
+ if (isTRUE(attr(api_field, "as_array")) && is.list(elem)) {
+ elem <- unlist(elem)
+ }
+
+ return(elem)
+ }
+
+ T_honor_as_array_flag <- function(mod_API, args) {
+ env_that_called_the_module_function <- parent.frame(2)
+ args <- T_eval_args(args, eval_env = env_that_called_the_module_function)
+ args <- T_honor_as_array_flag_inner(mod_API, args)
+ return(args)
+ }
+
+ # Map allowed types to those expected by the module ----
+
+ T_honor_map_to_flag_inner <- function(datasets, api_field, elem, field_to_dataset_map, current_field_name) {
+ res <- list(map = field_to_dataset_map, actions = list())
+
+ if (isTRUE(attr(api_field, "zero_or_more")) || isTRUE(attr(api_field, "zero_or_more"))) {
+ attr(api_field, "zero_or_more") <- FALSE
+ attr(api_field, "one_or_more") <- FALSE
+ for (i in seq_along(elem)) {
+ res <- T_honor_map_to_flag_inner(datasets, api_field, elem[[i]], field_to_dataset_map, current_field_name)
+ }
+ } else if (api_field$kind == "group") {
+ group_field_to_dataset_map <- field_to_dataset_map # push new mapping used only inside group
+
+ elem_names <- names(elem)
+ for (i in seq_along(elem)) {
+ name <- elem_names[[i]]
+ if (!is.null(name) && name %in% names(api_field[["elements"]]) && !is.null(elem[[i]])) {
+ subres <- T_honor_map_to_flag_inner(
+ datasets, api_field[["elements"]][[name]], elem[[i]], group_field_to_dataset_map, name
+ )
+ res[["actions"]] <- append(res[["actions"]], subres[["actions"]])
+ group_field_to_dataset_map <- subres[["map"]] # carry mappings defined inside this group
+ }
+ }
+
+ res[["map"]] <- field_to_dataset_map # pop old mapping
+ } else if (api_field$kind == "dataset_name") {
+ res[["map"]][[current_field_name]] <- elem
+ } else if (api_field$kind == "col") {
+ map_to <- attr(api_field$sub_kind, "map_to")
+ if (!is.null(map_to)) {
+ dataset <- field_to_dataset_map[[api_field$dataset_name]]
+ if (is.null(dataset)) stop("Column refers to unknown dataset") # TODO: Check this upstream, warn earlier
+ res[["actions"]][[length(res[["actions"]]) + 1]] <- list(dataset = dataset, col = elem, kind = map_to)
+ }
+ }
+
+ return(res)
+ }
+
+ T_do_map <- function(datasets, action) {
+ dataset <- action[["dataset"]]
+ col <- action[["col"]]
+ kind <- action[["kind"]]
+
+ col_data <- datasets[[dataset]][[col]]
+ if (!T_is_of_kind(col_data, kind)) {
+ mapped_from <- attr(col_data, "mapped_from")
+ if (!is.null(mapped_from)) {
+ stop(sprintf(
+ "Dataset %s column %s has already been mapped from %s to %s",
+ dataset, col, mapped_from, T_get_type_as_text(kind)
+ ))
+ }
+
+ mapped_from <- class(col_data)
+
+ attrs <- attributes(col_data)
+ if (kind == "logical" && T_is_of_kind(col_data, T_YN())) {
+ col_data <- (col_data == "Y")
+ } else {
+ kind_s <- T_get_type_as_text(kind)
+ stop(sprintf("Can't map data from type %s to %s", paste(mapped_from, collapse = ", "), kind_s))
+ }
+
+ attributes(col_data) <- attrs
+ attr(col_data, "mapped_from") <- mapped_from
+ }
+
+ return(col_data)
+ }
+
+ T_honor_map_to_flag <- function(datasets, mod_API, args) {
+ # NOTE: Here we overwrite affected dataset columns with the desired type for the purpose of
+ # a particular argument. A 'Y/N' field will be cast to `logical` an thus will become
+ # unavailable as a character variable.
+ # Ideally we would like to cast dataset columns to separate columns with a different
+ # name and overwrite args to point to those new columns, which would sidestep that
+ # restriction. This, however, would entail modifying the argument list in reactive
+ # time depending on the contents of the dataset, which would force mod_*_server to
+ # treat column name arguments as reactives. That seems too much of a hassle for little
+ # benefit.
+ env_that_called_the_module_function <- parent.frame(2)
+ args <- T_eval_args(args, eval_env = env_that_called_the_module_function)
+
+ mapping_actions <- T_honor_map_to_flag_inner(datasets, mod_API, args,
+ field_to_dataset_map = list(),
+ current_field_name = ""
+ )[["actions"]]
+
+ for (action in mapping_actions) {
+ dataset <- action[["dataset"]]
+ col <- action[["col"]]
+ datasets[[dataset]][[col]] <- T_do_map(datasets, action)
+ }
+
+ return(datasets)
+ }
+
+ list(
+ logical = T_logical,
+ factor = T_factor,
+ character = T_character,
+ date = T_date,
+ datetime = T_datetime,
+ integer = T_integer,
+ numeric = T_numeric,
+ anything = T_anything,
+ or = T_or,
+ group = T_group,
+ mod_ID = T_mod_ID,
+ dataset_name = T_dataset_name,
+ col = T_col,
+ color = T_color,
+ CDISC_study_day = T_CDISC_study_day,
+ YN = T_YN,
+ choice_from_col_contents = T_choice_from_col_contents,
+ choice = T_choice,
+ fn = T_fn,
+ is_of_kind = T_is_of_kind,
+ flag = T_flag,
+ map_to = T_map_to,
+ attach_docs = T_attach_docs,
+ honor_as_array_flag_inner = T_honor_as_array_flag_inner,
+ honor_as_array_flag = T_honor_as_array_flag,
+ honor_map_to_flag_inner = T_honor_map_to_flag_inner,
+ honor_map_to_flag = T_honor_map_to_flag
+ )
+})
diff --git a/R/check_call_auto.R b/R/check_call_auto.R
new file mode 100644
index 0000000..16c2c2c
--- /dev/null
+++ b/R/check_call_auto.R
@@ -0,0 +1,27 @@
+# Automatically generated module API check functions. Think twice before editing them manually.
+({
+# styler: off
+
+# dv.listings::mod_listings
+check_mod_listings_auto <- function(afmm, datasets, module_id, dataset_names, default_vars, pagination,
+ intended_use_label, warn, err) {
+ OK <- logical(0)
+ used_dataset_names <- new.env(parent = emptyenv())
+ OK[["module_id"]] <- CM$check_module_id("module_id", module_id, warn, err)
+ flags <- list(one_or_more = TRUE)
+ OK[["dataset_names"]] <- CM$check_dataset_name("dataset_names", dataset_names, flags, datasets, used_dataset_names,
+ warn, err)
+ "NOTE: default_vars (group) has no associated automated checks"
+ " The expectation is that it does not require one or that"
+ " the caller of this function has written manual checks near the call site."
+ "NOTE: pagination (group) has no associated automated checks"
+ " The expectation is that it does not require one or that"
+ " the caller of this function has written manual checks near the call site."
+ "NOTE: intended_use_label (group) has no associated automated checks"
+ " The expectation is that it does not require one or that"
+ " the caller of this function has written manual checks near the call site."
+ return(OK)
+}
+
+})
+# styler: on
diff --git a/R/export_helpers.R b/R/export_helpers.R
index 7be341e..ec1907a 100644
--- a/R/export_helpers.R
+++ b/R/export_helpers.R
@@ -528,7 +528,9 @@ pdf_export <- function(data_to_download, ref_cols, file, metadata, active_sessio
envir = new.env(parent = globalenv()),
output_format = "pdf_document"
)
- file.rename(out[1], file)
+ # copy+remove instead of rename because we can't guarantee that the temp folder lives in the same filesystem as `file`
+ file.copy(out, file)
+ file.remove(out)
# This is mainly needed for the progress bar
return(length(res_preprocess))
diff --git a/R/mock_listings.R b/R/mock_listings.R
index 89df723..91f7594 100644
--- a/R/mock_listings.R
+++ b/R/mock_listings.R
@@ -91,7 +91,7 @@ mock_listings_mm <- function() {
# Define and launch mock app
module_list <- list(
"Multiple Listings" = dv.listings::mod_listings(
- dataset_disp = dv.manager::mm_dispatch("filtered_dataset", c("adsl", "adae", "adtte", "small", "test")),
+ dataset_names = c("adsl", "adae", "adtte", "small", "test"),
module_id = "multi",
default_vars = default_vars_multi,
pagination = TRUE
diff --git a/R/mock_simple_listing.R b/R/mock_simple_listing.R
index b5b8a26..10588f8 100644
--- a/R/mock_simple_listing.R
+++ b/R/mock_simple_listing.R
@@ -51,7 +51,7 @@ mock_simple_listing_mm <- function() {
data = datasets,
module_list = list(
"Listing" = mod_simple_listing(
- dv.manager::mm_dispatch("filtered_dataset", "mpg"),
+ dataset_name = "mpg",
"mod_listing"
)
),
diff --git a/R/mod_listings.R b/R/mod_listings.R
index 44a3d31..4a64fef 100644
--- a/R/mod_listings.R
+++ b/R/mod_listings.R
@@ -360,15 +360,9 @@ listings_server <- function(module_id,
#' @param dataset_names `[character(1+)]`
#'
#' Name(s) of the dataset(s) that will be displayed.
-#' Cannot be used together with the parameter \code{dataset_disp}.
#'
#' @inheritParams listings_server
#'
-#' @param dataset_disp `[dv.manager::mm_dispatch()]`
-#'
-#' This is only for advanced usage. An mm_dispatch object.
-#' Can not be used together with the parameter \code{dataset_names}.
-#'
#' @template module_id-arg
#'
#' @export
@@ -422,49 +416,16 @@ mod_listings <- function(
dataset_names,
default_vars = NULL,
pagination = NULL,
- intended_use_label = "Use only for internal review and monitoring during the conduct of clinical trials.",
- dataset_disp) {
+ intended_use_label = "Use only for internal review and monitoring during the conduct of clinical trials.") {
# Check validity of parameters
- if (!missing(dataset_names)) {
- checkmate::assert_character(dataset_names)
- }
- if (!missing(dataset_disp)) {
- checkmate::assert_list(dataset_disp, types = "character")
- }
-
- # skip assertions/checks for module_id and default_vars since they will be checked directly in listings_server()
- if (!missing(dataset_disp)) {
- checkmate::assert(
- checkmate::check_class(dataset_disp, "mm_dispatcher"),
- checkmate::check_names(names(dataset_disp), identical.to = c("from", "selection")),
- combine = "and"
- )
- }
-
- if (!missing(dataset_names) && !missing(dataset_disp)) {
- stop("You specified both parameters dataset_names and dataset_disp, but only one can be used at the same time.")
- } else if (missing(dataset_names) && missing(dataset_disp)) {
- stop("Neither dataset_names nor dataset_disp is specified, please specify one of them.")
- }
- # check if dataset_disp should be used
- if (missing(dataset_disp)) {
- use_disp <- FALSE
- } else {
- use_disp <- TRUE
- }
+ checkmate::assert_character(dataset_names)
mod <- list(
ui = function(module_id) {
listings_UI(module_id = module_id)
},
server = function(afmm) {
- dataset_list <- if (use_disp) {
- dv.manager::mm_resolve_dispatcher(dataset_disp, afmm)
- } else {
- shiny::reactive({
- afmm$filtered_dataset()[dataset_names]
- })
- }
+ dataset_list <- shiny::reactive(afmm$filtered_dataset()[dataset_names])
listings_server(
dataset_list = dataset_list,
@@ -479,3 +440,79 @@ mod_listings <- function(
)
return(mod)
}
+
+# Listings module interface description ----
+# TODO: Fill in for dressing room and automatic generation of docs
+mod_listings_API_docs <- list(
+ "Listings",
+ module_id = "",
+ dataset_names = list(""),
+ default_vars = list(""),
+ pagination = list(""),
+ intended_use_label = list("")
+)
+
+mod_listings_API_spec <- TC$group(
+ module_id = TC$mod_ID(),
+ dataset_names = TC$dataset_name() |> TC$flag("one_or_more"),
+ default_vars = TC$group() |> TC$flag("ignore"), # manually tested by check_mod_listings
+ pagination = TC$group() |> TC$flag("ignore"), # manually tested by check_mod_listings
+ intended_use_label = TC$group() |> TC$flag("ignore") # manually tested by check_mod_listings
+) |> TC$attach_docs(mod_listings_API_docs)
+
+dataset_info_listings <- function(dataset_names, ...) {
+ return(list(all = unique(dataset_names), subject_level = character(0)))
+}
+
+check_mod_listings <- function(afmm, datasets, module_id, dataset_names, default_vars, pagination, intended_use_label) {
+ warn <- CM$container()
+ err <- CM$container()
+
+ ok <- check_mod_listings_auto(
+ afmm, datasets,
+ module_id, dataset_names, default_vars, pagination, intended_use_label,
+ warn, err
+ )
+
+ # default_vars
+ if (ok[["dataset_names"]] && !is.null(default_vars)) {
+ if (CM$assert(
+ container = err,
+ cond = (checkmate::test_list(default_vars, types = "character", names = "unique") &&
+ checkmate::test_subset(names(default_vars), dataset_names)),
+ msg = "`default_vars` should be a named list, whose names are unique references to elements of `dataset_names`."
+ )) {
+ for (name in names(default_vars)){
+ available_cols <- names(datasets[[name]])
+
+ CM$assert(
+ container = err,
+ cond = checkmate::test_subset(default_vars[[name]], available_cols),
+ msg = sprintf("`default_vars[['%s']]` should be a subset of these columns: %s.", name,
+ paste(available_cols, collapse = ", "))
+ )
+ }
+ }
+ }
+
+ # pagination
+ CM$assert(
+ container = err,
+ cond = checkmate::test_logical(pagination, null.ok = TRUE, len = 1),
+ msg = "`pagination` should be either logical(1) or NULL."
+ )
+
+ # intended_use_label
+ CM$assert(
+ container = err,
+ cond = checkmate::test_string(intended_use_label, null.ok = TRUE),
+ msg = "`intended_use_label` should be either character(1) or NULL."
+ )
+
+ res <- list(warnings = warn[["messages"]], errors = err[["messages"]])
+ return(res)
+}
+
+mod_listings <- CM$module(
+ mod_listings, check_mod_listings, dataset_info_listings
+)
diff --git a/R/mod_simple_listing.R b/R/mod_simple_listing.R
index a6ed04b..90bb0bd 100644
--- a/R/mod_simple_listing.R
+++ b/R/mod_simple_listing.R
@@ -35,16 +35,16 @@ utils::globalVariables("filtered_datasets")
#' @describeIn simple_listing module
#'
-#' @param dataset_disp An mm_dispatch object.
+#' @param dataset_name `[character(1)]`
#' @template module_id-arg
#'
#' @family data_table
-mod_simple_listing <- function(dataset_disp, module_id) {
+mod_simple_listing <- function(dataset_name, module_id) {
mod <- list(
ui = simple_listing_UI,
server = function(afmm) {
simple_listing_server(
- dataset = dv.manager::mm_resolve_dispatcher(dataset_disp, afmm, flatten = TRUE),
+ dataset = shiny::reactive(afmm$filtered_dataset()[[dataset_name]]),
module_id = module_id
)
},
diff --git a/R/zzzz_mod_API.R b/R/zzzz_mod_API.R
new file mode 100644
index 0000000..015ce87
--- /dev/null
+++ b/R/zzzz_mod_API.R
@@ -0,0 +1,4 @@
+# Available module specifications ----
+module_specifications <- list(
+ "dv.listings::mod_listings" = mod_listings_API_spec
+)
diff --git a/man/mod_listings.Rd b/man/mod_listings.Rd
index 1096f60..a6c1249 100644
--- a/man/mod_listings.Rd
+++ b/man/mod_listings.Rd
@@ -10,8 +10,7 @@ mod_listings(
default_vars = NULL,
pagination = NULL,
intended_use_label =
- "Use only for internal review and monitoring during the conduct of clinical trials.",
- dataset_disp
+ "Use only for internal review and monitoring during the conduct of clinical trials."
)
}
\arguments{
@@ -19,8 +18,7 @@ mod_listings(
\item{dataset_names}{\verb{[character(1+)]}
-Name(s) of the dataset(s) that will be displayed.
-Cannot be used together with the parameter \code{dataset_disp}.}
+Name(s) of the dataset(s) that will be displayed.}
\item{default_vars}{\verb{[list(characters(1+)) | NULL]}
@@ -33,11 +31,6 @@ NULL for which pagination will be activated for large datasets (nrows > 1000) au
\item{intended_use_label}{\verb{[character(1) | NULL]} Either a string indicating the intended use for export, or
NULL. The provided label will be displayed prior to the download and will also be included in the exported file.}
-
-\item{dataset_disp}{\verb{[dv.manager::mm_dispatch()]}
-
-This is only for advanced usage. An mm_dispatch object.
-Can not be used together with the parameter \code{dataset_names}.}
}
\description{
This module will present the dataset as listing using the DT package.
diff --git a/man/simple_listing.Rd b/man/simple_listing.Rd
index 2802fdb..a07039b 100644
--- a/man/simple_listing.Rd
+++ b/man/simple_listing.Rd
@@ -11,14 +11,14 @@ simple_listing_UI(module_id)
simple_listing_server(module_id, dataset)
-mod_simple_listing(dataset_disp, module_id)
+mod_simple_listing(dataset_name, module_id)
}
\arguments{
\item{module_id}{\verb{[character(1)]} Unique module_id identifier. It can only contain alphanumeric characters and underscores.}
\item{dataset}{a data.framish dataset that will be shown as a table}
-\item{dataset_disp}{An mm_dispatch object.}
+\item{dataset_name}{\verb{[character(1)]}}
}
\description{
This module shows a given dataset in a table form.
diff --git a/tests/testthat/apps/mm_app/app.R b/tests/testthat/apps/mm_app/app.R
index b1426f2..2ff4554 100644
--- a/tests/testthat/apps/mm_app/app.R
+++ b/tests/testthat/apps/mm_app/app.R
@@ -36,12 +36,12 @@ module_list <- list(
module_id = "multi",
default_vars = default_vars_multi,
pagination = TRUE,
- dataset_disp = dv.manager::mm_dispatch("filtered_dataset", c("adsl", "adae", "small"))
+ dataset_names = c("adsl", "adae", "small")
),
"Single listing" = dv.listings::mod_listings(
module_id = "single",
default_vars = default_vars_single,
- dataset_disp = dv.manager::mm_dispatch("filtered_dataset", c("adsl"))
+ dataset_names = c("adsl")
)
)
diff --git a/tests/testthat/test-mod_listing.R b/tests/testthat/test-mod_listing.R
index 00e0dcb..ffc455c 100644
--- a/tests/testthat/test-mod_listing.R
+++ b/tests/testthat/test-mod_listing.R
@@ -286,25 +286,6 @@ app <- shinytest2::AppDriver$new(
app_dir <- app$get_url()
test_that("mod_listings() fails when argument types mismatch", {
- # Prepare parameters to test
- disp_no_list <- "Not a list" # Parameter not a list at all
- disp_no_char <- list(from = 3, selection = "adae") # Parameter not a list of characters
-
- disp_no_names <- list("filtered_dataset", "adsl") # Parameter not named at all
- class(disp_no_names) <- "mm_dispatcher" # correct
-
- disp_wrong_names <- list(a = "filtered_dataset", b = "adsl") # Parameter not named correctly
- class(disp_wrong_names) <- "mm_dispatcher" # correct
-
- disp_wrong_class <- list(from = "unfiltered_dataset", selection = "adae") # Correct list structure but ...
- class(disp_wrong_class) <- "character" # ... wrong class
-
- test_cases <- c(disp_no_list, disp_no_char, disp_no_names, disp_wrong_names, disp_wrong_class)
-
- # Perform tests
- purrr::walk(test_cases, ~ expect_error(mod_listings(dataset_disp = .x, module_id = "test_id")))
-
-
dataset_names_no_chr <- 1
dataset_names_list <- list("adsl", "adae")
@@ -314,35 +295,21 @@ test_that("mod_listings() fails when argument types mismatch", {
purrr::walk(names_test_cases, ~ expect_error(mod_listings(dataset_names = .x, module_id = "test_id")))
})
-test_that("mod_listings() fails when both or none of dataset_names and dataset_disp are specified", {
- dataset_disp <- dv.manager::mm_dispatch("filtered_dataset", c("adsl"))
- dataset_names <- c("adsl")
-
- # throw error because both are specified
- expect_error(mod_listings(module_id = "test_id", dataset_names = dataset_names, dataset_disp = dataset_disp))
-
- # throw error because both are not specified
- expect_error(mod_listings(module_id = "test_id", dataset_names = NULL, dataset_disp = NULL))
-})
-
test_that("mod_listings() returns a list containing all information for dv.manager", {
# Valid parameters
- disp <- dv.manager::mm_dispatch("filtered_dataset", "adsl")
id <- "test_id"
# Return value
- outcome <- mod_listings(dataset_disp = disp, module_id = id)
+ outcome <- mod_listings(module_id = id, dataset_names = "adsl")
# Perform tests
- checkmate::expect_list(outcome, len = 3, names = "named") # Must be a list
- checkmate::expect_names(names(outcome), permutation.of = c("ui", "server", "module_id")) # Must have those names
+ checkmate::expect_list(outcome, len = 4, names = "named") # Must be a list
+ checkmate::expect_names(names(outcome), permutation.of = c("ui", "server", "module_id", "meta")) # Must have those names
checkmate::expect_function(outcome$ui) # ui entry must be a function
checkmate::expect_function(outcome$server) # server entry must be a function
expect_equal(outcome$module_id, id) # must not modify the id
})
-
-
test_that("mod_listings() displays a data table, dataset selector and corresponding column selector at app launch" %>%
vdoc[["add_spec"]](
c(
diff --git a/vignettes/disp.Rmd b/vignettes/disp.Rmd
deleted file mode 100644
index 4788b5e..0000000
--- a/vignettes/disp.Rmd
+++ /dev/null
@@ -1,50 +0,0 @@
----
-title: "Usage of {dv.manager} dispatchers"
-output: rmarkdown::html_vignette
-vignette: >
- %\VignetteIndexEntry{Usage of {dv.manager} dispatchers}
- %\VignetteEngine{knitr::rmarkdown}
- %\VignetteEncoding{UTF-8}
----
-
-```{r, include = FALSE}
-knitr::opts_chunk$set(
- eval = FALSE,
- collapse = TRUE,
- comment = "#>"
-)
-```
-
-## How to set up a listings module using dispatchers
-
-**Dispatchers** are helper functions that allow accessing data and utility functions inside module manager in a dynamic way. Refer to `?dv.manager::mm_dispatch` for more information about their functionalities. The boxes below show two examples on how they can be used to set up a listings module. Note that it is not possible to use both arguments, `dataset_names` and `dataset_disp`, at the same time in a `mod_listings()` call.
-
-### a. Filtered data
-
-This code chunk produces essentially the same app behavior as using the `dataset_names` argument. That is, any selection made by the user in the global filter menu affects the module display.
-
-```{r filtered, eval = FALSE}
-dv.listings::mod_listings(
- module_id = "mod2a",
- dataset_disp = dv.manager::mm_dispatch(
- from = "filtered_dataset",
- selection = c("adsl", "adae", "adtte")
- )
-)
-```
-
-
-### b. Unfiltered data
-
-In case it is undesirable that global filter settings affect the listings displayed in a listings module, it is possible to define the dispatcher such that it delivers always unfiltered data. This means that [any global filter will be ignored]{.ul}!
-
-```{r unfiltered, eval = FALSE}
-dv.listings::mod_listings(
- module_id = "mod2b",
- dataset_disp = dv.manager::mm_dispatch(
- from = "unfiltered_dataset",
- selection = c("adsl", "adae", "adtte")
- )
-)
-```
-