Skip to content

Commit

Permalink
Merge pull request #11 from Boehringer-Ingelheim/early_error_feedback
Browse files Browse the repository at this point in the history
Remove support for dispatchers; add early error feedback; tweak test to make it a bit more solid.
ml-ebs-ext authored Jan 23, 2025
2 parents e0d4062 + a39f4a5 commit d934995
Showing 18 changed files with 1,160 additions and 150 deletions.
2 changes: 0 additions & 2 deletions .github/workflows/ci.yml
Original file line number Diff line number Diff line change
@@ -11,8 +11,6 @@ on:
branches:
- main
push:
branches:
- main
workflow_dispatch:

jobs:
21 changes: 21 additions & 0 deletions .lintr.R
Original file line number Diff line number Diff line change
@@ -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")
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -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")),
5 changes: 5 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -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
639 changes: 639 additions & 0 deletions R/CM.R

Large diffs are not rendered by default.

367 changes: 367 additions & 0 deletions R/TC.R
Original file line number Diff line number Diff line change
@@ -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 <- "<placeholder>" # TODO: Refer to the actual column
} else if (elem$kind == "choice_from_col_contents") {
res <- "<placeholder>" # 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 = "<module_API>"
)[["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
)
})
27 changes: 27 additions & 0 deletions R/check_call_auto.R
Original file line number Diff line number Diff line change
@@ -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
4 changes: 3 additions & 1 deletion R/export_helpers.R
Original file line number Diff line number Diff line change
@@ -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))
2 changes: 1 addition & 1 deletion R/mock_listings.R
Original file line number Diff line number Diff line change
@@ -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
2 changes: 1 addition & 1 deletion R/mock_simple_listing.R
Original file line number Diff line number Diff line change
@@ -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"
)
),
121 changes: 79 additions & 42 deletions R/mod_listings.R
Original file line number Diff line number Diff line change
@@ -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
)
6 changes: 3 additions & 3 deletions R/mod_simple_listing.R
Original file line number Diff line number Diff line change
@@ -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
)
},
4 changes: 4 additions & 0 deletions R/zzzz_mod_API.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
# Available module specifications ----
module_specifications <- list(
"dv.listings::mod_listings" = mod_listings_API_spec
)
11 changes: 2 additions & 9 deletions man/mod_listings.Rd
4 changes: 2 additions & 2 deletions man/simple_listing.Rd
4 changes: 2 additions & 2 deletions tests/testthat/apps/mm_app/app.R
Original file line number Diff line number Diff line change
@@ -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")
)
)

39 changes: 3 additions & 36 deletions tests/testthat/test-mod_listing.R
Original file line number Diff line number Diff line change
@@ -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(
50 changes: 0 additions & 50 deletions vignettes/disp.Rmd

This file was deleted.

0 comments on commit d934995

Please sign in to comment.