Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Remove support for dispatchers; add early error feedback; tweak test to make it a bit more solid #11

Merged
merged 11 commits into from
Jan 23, 2025
Merged
Prev Previous commit
Next Next commit
Remove support for dispatchers. Provide early error feedback.
ml-ebs-ext committed Jan 16, 2025
commit df4f7bfb77482fd54b1530217e1945b515550e81
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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Not a big fan of leading commas, but also not very important. :)

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's a bit tongue-in-cheek :)

The default lintr config we have on dv.templates is just bad because it cares about formatting and deactivates useful linters such us object_usage_linter. However, having such annoying defaults forces the main developers of each repository to decide what is it that they care about, because one size does not fit all. And I see that as a good thing.

My formatting of this file is just an expression of how little I care about formatting. I won't add leading commas anywhere else and I won't complain if someone modifies these. And more importantly, I won't complain if the maintainers of these repository modify the set of linters they care about.

, 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.1.0
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.1.0

- Remove support for data dispatchers.
- Provide early feedback of module misconfiguration.

# dv.listings 4.0.1

The module allows now to
640 changes: 640 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
)
})
21 changes: 21 additions & 0 deletions R/check_call_auto.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,21 @@
# 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)
"TODO: default_vars (group)"
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These TODOs will be done later?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The TODOs (like the rest of the contents of this file) are autogenerated from the this spec, which is incomplete because the CM spec language doesn't have words to express the semantics of some of the parameters of this modules (those flagged as ignored).

The checks they should contain has been written by hand here, so I would consider that those TODOs are actually addressed. I just don't remove them because I prefer not to modify autogenerated files.

I haven't extended the API parameter types or the check generator (CM$generate_check_functions) to cover this scenario because I don't have another example that justifies that generalization. Instead I'm using the "escape hatch" of writing the checks by hand.

There's a much more elegant example of the use of this escape hatch in dv.edish, where all parameters can be expressed with the TC API types but the module still benefits from manual finetuning. Maybe I could take some time to talk about this in an upcoming devOH meeting...

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Wouldn't it make sense to mark somehow that the TODOs are actually already done?
So if you have a look at the code to a later time, that you know that this TODO ist not really a TODO.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see that the TODOs on the autogenerated code are no ideal. I'll replace them with NOTEs explaining that the expectation is that there will be code at the calling site taking care of the semantics of the parameters that are tagged as ignored.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Done!

"TODO: pagination (group)"
"TODO: intended_use_label (group)"
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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Dressing room wil also be added later, right?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The scope of this PR (and the associated sprint goal) is the early error feedback, although we've smuggled the behavior of communicating the datasets we use to dv.manager and the removal of dispatchers. All of these features provide are valuable by themselves.

Adding dressing room support would require a non-trivial generalization of TC.R and of DR.R that we should plan for on upcoming sprints, if we decide to prioritize it.

Up until now the dressing room feature has only been discussed/used as a helper for the core davinci team and it's only public to app creators of dv.papo that care too look for it in the reference manual. Since the interface of this module is fairly straightforward, I see little immediate benefit in equipping it with dressing room support. HOWEVER, if we decided to encourage app creators to rely on the dressing room, then I think that complete coverage of our dv.* module ecosystem would be a more compelling proposition.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Agreed, the module is so simple it doesn't benefit that much from a dressing room. We can revisit this once we equip the other modules with a dressing room.

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.