-
Notifications
You must be signed in to change notification settings - Fork 0
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
Remove support for dispatchers; add early error feedback; tweak test to make it a bit more solid #11
Changes from 1 commit
9b72518
9f51139
868887c
7091aff
10db7d8
df4f7bf
609f63e
52e3a9b
cfc5f98
45b3b72
a39f4a5
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
- dev
- (#16, #11)
- jumping_feature1
- (#11)
There are no files selected for viewing
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") |
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 | ||
) | ||
}) |
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)" | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. These TODOs will be done later? There was a problem hiding this comment. Choose a reason for hiding this commentThe 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 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 ( 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 There was a problem hiding this comment. Choose a reason for hiding this commentThe 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? There was a problem hiding this comment. Choose a reason for hiding this commentThe 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. There was a problem hiding this comment. Choose a reason for hiding this commentThe 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 |
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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Dressing room wil also be added later, right? There was a problem hiding this comment. Choose a reason for hiding this commentThe 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 Adding dressing room support would require a non-trivial generalization of 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 There was a problem hiding this comment. Choose a reason for hiding this commentThe 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 | ||
) |
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 | ||
) |
This file was deleted.
There was a problem hiding this comment.
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. :)
There was a problem hiding this comment.
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 usobject_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.