From a56ff88ed6cd8b659960cc4055ac155314b28f0c Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 09:13:04 +0200 Subject: [PATCH 01/11] Add QC report files --- inst/validation/results/.gitempty | 0 inst/validation/run_validation.R | 44 ++++++ inst/validation/utils-validation.R | 138 ++++++++++++++++++ inst/validation/val_report.Rmd | 17 +++ inst/validation/val_report_child.Rmd | 210 +++++++++++++++++++++++++++ 5 files changed, 409 insertions(+) create mode 100644 inst/validation/results/.gitempty create mode 100644 inst/validation/run_validation.R create mode 100644 inst/validation/utils-validation.R create mode 100644 inst/validation/val_report.Rmd create mode 100644 inst/validation/val_report_child.Rmd diff --git a/inst/validation/results/.gitempty b/inst/validation/results/.gitempty new file mode 100644 index 0000000..e69de29 diff --git a/inst/validation/run_validation.R b/inst/validation/run_validation.R new file mode 100644 index 0000000..465c65c --- /dev/null +++ b/inst/validation/run_validation.R @@ -0,0 +1,44 @@ +pkg_name <- read.dcf("DESCRIPTION")[, "Package"] +pkg_version <- read.dcf("DESCRIPTION")[, "Version"] +test_results <- tibble::as_tibble(devtools::test()) + +local({ + # This is evaluated inside a local because, otherwise, all the variables created in the chunks of the rendered + # document leak into the environment + + validation_root <- "./inst/validation" + validation_report_rmd <- file.path(validation_root, "val_report.Rmd") + validation_report_html <- "val_report.html" + validation_results <- file.path(validation_root, "results") + val_param_rds <- file.path(validation_results, "val_param.rds") + + stopifnot(dir.exists(validation_root)) + stopifnot(file.exists(validation_report_rmd)) + + stopifnot(dir.exists(validation_results)) + unlink(list.files(validation_results)) + + saveRDS( + list( + package = pkg_name, + tests = test_results, + version = pkg_version + ), + val_param_rds + ) + + rmarkdown::render( + input = validation_report_rmd, + params = list( + package = pkg_name, + tests = test_results, + version = pkg_version + ), + output_dir = validation_results, + output_file = validation_report_html + ) + + # We use one of the leaked variables, created inside the validation report to asses if the validation is + # succesful or not + VALIDATION_PASSED +}) diff --git a/inst/validation/utils-validation.R b/inst/validation/utils-validation.R new file mode 100644 index 0000000..4dfafd6 --- /dev/null +++ b/inst/validation/utils-validation.R @@ -0,0 +1,138 @@ +#' Setting up the validation + +if (!exists("package_name")) stop("package name must be in the environment when this script is sourced") + +#' How to link tests and specs + +if (FALSE) { + test_that( + vdoc[["add_spec"]]("my test description", specs$a_spec), + { + expect_true(TRUE) + } + ) +} +#' The specs variable on the call references the one declared in specs.R + +#' 3. For those tests covering more than one spec. +#' NOTE: It must be c() and not list() +#' + +if (FALSE) { + test_that( + vdoc[["add_spec"]]("my test_description", c(specs$my$hier$spec, vdoc_specs$my$hier$other_spec)), + { + expect_true(TRUE) + } + ) +} + +#' Considerations: +#' - parse_spec uses deparse(substitute()). These spec_ids are later used to check if all requirements +#' are covered or not, therefore those calls cannot by substituted for: + +if (FALSE) { + my_spec <- specs$my$hier$spec + test_that(vdoc[["add_spec"]]("my test_description", my_spec), { + ... + }) + + test_that(vdoc[["add_spec"]]("my test_description", specs[["my"]][["hier"]][["spec"]]), { + ... + }) +} + +# In this case the substitute captures my_spec and cannot be used later. +# If you want to do this you must use the spec_id parameter where you pass a +# character vector with the ids. +# Notice that the ids in character form do no longer have the specs particle +# at the beginning, only the pathing of the spec is needed. + +if (FALSE) { + my_spec <- specs$my$hier$spec + test_that(vdoc$parse_spec(my_spec, "my test_description", spec_id = c("my$hier$spec")), { + ... + }) +} + +# Validation code + +local({ + specs <- source( + system.file("validation", "specs.R", package = package_name, mustWork = TRUE), + local = TRUE + )[["value"]] + recursive_ids <- function(x, parent = character(0)) { + if (!is.list(x)) { + return(parent) + } + unlist(mapply(recursive_ids, + x, + paste(parent, names(x), + sep = if (identical(parent, character(0))) "" else "$" + ), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) + } + + recursive_ids <- function(x, parent = character(0)) { + if (!is.list(x)) { + return(parent) + } + unlist(mapply(recursive_ids, x, + paste(parent, names(x), + sep = if (identical(parent, character(0))) "" else "$" + ), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) + } + + + spec_id_list <- recursive_ids(specs) + + list( + specs = specs, + spec_id_list = spec_id_list, + add_spec = function(desc, spec, spec_id) { + if (missing(spec_id)) { + if (!is.character(spec) || length(spec) == 0) stop("spec must be a non-empty character vector") + s_spec <- substitute(spec) + if (s_spec[[1]] == "c") { + spec_id <- sapply(s_spec[2:length(s_spec)], identity) + } else { + spec_id <- list(s_spec) # Otherwise the posterior vapply iterates over the expression + } + + spec_id_chr <- vapply(spec_id, function(x) { + sub("^[^$]*\\$", "", deparse(x)) + }, FUN.VALUE = character(1)) + + if (!all(spec_id_chr %in% spec_id_list)) { + stop("At least one spec is not declared in the spec list") + } # This should be covered by pack of constants but just in case + } else { + spec_id_chr <- spec_id + } + structure(desc, spec_id = spec_id_chr, spec = spec) + }, + get_spec = function(result) { + lapply( + result, + function(x) { + first_result <- try( + x[[1]][["test"]], + silent = TRUE + ) + if (inherits(first_result, "try-error")) { + list(spec_id = NULL, desc = NULL) + } else { + list( + spec_id = attr(first_result, "spec_id", exact = TRUE), + spec = attr(first_result, "spec", exact = TRUE) + ) + } + } + ) + } + ) +}) diff --git a/inst/validation/val_report.Rmd b/inst/validation/val_report.Rmd new file mode 100644 index 0000000..26a97e9 --- /dev/null +++ b/inst/validation/val_report.Rmd @@ -0,0 +1,17 @@ +--- +title: "Quality Control" +output: + html_document: + toc: true + toc_depth: 2 + code_folding: hide +toc-title: "----\nIndex" + +params: + package: NULL + tests: NULL + version: NULL +--- + +```{r, child = "val_report_child.Rmd"} +``` diff --git a/inst/validation/val_report_child.Rmd b/inst/validation/val_report_child.Rmd new file mode 100644 index 0000000..6331537 --- /dev/null +++ b/inst/validation/val_report_child.Rmd @@ -0,0 +1,210 @@ + + + +```{r setup, message = FALSE} +# Import vdoc functions ---- +vdoc <- local({ + # ########## + # package_name is used # INSIDE # the sourced file below + # ########## + package_name <- params[["package"]] + utils_file_path <- system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE) + source(utils_file_path, local = TRUE)[["value"]] +}) + +# Set required packages ---- +suppressPackageStartupMessages(stopifnot(requireNamespace("DT"))) +suppressPackageStartupMessages(stopifnot(requireNamespace("devtools"))) + +# Parse tests ---- + +tests <- as.data.frame(params[["tests"]]) +tests[["validation_data"]] <- vdoc[["get_spec"]](tests[["result"]]) +tests[["spec_id"]] <- sapply(tests[["validation_data"]], function(x) x[["spec_id"]]) +tests[["spec"]] <- sapply(tests[["validation_data"]], function(x) x[["spec"]]) +tests[["spec_id_paste"]] <- vapply(tests[["spec_id"]], function(x) paste(x, collapse = "\n"), FUN.VALUE = character(1)) +tests[["spec_paste"]] <- vapply(tests[["spec"]], function(x) paste(x, collapse = "\n"), FUN.VALUE = character(1)) +tests[["desc"]] <- paste0("(#", seq_len(nrow(tests)), "): ", tests[["test"]]) +tests[["with_spec"]] <- vapply(tests[["spec_id"]], Negate(is.null), FUN.VALUE = logical(1)) + +spec_tests <- tests[tests[["with_spec"]], ] +no_spec_tests <- tests[!tests[["with_spec"]], ] + +declared_spec <- vdoc[["spec_id_list"]] +tested_spec <- unique(unlist(tests[["spec_id"]])) +uncovered_spec <- declared_spec[!declared_spec %in% tested_spec] +undeclared_spec <- tested_spec[!tested_spec %in% declared_spec] + +spec_tests[["are_declared"]] <- sapply(spec_tests[["spec_id"]], function(x) all(x %in% declared_spec)) + +# Count tests in the different categories ---- + +mask_failed <- !!spec_tests[["failed"]] +mask_skipped <- !!spec_tests[["skipped"]] +mask_declared <- spec_tests[["are_declared"]] +n_pass_dec <- sum(!mask_failed & !mask_skipped & mask_declared) +n_fail_dec <- sum(mask_failed & mask_declared) +n_skip_dec <- sum(mask_skipped & mask_declared) +n_uncov <- length(uncovered_spec) +n_undec <- sum(!mask_declared) + +render_spec_table <- function(t) { + t <- t[trac_matrix_col] + colnames(t) <- names(trac_matrix_col) + t <- t[order(t[["Spec ID"]]), ] + DT::datatable(t, options = list(dom = "ltp"), filter = list(position = "top")) +} + +data_frame_by_row <- function(colnames, data) { + n <- length(data) + n_cols <- length(colnames) + stopifnot(n %% n_cols == 0) + columns <- vector("list", length = n_cols) + for (i in 1:n_cols) columns[[i]] <- unlist(data[seq(i, n, n_cols)]) + do.call(data.frame, setNames(columns, colnames)) +} + +# Select columns to be included in the tables ---- +trac_matrix_col <- c("Spec ID" = "spec_id_paste", "Spec" = "spec_paste", "Test Desc" = "desc", "File" = "file") + +# Check that validation passes and set title ---- +VALIDATION_PASSED <- n_fail_dec == 0 && n_uncov == 0 && n_undec == 0 && n_uncov == 0 # nolint + +result_symbol <- if (VALIDATION_PASSED) "\U02705" else "\U274C" +title <- paste(result_symbol, params[["package"]], params[["version"]]) +``` + +## `r title` +Date: `r format(Sys.time(), "%Y-%b-%d %H:%M:%S")` + +The following document generates a report for R packages, to satisfy the criteria of a "Released" status under the **Non-GxP** project. The QC report contains the following information: + +- **Specifications (specs):** These can be attached to every test that the user adds. +- **Traceability matrix:** Contains test cases with passed, failed, or skipped expectations. +- **Uncovered or undeclared specs** +- **Session Info and System Configuration** + +::: {.infobox .warning} +Please be advised that the QC report generated for this module does not imply validation according to any other GxP criteria. +The QC report only satisfies our internally developed quality checks for non-GxP criteria. +For clinical reporting purposes, it is essential to note that any outputs generated using this module must be checked and verified within a validated system that adheres to the appropriate GxP guidelines. +::: + +---- +# Traceability matrix + +In this traceability matrix only those tests that point to an specification are included. + +Test cases can contain several expectations a test is considered: + + - **passed** if all expectations in the test pass. + + - **failed** if at least one expectation in the test fails. + + - **skipped** if at least one expectation in the test is skipped. + +A test can be both **failed** and **skipped**. + +## Summary + +```{r summary} +data_frame_by_row( + colnames = c("Spec Exists", "Test", "Count", "color"), + data = list( + "Yes", "Pass", n_pass_dec, "white", + "Yes", "Failed", n_fail_dec, if (n_fail_dec > 0) "red" else "green", + "Yes", "Skipped", n_skip_dec, if (n_skip_dec > 0) "red" else "green", + "Yes", "No Test", n_uncov, if (n_uncov > 0) "red" else "green", + "No", "NA", n_undec, if (n_undec > 0) "red" else "green" + ) +) |> + DT::datatable( + rownames = FALSE, + options = list(columnDefs = list(list(visible = FALSE, targets = c(3))), dom = "tp"), + filter = list(position = "top") + ) |> + DT::formatStyle( + c("Count"), + valueColumns = "color", + backgroundColor = DT::JS("value") + ) +``` + +## Passed tests + +```{r passed_test} +render_spec_table(spec_tests[!mask_failed & !mask_skipped & mask_declared, ]) +``` + +## Failed tests + +```{r failed_test} +render_spec_table(spec_tests[mask_failed & mask_declared, ]) +``` + +## Skipped tests + +```{r skipped_test} +render_spec_table(spec_tests[mask_skipped & mask_declared, ]) +``` + +## Uncovered specifications + +```{r uncovered_spec, echo=FALSE} +data.frame("Uncovered Specifications" = uncovered_spec) |> + DT::datatable( + options = list(dom = "ltp"), + filter = list(position = "top") + ) +``` + +## Undeclared specifications + +This should always be empty, as non existant specs are controlled during test execution. + +```{r undeclared_spec, echo=FALSE, results = "asis"} +render_spec_table(spec_tests[!mask_declared, ]) +``` + +# Session Info and System Configuration + +```{r system_conf} +devtools::session_info() +``` + +# List of specifications +```{r spec_list} +j <- vapply( + vdoc[["spec_id_list"]], + function(x) { + eval( + str2expression( + paste0("vdoc[[\"specs\"]]$", x) + ) + ) + }, + FUN.VALUE = character(1) +) |> + gsub("\n", "
", x = _, fixed = TRUE) + +data.frame(spec_id = names(j), spec = j) |> + DT::datatable( + rownames = FALSE, + options = list( + dom = "ltp" + ), + filter = list(position = "top"), + escape = FALSE + ) +``` From dff49f56022746c7eac0386c02ac756288021c2a Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 09:13:40 +0200 Subject: [PATCH 02/11] Add specs --- inst/validation/specs.R | 28 ++ tests/testthat/setup.R | 11 + tests/testthat/test-export_helpers.R | 282 ++++++------ tests/testthat/test-helpers.R | 117 ++--- tests/testthat/test-mod_export_listings.R | 156 +++---- tests/testthat/test-mod_listing.R | 532 +++++++++++----------- 6 files changed, 601 insertions(+), 525 deletions(-) create mode 100644 inst/validation/specs.R create mode 100644 tests/testthat/setup.R diff --git a/inst/validation/specs.R b/inst/validation/specs.R new file mode 100644 index 0000000..71a8bc8 --- /dev/null +++ b/inst/validation/specs.R @@ -0,0 +1,28 @@ +# Use a list to declare the specs +# nolint start +specs_list <- list + +listing <- specs_list( + "display_listing" = "dv.listings displays a dataset in a tabular form", + "listing_selection" = "dv.listings includes a dropdown menu to select which listing to be shown.", + "listings_label" = "dv.listings displays the label of a listing if available. The label is concatenated to the listing’s dataset name and the resulting strings are provided as choices in the listings dropdown menu.", + "column_selection" = "dv.listings includes a dropdown menu to select the columns from the selected listing to be shown and arrange their order.", + "column_label" = "dv.listings displays the column labels of a listing if available. Column names are pasted together with their label. These extended column titles replace the original column names, so that they are visible in the listings display and column dropdown menu.", + "sorting_columns" = "dv.listings includes sorting functionality for each of the different variables included in the dataset", + "restore_row_order" = "dv.listings includes a button to restore the row order of a listing to the state as it is in the original data.", + "default_vars" = "If pre-specifications for default columns are available, dv.listings will display them at app launch for the respective listing. If not, dv.listings will show the first six columns of the listing - or all columns, in case the number of columns is less than six.", + "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the ", + "bookmarking" = "The module is compatible with the bookmarking feature of the dv.manager." +) +export <- specs_list( + "export" = "dv.listings includes a button to export the listing(s). A click to the button envokes a pop-up to appear that allows the user to decide whether the download should only contain the displayed listing or all available listings, provide a file name (defaulted to the dataset name), and select from available file types.", + "export_active_listing" = "For downloading only the currently active listing, the listing will be saved as it is displayed, either in .xlsx or .pdf format. In case filters were applied, the downloaded output will only contain the filtered data.", + "export_excel" = "For downloading all listings, the tables can be saved in .xlsx format only without considering local filters. Each listing will be placed in an individual worksheet within the file.", + "export_pdf" = "For downloading in .pdf format, users can select one or multiple reference column(s), which will be displayed on all document pages." +) + +specs <- c( + listing, + export +) +# nolint end \ No newline at end of file diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..fb131cf --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,11 @@ +# validation (S) +vdoc <- local({ + # ########## + # package_name is used # INSIDE # the sourced file below + # ########## + package_name <- read.dcf("../../DESCRIPTION")[, "Package"] + utils_file_path <- system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE) + source(utils_file_path, local = TRUE)[["value"]] +}) +specs <- vdoc[["specs"]] +# validation (F) diff --git a/tests/testthat/test-export_helpers.R b/tests/testthat/test-export_helpers.R index f007f95..779d5a1 100644 --- a/tests/testthat/test-export_helpers.R +++ b/tests/testthat/test-export_helpers.R @@ -11,7 +11,7 @@ test_that("export_modal_content() throws an error when argument types mismatch", cond_invalid <- list(NULL, 42, c("wrong", "type")) colnames_valid <- c("valid", "column", "names") colnames_invalid <- list(42) - + # perform tests purrr::walk(ns_invalid, ~ expect_error(export_modal_content(.x, file_name_valid, cond_valid, colnames_valid))) purrr::walk(file_name_invalid, ~ expect_error(export_modal_content(ns_valid, .x, cond_valid, colnames_valid))) @@ -22,7 +22,7 @@ test_that("export_modal_content() throws an error when argument types mismatch", test_that("export_modal_content() returns a shiny tagList with five element", { result <- export_modal_content(function(id) {}, "name", "true", c("valid", "column", "names")) - + checkmate::expect_list(result, len = 5) checkmate::expect_class(result, "shiny.tag.list") }) @@ -31,7 +31,7 @@ test_that("export_modal_content() shows/hides additional panels depending on con # show additional panels result <- export_modal_content(function(id) {}, "name", "true", c("column", "names")) expect_equal(result[[4]]$attribs$`data-display-if`, "true") - + # hide additional panels result <- export_modal_content(function(id) {}, "name", "false", c("column", "names")) expect_equal(result[[4]]$attribs$`data-display-if`, "false") @@ -48,7 +48,7 @@ test_that("shorten_entries() throws an error when argument types mismatch", { as.integer(2), # too_small as.integer(c(1, 2)) # too_long ) - + # perform tests purrr::walk(vec_invalid, ~ expect_error(shorten_entries(.x, len_max_valid))) purrr::walk(len_max_invalid, ~ expect_error(shorten_entries(vec_valid, .x))) @@ -59,7 +59,7 @@ test_that("shorten_entries() returns the original vector if strings are already # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(42) - + # perform test expect_identical(shorten_entries(vec, len_max), vec) }) @@ -68,7 +68,7 @@ test_that("shorten_entries() cuts strings to not exceed a specific length", { # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(5) - + # perform test expect_identical(nchar(shorten_entries(vec, len_max)), rep(len_max, length(vec))) }) @@ -77,7 +77,7 @@ test_that("shorten_entries() returns the correct string after cutting", { # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(5) - + # perform test expect_identical(shorten_entries(vec, len_max), c("fi...", "se...", "th...")) }) @@ -93,7 +93,7 @@ test_that("split_label() throws an error when argument types mismatch", { max_width_invalid <- list(as.integer(3), 10.5, c(as.integer(10), as.integer(12)), "Wrong type") label_width_valid <- as.integer(6) label_width_invalid <- list(as.integer(0), 5.8, c(as.integer(4), as.integer(7)), "Wrong type") - + # perform tests purrr::walk(label_invalid, ~ expect_error(split_label(.x, min_width_valid, max_width_valid, label_width_valid))) purrr::walk(min_width_invalid, ~ expect_error(split_label(label_valid, .x, max_width_valid, label_width_valid))) @@ -108,10 +108,10 @@ test_that("split_label() splits a simple label correctly", { min_width <- as.integer(5) max_width <- as.integer(10) label_width <- as.integer(5) - + # expected label_vec <- c("This", "is a", "simple", "label.") - + # perform test expect_identical( split_label(label, min_width, max_width, label_width), @@ -125,10 +125,10 @@ test_that("split_label() deals with labels that do not fit in the foreseen lines min_width <- as.integer(1) max_width <- as.integer(6) label_width <- as.integer(6) - + # expected label_vec <- c("This", "is a", "loo...", "label", "which", "doe...") - + # perform test expect_identical( split_label(label, min_width, max_width, label_width), @@ -142,10 +142,10 @@ test_that("split_label() directly returns the unchanged label and min_width in c min_width <- as.integer(50) max_width <- as.integer(100) label_width <- as.integer(6) - + # expected result <- list(label_vec = label, col_width = min_width) - + # perform test expect_identical(split_label(label, min_width, max_width, label_width), result) }) @@ -154,25 +154,25 @@ test_that("split_label() directly returns the unchanged label and min_width in c test_that("calculate_col_width() throws an error when argument types mismatch", { # arguments df_valid <- dm_dummy - + df_unnamed <- data.frame(test = cbind(1:10, 11:20)) colnames(df_unnamed) <- NULL df_duplicated_names <- data.frame(test = cbind(1:10, 11:20)) colnames(df_duplicated_names) <- c("name1", "name1") - + df_invalid <- list( "Not a data frame.", # type_mismatch df_unnamed, # unnamed df_duplicated_names, # duplicated names data.frame() # no_dimensions ) - + ref_valid <- paste0(names(df_valid)[1], " [", get_labels(df_valid[1]), "]") ref_invalid <- list( cbind(1:5, 6:10), # type_mismatch c("wrong", "entries") # wrong_entries ) - + # perform tests purrr::walk(df_invalid, ~ expect_error(calculate_col_width(.x, ref_valid))) purrr::walk(ref_invalid, ~ expect_error(calculate_col_width(df_valid, .x))) @@ -190,14 +190,14 @@ test_that("calculate_col_width() returns the correct results", { attributes(df[["name_13_chars"]])$label <- "label 1" attributes(df[["name2"]])$label <- "label 10 characters" attributes(df[["name3"]])$label <- "label 3" - + # ref argument ref_ind <- c(1, 2) ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") - + # result col_width_res <- calculate_col_width(df, ref) - + # expected table_width <- PDF_EXP$N_COL_CHARS - nchar(nrow(df)) label_vecs <- purrr::map2(get_labels(df), c(13, 5, 14), ~ { @@ -217,7 +217,7 @@ test_that("calculate_col_width() returns the correct results", { table_width = table_width, check_ref_cols = FALSE ) - + # perform test expect_identical(col_width_res, col_width_exp) }) @@ -230,7 +230,7 @@ test_that("calculate_col_width() detects that all columns are specified as refer )) colnames(df) <- c("name1", "name2") ref <- paste0(colnames(df), " [", get_labels(df), "]") - + # perform test expect_identical(calculate_col_width(df, ref)$check_ref_cols, TRUE) }) @@ -239,7 +239,7 @@ test_that("calculate_col_width() detects that reference columns take up too much # arguments df <- dm_dummy ref <- paste0(colnames(df)[1:15], " [", get_labels(df)[1:15], "]") - + # perform test expect_identical(calculate_col_width(df, ref)$check_ref_cols, TRUE) }) @@ -251,7 +251,6 @@ empty_rownames <- purrr::imap(rep("", PDF_EXP$LABEL_WIDTH), ~ paste(rep(.x, .y), test_that("pdf_preprocessing() throws an error when argument types mismatch", { # arguments df_valid <- dm_dummy - unnamed <- data.frame(test = cbind(1:10, 11:20)) colnames(unnamed) <- NULL duplicated_names <- data.frame(test = cbind(1:10, 11:20)) @@ -262,13 +261,13 @@ test_that("pdf_preprocessing() throws an error when argument types mismatch", { duplicated_names, # duplicated names data.frame() # no dimensions ) - + ref_valid <- paste0(names(df_valid)[1], " [", get_labels(df_valid[1]), "]") ref_invalid <- list( cbind(1:5, 6:10), # type_mismatch c("wrong", "entries") # wrong_entries ) - + # perform tests purrr::walk(df_invalid, ~ expect_error(pdf_preprocessing(.x, ref_valid))) purrr::walk(ref_invalid, ~ expect_error(pdf_preprocessing(df_valid, .x))) @@ -288,10 +287,10 @@ test_that("pdf_preprocessing() returns original df (without splitting) inclusive row.names(df_res) <- c("", rownames) attributes(df[["name1"]])$label <- labels[1] attributes(df[["name2"]])$label <- labels[2] - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) - + # expected pdf_preprocessing_exp <- list(data.frame(rbind( c("label", "label"), @@ -302,7 +301,7 @@ test_that("pdf_preprocessing() returns original df (without splitting) inclusive ))) colnames(pdf_preprocessing_exp[[1]]) <- c("name1", "name2") rownames(pdf_preprocessing_exp[[1]]) <- c(empty_rownames, 1, 2) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -311,16 +310,16 @@ test_that("pdf_preprocessing() deals with data frames containing only one column # df argument df <- data.frame(simple_dummy[1:5, 1]) colnames(df) <- c("name1") - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) - + # expected pdf_preprocessing_exp <- data.frame(c("No", "label", "", "", "", "", simple_dummy[1:5, 1])) colnames(pdf_preprocessing_exp) <- colnames(df) rownames(pdf_preprocessing_exp) <- c(empty_rownames, 1:5) pdf_preprocessing_exp <- list(pdf_preprocessing_exp) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -329,10 +328,10 @@ test_that("pdf_preprocessing() deals with data frames containing only one row", # df argument df <- data.frame(simple_dummy[1, 1:3]) colnames(df) <- c("name1", "name2", "name3") - + # result pdf_preprocessing_res <- pdf_preprocessing(df, "name2 [No label]") - + # expected pdf_preprocessing_exp <- data.frame(rbind( c("No", "No", "No"), @@ -344,42 +343,43 @@ test_that("pdf_preprocessing() deals with data frames containing only one row", rownames(pdf_preprocessing_exp) <- c(empty_rownames, seq_len(nrow(df))) pdf_preprocessing_exp <- pdf_preprocessing_exp[, c(2, 1, 3)] pdf_preprocessing_exp <- list(pdf_preprocessing_exp) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) -test_that("pdf_preprocessing() changes column order due to reference column specification", { - # df argument - len <- 4 - df <- simple_dummy[1:2, 1:len] - - # ref argument - ref_ind <- c(4, 2) - ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") - - # result - pdf_preprocessing_res <- pdf_preprocessing(df, ref) - - # expected - df_res <- data.frame(rbind( - rep("No", len), - rep("label", len), - matrix("", nrow = PDF_EXP$LABEL_WIDTH - 2, ncol = len), - as.matrix(df) - )) - rownames(df_res) <- c(empty_rownames, 1, 2) - pdf_preprocessing_exp <- list(cbind(df_res[, ref_ind], df_res[, !(1:len %in% ref_ind)])) - - - # perform test - expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) -}) +test_that("pdf_preprocessing() changes column order due to reference column specification" %>% + vdoc[["add_spec"]](specs$export_pdf), { + # df argument + len <- 4 + df <- simple_dummy[1:2, 1:len] + + # ref argument + ref_ind <- c(4, 2) + ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") + + # result + pdf_preprocessing_res <- pdf_preprocessing(df, ref) + + # expected + df_res <- data.frame(rbind( + rep("No", len), + rep("label", len), + matrix("", nrow = PDF_EXP$LABEL_WIDTH - 2, ncol = len), + as.matrix(df) + )) + rownames(df_res) <- c(empty_rownames, 1, 2) + pdf_preprocessing_exp <- list(cbind(df_res[, ref_ind], df_res[, !(1:len %in% ref_ind)])) + + + # perform test + expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) + }) test_that("pdf_preprocessing() splits df into disjoint sub dataframes that form together the original df when ignoring labels", { # nolint # df argument df <- dm_dummy[1:35, 1:10] - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) pdf_preprocessing_res <- purrr::map(pdf_preprocessing_res, ~ { @@ -389,7 +389,7 @@ test_that("pdf_preprocessing() splits df into disjoint sub dataframes that form cbind(pdf_preprocessing_res[[1]], pdf_preprocessing_res[[2]]), cbind(pdf_preprocessing_res[[3]], pdf_preprocessing_res[[4]]) ) - + # perform test expect_identical(apply(pdf_preprocessing_res, 2, as.character), apply(df, 2, as.character)) }) @@ -405,13 +405,13 @@ test_that("pdf_preprocessing() shortens entries that do not fit on one page", { attributes(df[["name2"]])$label <- "label 2" long_entry <- paste0(c("this is a", rep("very", 25), "long entry"), collapse = " ") df[2, 1] <- long_entry - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL)[[1]][8, 1] - + # expected pdf_preprocessing_exp <- paste0(substr(long_entry, 1, (PDF_EXP$N_COL_CHARS - nchar(nrow(df)) - 3)), "...") - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -436,7 +436,7 @@ test_that("prep_export_data() throws an error when argument types mismatch", { data_selection_name_invalid <- list(42, c("wrong", "type")) dataset_list_valid <- list("dummy_data" = simple_dummy) dataset_list_invalid <- list(c("wrong", "type"), list(1, 2, "no dataframe")) - + # perform tests purrr::walk(data_selection_invalid, ~ expect_error(prep_export_data( .x, @@ -477,36 +477,46 @@ test_that("prep_export_data() performs the correct transformation in the single attributes(dataset_list_valid$data1)$label <- "My Label" current_data_valid <- dataset_list_valid[[1]] data_selection_name_valid <- names(dataset_list_valid)[1] - + # result res <- prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid) - + # expected exp <- list("data1 (My Label)" = set_labels(data.frame(col1 = c("1", "2"), col2 = c("3", "4")))) - + # perform tests expect_identical(res, exp) }) -test_that("prep_export_data() performs the correct transformation in the multiple dataset case", { - # arguments - data_selection_valid <- "all" - dataset_list_valid <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[1:5], "dummy3" = simple_dummy[5:10]) - attributes(dataset_list_valid$dummy1)$label <- "My Label 1" - attributes(dataset_list_valid$dummy2)$label <- "My Label 2" - attributes(dataset_list_valid$dummy3)$label <- "My Label 3" - current_data_valid <- dataset_list_valid[[1]] - data_selection_name_valid <- names(dataset_list_valid)[1] - - # result - res <- prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid) - - # perform tests - expect_identical(names(res), c("dummy1 (My Label 1)", "dummy2 (My Label 2)", "dummy3 (My Label 3)")) - expect_identical(res[[1]], set_labels(data.frame(sapply(dataset_list_valid[[1]], as.character)))) - expect_identical(res[[2]], set_labels(data.frame(sapply(dataset_list_valid[[2]], as.character)))) - expect_identical(res[[3]], set_labels(data.frame(sapply(dataset_list_valid[[3]], as.character)))) -}) +test_that("prep_export_data() performs the correct transformation in the multiple dataset case" %>% + vdoc[["add_spec"]](specs$export_excel), { + # arguments + data_selection_valid <- "all" + dataset_list_valid <- list( + "dummy1" = simple_dummy, + "dummy2" = simple_dummy[1:5], + "dummy3" = simple_dummy[5:10] + ) + attributes(dataset_list_valid$dummy1)$label <- "My Label 1" + attributes(dataset_list_valid$dummy2)$label <- "My Label 2" + attributes(dataset_list_valid$dummy3)$label <- "My Label 3" + current_data_valid <- dataset_list_valid[[1]] + data_selection_name_valid <- names(dataset_list_valid)[1] + + # result + res <- prep_export_data( + data_selection_valid, + current_data_valid, + data_selection_name_valid, + dataset_list_valid + ) + + # perform tests + expect_identical(names(res), c("dummy1 (My Label 1)", "dummy2 (My Label 2)", "dummy3 (My Label 3)")) + expect_identical(res[[1]], set_labels(data.frame(sapply(dataset_list_valid[[1]], as.character)))) + expect_identical(res[[2]], set_labels(data.frame(sapply(dataset_list_valid[[2]], as.character)))) + expect_identical(res[[3]], set_labels(data.frame(sapply(dataset_list_valid[[3]], as.character)))) + }) test_that("prep_export_data() shortens dataset names if they exceed Excel's sheet name limit of 31 characters", { # arguments @@ -517,12 +527,12 @@ test_that("prep_export_data() shortens dataset names if they exceed Excel's shee attributes(dataset_list_valid$dummy3)$label <- "Short label" current_data_valid <- dataset_list_valid[[1]] data_selection_name_valid <- names(dataset_list_valid)[1] - + # result res <- nchar( names(prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid)) ) - + # perform tests expect_identical(res, as.integer(c(31, 31, 20))) }) @@ -534,50 +544,51 @@ test_that("excel_export() throws an error when argument types mismatch", { data_to_download_invalid <- list(c("wrong", "type"), list(1, 2, "no dataframe"), NULL) file_valid <- "./testfile.xlsx" file_invalid <- list(42, "./testfile.pdf") - + # perform tests purrr::walk(data_to_download_invalid, ~ expect_error(excel_export(.x, file_valid))) purrr::walk(file_invalid, ~ expect_error(excel_export(data_to_download_valid, .x))) }) -test_that("excel_export() exports the .xlsx file as intended", { - # arguments - data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) - file <- paste0(getwd(), "/testfile.xlsx") - - # result - excel_export(data_to_download, file, intended_use_label = "") - res_sheet2 <- openxlsx::read.xlsx(file, "dummy2", sep.names = " ") - - # expected - exp_sheet2 <- data_to_download$dummy2 - rownames(exp_sheet2) <- seq_len(nrow(exp_sheet2)) - colnames(exp_sheet2) <- paste0(colnames(exp_sheet2), " [", get_labels(exp_sheet2), "]") - - # perform tests - expect_equal(res_sheet2, exp_sheet2) - - # remove file - file.remove(file) -}) +test_that("excel_export() exports the .xlsx file as intended" %>% + vdoc[["add_spec"]](specs$export_excel), { + # arguments + data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) + file <- paste0(getwd(), "/testfile.xlsx") + + # result + excel_export(data_to_download, file, intended_use_label = "") + res_sheet2 <- openxlsx::read.xlsx(file, "dummy2", sep.names = " ") + + # expected + exp_sheet2 <- data_to_download$dummy2 + rownames(exp_sheet2) <- seq_len(nrow(exp_sheet2)) + colnames(exp_sheet2) <- paste0(colnames(exp_sheet2), " [", get_labels(exp_sheet2), "]") + + # perform tests + expect_equal(res_sheet2, exp_sheet2) + + # remove file + file.remove(file) + }) test_that("excel_export() generates the .xlsx file with a leading worksheet containing the disclaimer", { # arguments data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) file <- paste0(getwd(), "/testfile.xlsx") - + # result excel_export(data_to_download, file, intended_use_label = "test label") res_info_sheet <- openxlsx::read.xlsx(file, 1, sep.names = " ", colNames = FALSE) # 1 = leading # nolint colnames(res_info_sheet) <- NULL - + # expected exp_info_sheet <- data.frame(c(EXP$EXP_TITLE, "test label")) colnames(exp_info_sheet) <- NULL - + # perform tests expect_equal(res_info_sheet, exp_info_sheet) - + # remove file file.remove(file) }) @@ -599,7 +610,7 @@ test_that("pdf_export() throws an error when argument types mismatch", { file_invalid <- list(42, "./testfile.xlsx") metadata_valid <- c("text 1", "text 2", "text 3") metadata_invalid <- list(42, c("too", "many", "header/footer", "components")) - + # perform tests purrr::walk(data_to_download_invalid, ~ expect_error(pdf_export( .x, ref_valid, file_valid, metadata_valid, FALSE @@ -615,22 +626,23 @@ test_that("pdf_export() throws an error when argument types mismatch", { ))) }) -test_that("pdf_export() exports the .pdf file as intended", { - # arguments - data_to_download <- list("dummy_data" = simple_dummy) - ref <- c("var2 [No label]") - file <- paste0(getwd(), "/testfile.pdf") - metadata <- c("text 1", "text 2", "text 3") - - # result - pdf_export(data_to_download, ref, file, metadata, FALSE, "") - - # perform tests - expect_true(file.exists(file)) - - # remove file - file.remove(file) -}) +test_that("pdf_export() exports the .pdf file as intended" %>% + vdoc[["add_spec"]](specs$export_pdf), { + # arguments + data_to_download <- list("dummy_data" = simple_dummy) + ref <- c("var2 [No label]") + file <- paste0(getwd(), "/testfile.pdf") + metadata <- c("text 1", "text 2", "text 3") + + # result + pdf_export(data_to_download, ref, file, metadata, FALSE, "") + + # perform tests + expect_true(file.exists(file)) + + # remove file + file.remove(file) + }) test_that("pdf_export() generates the .pdf file with a title page containing the disclaimer", { skip("Setting titles and subtitles is Rmarkdown functionality and therefore not tested additionally.") @@ -646,7 +658,7 @@ test_that("warn_function() throws an error when argument types mismatch", { input_id_invalid <- list(NULL, 42) text_valid <- "warning" text_invalid <- list(c("wrong", "type")) - + # perform tests purrr::walk(cond_invalid, ~ expect_error(warn_function(.x, input_id_valid, text_valid))) purrr::walk(input_id_invalid, ~ expect_error(warn_function(cond_valid, .x, text_valid))) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 40f8b18..05267ba 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -4,14 +4,14 @@ source("dummy-data.R") test_that("fill_default_vars() throws an error when dataset argument type mismatches", { # Correct default_vars argument default_vars <- NULL - + # Wrong dataset arguments type_mismatch <- "Not a list." # wrong argument type element_mismatch <- list(a = letters[1:6], b = 1:10) # wrong list element types unnamed <- list(simple_dummy, data.frame(test = 1:10)) # missing names duplicated_names <- list(data1 = simple_dummy, data1 = data.frame(test = 1:10)) # duplicated names inexistent <- NULL # no data - + # Perform tests purrr::walk( list(type_mismatch, element_mismatch, unnamed, duplicated_names, inexistent), @@ -21,9 +21,9 @@ test_that("fill_default_vars() throws an error when dataset argument type mismat test_that("fill_default_vars() throws an error when default_vars argument type mismatches", { dummy_names <- names(simple_dummy) - + # Wrong default_vars argument - + type_mismatch <- "Not a list." # wrong argument type element_mismatch <- list(dummy1 = 1:6, dummy2 = 1:10) # wrong list element types unnamed <- list(dummy_names[1:4], dummy_names[1:8]) # missing names @@ -33,10 +33,10 @@ test_that("fill_default_vars() throws an error when default_vars argument type m dummy1 = c(dummy_names[1:4], dummy_names[1:2]), dummy2 = dummy_names[1:8] ) wrong_values <- list(dummy1 = c(dummy_names[1:4], "wrong"), dummy2 = dummy_names[1:8]) # wrong vector entries - + # Correct dataset argument dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) - + # Perform tests purrr::walk(list( type_mismatch, element_mismatch, unnamed, duplicated_names, wrong_names, duplicated_values, wrong_values @@ -47,11 +47,11 @@ test_that("fill_default_vars() returns default_vars without transformation", { # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) default_vars <- list(dummy1 = names(simple_dummy)[1:4], dummy2 = names(simple_dummy)[1:8]) - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- default_vars - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -60,11 +60,11 @@ test_that("fill_default_vars() fills all entries of default_vars witth 6 column # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) default_vars <- NULL - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list(dummy1 = names(simple_dummy)[1:6], dummy2 = names(simple_dummy)[1:6]) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -73,13 +73,13 @@ test_that("fill_default_vars() fills single missing entry of default_vars with 6 # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy, dummy3 = simple_dummy) default_vars <- list(dummy1 = names(simple_dummy)[1:4], dummy3 = names(simple_dummy)[1:8]) - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list( dummy1 = names(simple_dummy)[1:4], dummy2 = names(simple_dummy)[1:6], dummy3 = names(simple_dummy)[1:8] ) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -88,13 +88,13 @@ test_that("fill_default_vars() fills default_vars only with available columns in # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy[, 1:4], dummy3 = simple_dummy[, 1:2]) default_vars <- NULL - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list( dummy1 = names(simple_dummy)[1:6], dummy2 = names(simple_dummy)[1:4], dummy3 = names(simple_dummy)[1:2] ) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -106,7 +106,7 @@ test_that("get_labels() throws an error when argument type mismatches", { type_mismatch <- "Not a data.frame or list" # wrong argument type element_mismatch <- list(a = letters[1:6], b = 1:10) # wrong list element types unnamed <- list(simple_dummy, data.frame(test = 1:10)) # missing names - + # Perform tests purrr::walk(list(type_mismatch, element_mismatch, unnamed), ~ expect_error(get_labels(.x))) }) @@ -116,7 +116,7 @@ test_that("get_labels() returns column labels of a data.frame in a character vec df <- simple_dummy[, 1:3] labels <- c("Label 1", "Label 2", "Label 3") purrr::walk2(names(df), labels, function(x, y) attributes(df[[x]])$label <<- y) - + # Perform test col_labs <- get_labels(df) expect_equal(col_labs, labels, ignore_attr = TRUE) # check only values @@ -130,7 +130,7 @@ test_that("get_labels() returns labels for each element of a list of data.frames df_list <- list(dummy1 = simple_dummy[, 1:3], dummy2 = simple_dummy) labels <- c("First label", "Second label") purrr::walk2(names(df_list), labels, function(x, y) attributes(df_list[[x]])$label <<- y) - + # Perform test df_labs <- get_labels(df_list) expect_equal(df_labs, labels, ignore_attr = TRUE) # check only values @@ -144,7 +144,7 @@ test_that("get_labels() returns NULL when the argument is empty or NULL", { empty_df <- data.frame() empty_list <- list() null_arg <- NULL - + # Perform tests purrr::walk(list(empty_df, empty_list, null_arg), ~ expect_null(get_labels(.x))) }) @@ -153,7 +153,7 @@ test_that("get_labels() substitutes missing labels with a 'No label' entry in th # We can directly use simple_dummy as it has no column labels missing_labs <- get_labels(simple_dummy) expected_labs <- rep("No label", times = ncol(simple_dummy)) - + # Perform test expect_equal(missing_labs, expected_labs, ignore_attr = TRUE) }) @@ -176,22 +176,27 @@ attributes(df1)$label <- "Test data 1" attributes(df1$mpg)$label <- "Col label 1" attributes(df1$type)$label <- "Col label 2" -test_that("generate_choices() generates meaningful choices for datasets and columns to be used in the corresponding dropdown menues", { # nolint - df_list <- list(first = df1, second = df2) - - expected_df <- c("first [Test data 1]" = "first", "second [No label]" = "second") - actual_df <- generate_choices(df_list) - expect_equal(expected_df, actual_df) - - expected_col <- c( - "mpg [Col label 1]" = "mpg", - "cyl [No label]" = "cyl", - "disp [No label]" = "disp", - "type [Col label 2]" = "type" - ) - actual_col <- generate_choices(df1) - expect_equal(expected_col, actual_col) -}) +test_that("generate_choices() generates meaningful choices for datasets and columns to be used in the corresponding dropdown menues" %>% # nolint + vdoc[["add_spec"]]( + c(specs$listings_label, + specs$column_label + ) + ), { + df_list <- list(first = df1, second = df2) + + expected_df <- c("first [Test data 1]" = "first", "second [No label]" = "second") + actual_df <- generate_choices(df_list) + expect_equal(expected_df, actual_df) + + expected_col <- c( + "mpg [Col label 1]" = "mpg", + "cyl [No label]" = "cyl", + "disp [No label]" = "disp", + "type [Col label 2]" = "type" + ) + actual_col <- generate_choices(df1) + expect_equal(expected_col, actual_col) + }) test_that("set_data() throws an error when at leat one argument type mismatches", { @@ -204,11 +209,11 @@ test_that("set_data() throws an error when at leat one argument type mismatches" dimnames = list(c("row1", "row2"), c("C.1", "C.2", "C.3")) ) df <- simple_dummy - + ## ... for selector parameter not_char <- c(1, 2) char <- c("C.1", "C.2") - + # Perform tests expect_error(set_data(not_df, char)) expect_error(set_data(df, not_char)) @@ -226,7 +231,7 @@ test_that("set_data() returns a named list containing a data.frame, a character rows <- as.character(seq_len(nrow(df))) outcome <- set_data(df, selection) expected_names <- c("data", "col_names", "row_names") - + # Perform tests expect_type(outcome, "list") expect_length(outcome, 3) @@ -241,7 +246,7 @@ test_that("set_data() returns a character of length zero as row_names if data ha df <- simple_dummy[0, ] selection <- names(df)[1:3] outcome <- set_data(df, selection) - + # Perform tests testthat::expect_true(length(outcome[["row_names"]]) == 0) }) @@ -251,7 +256,7 @@ test_that("set_data() reduces the columns of base_data to those specified in sel df <- simple_dummy selection <- names(df)[3:5] outcome <- set_data(df, selection) - + # Perform tests checkmate::expect_data_frame(outcome[["data"]], ncols = length(selection)) expect_named(outcome[["data"]], selection) @@ -262,7 +267,7 @@ test_that("set_data() orders the columns of the returned data.frame according to df <- simple_dummy selection <- names(df)[5:3] outcome <- set_data(df, selection) - + # Perform test expect_named(outcome[["data"]], selection) }) @@ -274,7 +279,7 @@ test_that("set_data() creates descriptive column names consisting of the column purrr::walk2(names(df), labels, function(x, y) attributes(df[[x]])$label <<- y) expected <- c("var1 [First label]", "var2 [Second label]") outcome <- set_data(df, selector = names(df)[1:2]) - + # Perform test expect_equal(outcome[["col_names"]], expected) }) @@ -284,7 +289,7 @@ test_that("set_data() creates descriptive column names consisting of the column test_that("set_data() throws an error when argument type mismatches", { # Initialize test case df <- as.list(simple_dummy) - + # Perform test expect_error(convert_data(df)) }) @@ -294,13 +299,13 @@ test_that("set_data() returns the data.frame with converted column data types an df <- data.frame(A = c("a", "b", "c"), B = c("1", "2", "3")) attributes(df$A)$label <- "Character column" attributes(df$B)$label <- "Numeric column" - + # Perform test conv_df <- convert_data(df) - + expect_equal(attributes(conv_df$A)$label, attributes(df$A)$label) expect_equal(attributes(conv_df$B)$label, attributes(df$B)$label) - + expect_equal(class(conv_df$A), "factor") expect_equal(class(conv_df$B), "integer") }) @@ -309,15 +314,15 @@ test_that("set_data() returns the data.frame with converted column data types an test_that("set_up_datatable() returns correct column names, row names, and paging", { df <- data.frame(A = c("a", "b", "c"), B = c("1", "2", "3"), C = c("a", "b", "c")) - + attributes(df$A)$label <- "Label A" attributes(df$C)$label <- "Label C" - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expected <- list( col_names = c("A [Label A]", "B [No label]", "C [Label C]"), row_names = c("1", "2", "3"), @@ -332,12 +337,12 @@ test_that("set_up_datatable() automatically activates pagination for large datas B = sample(c("1", "2", "3"), 1001, replace = TRUE), C = sample(c("a", "b", "c"), 1001, replace = TRUE) ) - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expect_true(actual$paging) }) @@ -347,11 +352,11 @@ test_that("set_up_datatable() automatically deactivates pagination for small dat B = sample(c("1", "2", "3"), 100, replace = TRUE), C = sample(c("a", "b", "c"), 100, replace = TRUE) ) - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expect_false(actual$paging) }) diff --git a/tests/testthat/test-mod_export_listings.R b/tests/testthat/test-mod_export_listings.R index 592a6fa..00a64e7 100644 --- a/tests/testthat/test-mod_export_listings.R +++ b/tests/testthat/test-mod_export_listings.R @@ -28,7 +28,7 @@ test_that("mod_export_listings_UI fails when argument type mismatches", { test_that("mod_export_listings_UI returns a shiny tagList with three elements", { ui <- mod_export_listings_UI("test") - + checkmate::expect_list(ui, len = 3) checkmate::expect_class(ui, "shiny.tag.list") }) @@ -40,7 +40,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { 3, # wrong type "" # less than one character ) - + dataset_metadata_valid <- list( name = shiny::reactive("test"), date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) @@ -51,7 +51,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { list(name = shiny::reactive("test"), name = shiny::reactive("test2")), # not unique list(test1 = shiny::reactive("test"), test2 = shiny::reactive(c("01-01-2000", "01-01-2000"))) # wrong names ) - + dataset_list_valid <- shiny::reactive({ list(dm = dm_dummy, ae = ae_dummy) }) @@ -67,28 +67,28 @@ test_that("mod_export_listings_server fails when argument type mismatches", { list(dm_dummy, ae_dummy) }) # unnamed ) - + data_valid <- shiny::reactive({ list(data = dm_dummy, col_names = colnames(ae_dummy)) }) data_invalid <- list( c("wrong", "type") # wrong type ) - + data_selection_name_valid <- shiny::reactive("dm") data_selection_name_invalid <- list( shiny::reactive({ 3 }) # wrong type ) - + current_rows_valid <- shiny::reactive(seq_len(dim(dm_dummy)[2])) current_rows_invalid <- list( shiny::reactive({ c("wrong", "type") }) # wrong type ) - + # execute invalid test cases purrr::walk(id_invalid, ~ expect_error( shiny::testServer( @@ -193,7 +193,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { ) ) )) - + # verify that valid arguments launch the server as intended expect_success( shiny::testServer( @@ -216,50 +216,51 @@ test_that("mod_export_listings_server fails when argument type mismatches", { ) }) -test_that("mod_export_listings_server updates file type choices when switching between single and all datasets", { - # server arguments - id <- "test" - dataset_metadata <- list( - name = shiny::reactive("test"), - date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) - ) - dataset_list <- shiny::reactive({ - list(dm = dm_dummy, ae = ae_dummy) - }) - data <- shiny::reactive({ - list(data = dm_dummy, col_names = colnames(dm_dummy)) - }) - data_selection_name <- shiny::reactive("dm") - current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - - # perform tests - shiny::testServer( - app = server_func, - expr = { - # initial expectation - # note: id is hard coded because pack of constants cannot be used within session$setInputs() - session$setInputs(which_data = "single") - actual_choices <- type_choices() - expected_choices <- c("Excel" = ".xlsx", "PDF" = ".pdf") - expect_equal(actual_choices, expected_choices) - - # after selection switch - session$setInputs(which_data = "all") - actual_choices <- type_choices() - expected_choices <- c("Excel" = ".xlsx") - expect_equal(actual_choices, expected_choices) - }, - args = list( - id = id, - dataset_metadata = dataset_metadata, - dataset_list = dataset_list, - data = data, - data_selection_name = data_selection_name, - current_rows = current_rows, - intended_use_label = NULL - ) - ) -}) +test_that("mod_export_listings_server updates file type choices when switching between single and all datasets" %>% # nolint + vdoc[["add_spec"]](specs$export), { + # server arguments + id <- "test" + dataset_metadata <- list( + name = shiny::reactive("test"), + date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) + ) + dataset_list <- shiny::reactive({ + list(dm = dm_dummy, ae = ae_dummy) + }) + data <- shiny::reactive({ + list(data = dm_dummy, col_names = colnames(dm_dummy)) + }) + data_selection_name <- shiny::reactive("dm") + current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) + + # perform tests + shiny::testServer( + app = server_func, + expr = { + # initial expectation + # note: id is hard coded because pack of constants cannot be used within session$setInputs() + session$setInputs(which_data = "single") + actual_choices <- type_choices() + expected_choices <- c("Excel" = ".xlsx", "PDF" = ".pdf") + expect_equal(actual_choices, expected_choices) + + # after selection switch + session$setInputs(which_data = "all") + actual_choices <- type_choices() + expected_choices <- c("Excel" = ".xlsx") + expect_equal(actual_choices, expected_choices) + }, + args = list( + id = id, + dataset_metadata = dataset_metadata, + dataset_list = dataset_list, + data = data, + data_selection_name = data_selection_name, + current_rows = current_rows, + intended_use_label = NULL + ) + ) + }) test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) ticked", { # server arguments @@ -276,7 +277,7 @@ test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) }) data_selection_name <- shiny::reactive("dm") current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - + # perform tests shiny::testServer( app = server_func, @@ -288,7 +289,7 @@ test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) actual_label <- gsub("[\r\n] *", "", actual_label) # remove newline tags and multiple spacing expected_label <- paste(EXP$DATAPROTECT_LABEL, intended_use_label) expect_equal(actual_label, expected_label) - + # after further selection switch session$setInputs(check = FALSE) # name must be set manually to avoid errors actual_label <- checkbox_label() @@ -309,7 +310,7 @@ test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) ) }) -test_that("mod_export_listings_server en-/disables download button if prerequesites are (not) met}", { +test_that("mod_export_listings_server en-/disables download button if prerequesites are (not) met", { # server arguments id <- "test" dataset_metadata <- list( @@ -324,7 +325,7 @@ test_that("mod_export_listings_server en-/disables download button if prerequesi }) data_selection_name <- shiny::reactive("dm") current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - + # perform tests shiny::testServer( app = server_func, @@ -332,11 +333,11 @@ test_that("mod_export_listings_server en-/disables download button if prerequesi # ticking the checkbox and inserting file name should enable download button session$setInputs(name = "name", check = TRUE) expect_equal(download_enable(), TRUE) - + # removing file name should disable download button session$setInputs(name = "") expect_equal(download_enable(), FALSE) - + # reentering file name should enable download button session$setInputs(name = "test") expect_equal(download_enable(), TRUE) @@ -363,22 +364,23 @@ test_that("mod_export_listings_server places exported files in the local downloa app_dir <- "./apps/mm_app" -test_that("mock_listings_mm exports all pages when downloading the currently displayed table in case of pagination turned on", { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_row_order" - ) - - # Click buttons - app$wait_for_idle() - app$click("multi-export-download_data") - app$wait_for_idle() - - # Check if length(current_rows()) > 10 (more than one page) - testthat::expect_identical( - length(app$get_value(export = "multi-export-current_rows")), - as.integer(100) - ) - - app$stop() -}) +test_that("mock_listings_mm exports all pages when downloading the currently displayed table in case of pagination turned on" %>% # nolint + vdoc[["add_spec"]](specs$export_active_listing), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_row_order" + ) + + # Click buttons + app$wait_for_idle() + app$click("multi-export-download_data") + app$wait_for_idle() + + # Check if length(current_rows()) > 10 (more than one page) + testthat::expect_identical( + length(app$get_value(export = "multi-export-current_rows")), + as.integer(100) + ) + + app$stop() + }) diff --git a/tests/testthat/test-mod_listing.R b/tests/testthat/test-mod_listing.R index 45e6d25..500cf42 100644 --- a/tests/testthat/test-mod_listing.R +++ b/tests/testthat/test-mod_listing.R @@ -17,7 +17,7 @@ test_that("listings_server() fails when argument type mismatches", { id_valid <- "test" id_num <- 3 id_zero <- "" - + data_valid <- shiny::reactive({ list(dm = dm_dummy, ae = ae_dummy) }) @@ -25,12 +25,12 @@ test_that("listings_server() fails when argument type mismatches", { data_no_list <- shiny::reactive(ae_dummy) data_null <- shiny::reactive(NULL) data_unnamed <- shiny::reactive(list(dm_dummy, ae_dummy)) - + cols_valid <- list(dm = "USUBJID", ae = c("AETERM", "AESEV")) cols_null <- NULL cols_no_list <- "USUBJID" cols_unnamed <- list("USUBJID", c("AETERM", "AESEV")) - + metadata_valid <- list( name = shiny::reactive("test"), date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) @@ -42,18 +42,18 @@ test_that("listings_server() fails when argument type mismatches", { test1 = shiny::reactive("test"), test2 = shiny::reactive(c("01-01-2000", "31-12-2000")) ) - + pagination_valid <- NULL pagination_num <- 1 pagination_char <- "wrong" - + # Cases that expect an error test_id <- list(id_num, id_zero) # list to preserve types test_dataset_list <- list(data_no_df, data_no_list, data_unnamed) test_cols <- list(cols_no_list, cols_unnamed) test_metadata <- list(metadata_wrong_type, metadata_unnamed, metadata_not_unique, metadata_wrong_names) test_pagination <- list(pagination_num, pagination_char) - + # Execute test cases purrr::walk(test_id, ~ expect_error( shiny::testServer(server_func, args = list( @@ -87,7 +87,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) - + purrr::walk(test_metadata, ~ expect_error( shiny::testServer(server_func, args = list( id = id_valid, dataset_list = data_valid, @@ -98,7 +98,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) # test dataset_metadata parameter - + purrr::walk(test_pagination, ~ expect_error( shiny::testServer(server_func, args = list( id = id_valid, dataset_list = data_valid, @@ -109,7 +109,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) # test pagination parameter - + # Verify that valid arguments launch the server as intended expect_success( shiny::testServer( @@ -130,60 +130,62 @@ test_that("listings_server() fails when argument type mismatches", { ) }) -test_that("listings_server() saves default_vars in the selected_columns_in_dataset at app launch", { - # Prepare test parameters - dataset_list <- list(dm = dm_dummy, ae = ae_dummy) - default_vars <- list(dm = c("USUBJID", "AGE", "SEX"), ae = c("USUBJID", "AETERM", "AESEV")) - dataset_metadata <- list( - name = shiny::reactive("trial_xy"), - date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) - ) - - # Perform tests - shiny::testServer( - server_func, - args = list( - dataset_list = shiny::reactive({ - dataset_list - }), - default_vars = default_vars, - dataset_metadata = dataset_metadata, - intended_use_label = NULL - ), - { - expect_equal(r_selected_columns_in_dataset(), default_vars) - } - ) -}) - -test_that("listings_server() adds default variables, if not specified by the app creator", { - # Prepare test parameters - dataset_list <- list(dm = dm_dummy, ae = ae_dummy) - default_vars <- list(dm = c("USUBJID", "AGE", "SEX")) - expected_cols <- default_vars %>% - purrr::list_modify(ae = names(dataset_list$ae)[1:6]) - dataset_metadata <- list( - name = shiny::reactive("trial_xy"), - date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) - ) - - # Perform tests - shiny::testServer( - server_func, - args = list( - dataset_list = shiny::reactive({ - dataset_list - }), - default_vars = default_vars, - dataset_metadata = dataset_metadata, - intended_use_label = NULL - ), - { - session$setInputs(dataset = "ae") - expect_equal(r_selected_columns_in_dataset(), expected_cols) - } - ) -}) +test_that("listings_server() saves default_vars in the selected_columns_in_dataset at app launch" %>% + vdoc[["add_spec"]](specs$default_vars), { + # Prepare test parameters + dataset_list <- list(dm = dm_dummy, ae = ae_dummy) + default_vars <- list(dm = c("USUBJID", "AGE", "SEX"), ae = c("USUBJID", "AETERM", "AESEV")) + dataset_metadata <- list( + name = shiny::reactive("trial_xy"), + date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) + ) + + # Perform tests + shiny::testServer( + server_func, + args = list( + dataset_list = shiny::reactive({ + dataset_list + }), + default_vars = default_vars, + dataset_metadata = dataset_metadata, + intended_use_label = NULL + ), + { + expect_equal(r_selected_columns_in_dataset(), default_vars) + } + ) + }) + +test_that("listings_server() adds default variables, if not specified by the app creator" %>% + vdoc[["add_spec"]](specs$default_vars), { + # Prepare test parameters + dataset_list <- list(dm = dm_dummy, ae = ae_dummy) + default_vars <- list(dm = c("USUBJID", "AGE", "SEX")) + expected_cols <- default_vars %>% + purrr::list_modify(ae = names(dataset_list$ae)[1:6]) + dataset_metadata <- list( + name = shiny::reactive("trial_xy"), + date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) + ) + + # Perform tests + shiny::testServer( + server_func, + args = list( + dataset_list = shiny::reactive({ + dataset_list + }), + default_vars = default_vars, + dataset_metadata = dataset_metadata, + intended_use_label = NULL + ), + { + session$setInputs(dataset = "ae") + expect_equal(r_selected_columns_in_dataset(), expected_cols) + } + ) + }) app_dir <- "./apps/bookmarking_app" @@ -194,77 +196,84 @@ app <- shinytest2::AppDriver$new( app_dir <- app$get_url() -test_that("listings_server() stores the selected_columns_in_dataset and the currently selected dataset for bookmarking", { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_on_bookmark_TAB-SO-763" - ) - - app_dir <- app$get_url() - - app$set_inputs(`listings-dataset` = "dummy2") - app$wait_for_idle() # make sure inputs are updated before bookmarking - app$set_inputs(`listings-col_sel` = c("var2", "var4")) - app$wait_for_idle() - app$set_inputs(!!"._bookmark_" := "click") - - tst <- app$get_value(export = "state") - bmk_url <- app$get_value(export = "url") - query_string_list <- parseQueryString(bmk_url, nested = TRUE) - - expected_elements <- c("dummy1", "var1", "var2", "var3", "dummy2", "var2", "var4") - exist <- purrr::map2_lgl(expected_elements, query_string_list$`listings-selected_columns_in_dataset`, grepl) - - testthat::expect_true(all(exist)) - testthat::expect_true(grepl("dummy2", query_string_list$`listings-data_sel`)) -}) - -test_that("listings_server() restores the selected_columns_in_dataset and the currently selected dataset for bookmarking", { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_bookmark_TAB-SO-777" - ) - - # Capture the background app's URL and add appropriate query parameters - bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=2&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint - # Open the bookmark URL in a new AppDriver object - app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_restore_bookmark") - - actual <- app$get_values(export = c("listings-selected_columns_in_dataset", "listings-data_sel")) - - expected <- list(export = list( - `listings-selected_columns_in_dataset` = list( - dummy1 = c("var1", "var2", "var3"), - dummy2 = c("var2", "var4") - ) - )) - - testthat::expect_equal(actual, expected) -}) - -test_that("listings_server() allows bookmarking for dataset and column selections", { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_on_bookmark_TAB-SO-777" - ) - - # Capture the background app's URL and add appropriate query parameters - bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=1&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint - - # Open the bookmark URL in a new AppDriver object - app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_on_bookmark") - - actual <- app$get_values(input = c("listings-dataset", "listings-col_sel")) - - expected <- list(input = list( - `listings-col_sel` = c("var2", "var4"), - `listings-dataset` = "dummy2" - )) - - testthat::expect_equal(actual, expected) - - app$stop() -}) +test_that("listings_server() stores the selected_columns_in_dataset and the currently selected dataset for bookmarking" %>% # nolint + vdoc[["add_spec"]](specs$retain_last_selection), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_on_bookmark_TAB-SO-763" + ) + + app_dir <- app$get_url() + + app$set_inputs(`listings-dataset` = "dummy2") + app$wait_for_idle() # make sure inputs are updated before bookmarking + app$set_inputs(`listings-col_sel` = c("var2", "var4")) + app$wait_for_idle() + app$set_inputs(!!"._bookmark_" := "click") + + tst <- app$get_value(export = "state") + bmk_url <- app$get_value(export = "url") + query_string_list <- parseQueryString(bmk_url, nested = TRUE) + + expected_elements <- c("dummy1", "var1", "var2", "var3", "dummy2", "var2", "var4") + exist <- purrr::map2_lgl( + expected_elements, + query_string_list$`listings-selected_columns_in_dataset`, + grepl + ) + + testthat::expect_true(all(exist)) + testthat::expect_true(grepl("dummy2", query_string_list$`listings-data_sel`)) + }) + +test_that("listings_server() restores the selected_columns_in_dataset and the currently selected dataset for bookmarking" %>% # nolint + vdoc[["add_spec"]](specs$retain_last_selection), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_bookmark_TAB-SO-777" + ) + + # Capture the background app's URL and add appropriate query parameters + bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=2&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint + # Open the bookmark URL in a new AppDriver object + app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_restore_bookmark") + + actual <- app$get_values(export = c("listings-selected_columns_in_dataset", "listings-data_sel")) + + expected <- list(export = list( + `listings-selected_columns_in_dataset` = list( + dummy1 = c("var1", "var2", "var3"), + dummy2 = c("var2", "var4") + ) + )) + + testthat::expect_equal(actual, expected) + }) + +test_that("listings_server() allows bookmarking for dataset and column selections" %>% + vdoc[["add_spec"]](specs$bookmarking), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_on_bookmark_TAB-SO-777" + ) + + # Capture the background app's URL and add appropriate query parameters + bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=1&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint + + # Open the bookmark URL in a new AppDriver object + app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_on_bookmark") + + actual <- app$get_values(input = c("listings-dataset", "listings-col_sel")) + + expected <- list(input = list( + `listings-col_sel` = c("var2", "var4"), + `listings-dataset` = "dummy2" + )) + + testthat::expect_equal(actual, expected) + + app$stop() + }) test_that("listings_server() displays default columns after SSO redirect", { skip("Cannot integrate SSO in unit test, i.e. this test has to be performed manually.") @@ -280,27 +289,27 @@ 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") - + names_test_cases <- list(dataset_names_no_chr, dataset_names_list) - + # Perform tests purrr::walk(names_test_cases, ~ expect_error(mod_listings(dataset_names = .x, module_id = "test_id"))) }) @@ -308,10 +317,10 @@ test_that("mod_listings() fails when argument types mismatch", { 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)) }) @@ -320,10 +329,10 @@ test_that("mod_listings() returns a list containing all information for dv.manag # Valid parameters disp <- dv.manager::mm_dispatch("filtered_dataset", "adsl") id <- "test_id" - + # Return value outcome <- mod_listings(dataset_disp = disp, module_id = id) - + # 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 @@ -334,48 +343,55 @@ test_that("mod_listings() returns a list containing all information for dv.manag -test_that("mod_listings() displays a data table, dataset selector and corresponding column selector at app launch", { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_initial_state" - ) - - dataset_sel <- app$get_value(input = "listings-dataset") - column_sel <- app$get_value(input = "listings-col_sel") - table_out <- app$get_value(output = "listings-listing") - - # Verify that required elements exist - testthat::expect_true(!is.null(dataset_sel) && !is.null(column_sel) && !is.null(table_out)) -}) - -test_that("mod_listings() restores row order of the whole table when restoring a sorted variable", { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_row_order" - ) - - # Needed buttons to click - sort_selector <- '.dt-center.sorting[aria-label="var1 [My 1st label]: activate to sort column ascending"]' - reset_selector <- "div.dt-buttons>button" - - # Perform steps within test app - app$wait_for_idle() - initial_rows <- (app$get_values(input = "listings-listing_rows_all"))[["input"]][["listings-listing_rows_all"]] - app$click(selector = sort_selector) - app$wait_for_idle() - sorted_rows <- (app$get_values(input = "listings-listing_rows_all"))[["input"]][["listings-listing_rows_all"]] - app$click(selector = reset_selector) - app$wait_for_idle() - reset_rows <- (app$get_values(input = "listings-listing_rows_all"))[["input"]][["listings-listing_rows_all"]] - - # Perform test that row order changed and then gets restored - testthat::expect_false(all(initial_rows == sorted_rows)) - testthat::expect_identical(initial_rows, reset_rows) -}) - -test_that("mod_listings() restores even from nested variable sorting", { - skip("Nested variable sorting not available.") -}) +test_that("mod_listings() displays a data table, dataset selector and corresponding column selector at app launch" %>% + vdoc[["add_spec"]]( + c(specs$display_listing, + specs$listing_selection, + specs$column_selection + ) + ), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_initial_state" + ) + + dataset_sel <- app$get_value(input = "listings-dataset") + column_sel <- app$get_value(input = "listings-col_sel") + table_out <- app$get_value(output = "listings-listing") + + # Verify that required elements exist + testthat::expect_true(!is.null(dataset_sel) && !is.null(column_sel) && !is.null(table_out)) + }) + +test_that("mod_listings() restores row order of the whole table when restoring a sorted variable" %>% + vdoc[["add_spec"]]( + c(specs$restore_row_order, + specs$sorting_columns + ) + ), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_row_order" + ) + + # Needed buttons to click + sort_selector <- '.dt-center.sorting[aria-label="var1 [My 1st label]: activate to sort column ascending"]' + reset_selector <- "div.dt-buttons>button" + + # Perform steps within test app + app$wait_for_idle() + initial_rows <- app$get_value(input = "listings-listing_rows_all") + app$click(selector = sort_selector) + app$wait_for_idle() + sorted_rows <- app$get_value(input = "listings-listing_rows_all") + app$click(selector = reset_selector) + app$wait_for_idle() + reset_rows <- app$get_value(input = "listings-listing_rows_all") + + # Perform test that row order changed and then gets restored + testthat::expect_false(all(initial_rows == sorted_rows)) + testthat::expect_identical(initial_rows, reset_rows) + }) app_dir <- "./apps/mm_app" # applies for all tests within this describe() @@ -390,7 +406,7 @@ test_that("mock_listings_mm() launches successfully the module via dv.manager", app_dir = app_dir, name = "test_launch_mm" ) app$wait_for_idle() - + value_list <- app$get_values( input = c("multi-dataset", "multi-col_sel"), export = "multi-output_table" @@ -398,68 +414,70 @@ test_that("mock_listings_mm() launches successfully the module via dv.manager", # check availability of: # values for dataset and column selection # output dataframe - + # Only the existence of values are checked not the actual values col_sel <- length(value_list[["input"]][["multi-col_sel"]]) > 0 data_sel <- length(value_list[["input"]][["multi-dataset"]]) == 1 - + out_table <- (nrow(value_list[["export"]][["multi-output_table"]]) > 0 && - ncol(value_list[["export"]][["multi-output_table"]]) > 0) # nolint - + ncol(value_list[["export"]][["multi-output_table"]]) > 0) # nolint + # Verify that module can be launched via module manager by expecting values for selectors and a output dataframe testthat::expect_true((col_sel && data_sel && out_table)) }) # integration -test_that("mock_table_mm() displays the column names with the corresponding labels", { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_col_labels_TAB-SO-760" - ) - - expected <- c( - "STUDYID [No label]", "DOMAIN [Domain Abbreviation]", - "USUBJID [Unique Subject Identifier]", "SUBJID [Subject Identifier for the Study]", - "RFSTDTC [Subject Reference Start Date/Time]", "RFENDTC [Subject Reference End Date/Time]", - "RFXSTDTC [Date/Time of First Study Treatment]", "RFXENDTC [Date/Time of Last Study Treatment]" - ) - - actual <- app$get_value(export = "multi-column_names") - - # Verify that dataset choices are displayed properly with their labels - testthat::expect_equal(actual, expected) -}) - -test_that("mock_table_mm() updates dropdown choices on dataset change in dv.manager", { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_update_labels" - ) - - expected <- c( - "adsl [Subject Level]" = "adsl", - "adae [Adverse Events]" = "adae", - "small [Few columns]" = "small" - ) - - actual <- app$get_value(export = "multi-dataset_choices") - - # Verify that dataset choices are displayed properly with their labels - testthat::expect_equal(actual, expected = expected) - - # Switch overall dataset (via module manager) - app$set_inputs(selector = "demo no labels") - - expected <- c( - "adsl [No label]" = "adsl", - "adae [No label]" = "adae", - "small [No label]" = "small" - ) - - actual <- app$get_value(export = "multi-dataset_choices") - - # Verify that dataset choices were updated due to dataset switch - testthat::expect_equal(actual, expected = expected) -}) # integration +test_that("mock_table_mm() displays the column names with the corresponding labels" %>% + vdoc[["add_spec"]](specs$column_label), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_col_labels_TAB-SO-760" + ) + + expected <- c( + "STUDYID [No label]", "DOMAIN [Domain Abbreviation]", + "USUBJID [Unique Subject Identifier]", "SUBJID [Subject Identifier for the Study]", + "RFSTDTC [Subject Reference Start Date/Time]", "RFENDTC [Subject Reference End Date/Time]", + "RFXSTDTC [Date/Time of First Study Treatment]", "RFXENDTC [Date/Time of Last Study Treatment]" + ) + + actual <- app$get_value(export = "multi-column_names") + + # Verify that dataset choices are displayed properly with their labels + testthat::expect_equal(actual, expected) + }) + +test_that("mock_table_mm() updates dropdown choices on dataset change in dv.manager" %>% + vdoc[["add_spec"]](specs$listings_label), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_update_labels" + ) + + expected <- c( + "adsl [Subject Level]" = "adsl", + "adae [Adverse Events]" = "adae", + "small [Few columns]" = "small" + ) + + actual <- app$get_value(export = "multi-dataset_choices") + + # Verify that dataset choices are displayed properly with their labels + testthat::expect_equal(actual, expected = expected) + + # Switch overall dataset (via module manager) + app$set_inputs(selector = "demo no labels") + + expected <- c( + "adsl [No label]" = "adsl", + "adae [No label]" = "adae", + "small [No label]" = "small" + ) + + actual <- app$get_value(export = "multi-dataset_choices") + + # Verify that dataset choices were updated due to dataset switch + testthat::expect_equal(actual, expected = expected) + }) # integration test_that("mock_table_mm() displays no table when global filter returns an empty data.frame", { # Initialize test app @@ -467,7 +485,7 @@ test_that("mock_table_mm() displays no table when global filter returns an empty app_dir = app_dir, name = "test_empty_df", timeout = 6000, load_timeout = 30000 ) - + # Choose global filter settings that lead to an empty data.frame # NOTE: It is not possible to put those two set_input() lines into only one call since we need to wait until the # first input is available! (Second call wouldn't be able to find it otherwise.) @@ -475,12 +493,12 @@ test_that("mock_table_mm() displays no table when global filter returns an empty app$wait_for_idle() app$set_inputs(`global_filter-RACE` = character(0)) app$wait_for_idle(duration = 3000) - + # Verify that a table with zero rows is shown - + dataset <- app$get_value(export = "multi-output_table") actual <- nrow(dataset) - + testthat::expect_equal(actual, expected = 0) }) # integration @@ -489,17 +507,17 @@ test_that("mock_table_mm() displays selected columns after activating global fil app <- shinytest2::AppDriver$new( app_dir = app_dir, name = "test_global_filter_selected_cols" ) - + # Set selected columns selected_cols <- c("STUDYID", "USUBJID") app$set_inputs(`multi-col_sel` = selected_cols) - + # Activate global filter app$set_inputs(`global_filter-vars` = "RACE") app$wait_for_idle() - + actual <- app$get_value(input = "multi-col_sel") - + testthat::expect_equal(actual, expected = selected_cols) }) # integration @@ -508,20 +526,20 @@ test_that("mock_table_mm() displays selected dataset after activating global fil app <- shinytest2::AppDriver$new( app_dir = app_dir, name = "test_global_filter_selected_dataset" ) - + selected <- "adae" # Switch dataset app$set_inputs(`multi-dataset` = selected) app$wait_for_idle() - + # Activate global filter app$set_inputs(`global_filter-vars` = "RACE") app$wait_for_idle() - + actual <- app$get_value(input = "multi-dataset") - + # Kill test app app$stop() - + testthat::expect_equal(actual, expected = selected) }) # integration From 9b29bb3e3fa71d9cad9ba455006d0778bbe16479 Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 09:14:04 +0200 Subject: [PATCH 03/11] Update gitignore and add .lintr file --- .gitignore | 16 ++++++++++++---- .lintr | 6 ++++++ 2 files changed, 18 insertions(+), 4 deletions(-) create mode 100644 .lintr diff --git a/.gitignore b/.gitignore index cce918b..a9b078a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,14 @@ -.Rproj.user/ -README.html +.Rproj.user .Rhistory -.lintr +.RData +.Ruserdata +.directory +.Renviron +.Rprofile docs/ - +README.html +vignettes/*\.html +vignettes/*\.R +inst/validation/results/val_param.rds +inst/validation/results/val_report.html +tests/testthat/app/shiny_bookmarks \ No newline at end of file diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..d2d542e --- /dev/null +++ b/.lintr @@ -0,0 +1,6 @@ +linters: linters_with_defaults( + line_length_linter(120), + object_usage_linter = NULL, + indentation_linter = NULL, + trailing_whitespace_linter = NULL + ) From 4888589f931a137e7e2d446ee0f60b2a52e10010 Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 09:47:14 +0200 Subject: [PATCH 04/11] Add qc vignette and update pkgdown.yml --- _pkgdown.yml | 8 ++++++++ vignettes/qc.Rmd | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+) create mode 100644 vignettes/qc.Rmd diff --git a/_pkgdown.yml b/_pkgdown.yml index afc77ed..69fb080 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -3,6 +3,10 @@ template: navbar: type: inverse + components: + qc: + text: Quality Control + href: articles/qc.html home: title: dv.listings @@ -20,3 +24,7 @@ reference: - listings_UI - listings_server - mod_simple_listing +- title: Quality Control + desc: Quality Control + contents: + - qc diff --git a/vignettes/qc.Rmd b/vignettes/qc.Rmd new file mode 100644 index 0000000..87bb735 --- /dev/null +++ b/vignettes/qc.Rmd @@ -0,0 +1,32 @@ +--- +title: "Quality Control" +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Quality Control} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + echo = FALSE +) +``` + +```{r, params, echo = FALSE, include = FALSE} +val_param_rds <- "../inst/validation/results/val_param.rds" +val_param_rds_exists <- file.exists(val_param_rds) +if (file.exists(val_param_rds)) params <- readRDS(val_param_rds) +``` + +```{r, results = "asis", echo = FALSE} +if (val_param_rds_exists) { + res <- knitr::knit_child("../inst/validation/val_report_child.Rmd", quiet = TRUE, envir = environment()) + cat(res, sep = "\n") +} else { + "No quality control results found" +} +``` From a5a5d133ad5ef0df7fd40be2ec4f9cd22ab0fa9d Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 11:24:03 +0200 Subject: [PATCH 05/11] Fix styler issues --- tests/testthat/_snaps/mod_simple_table.md | 2 +- tests/testthat/test-export_helpers.R | 286 ++++++------ tests/testthat/test-helpers.R | 121 ++--- tests/testthat/test-mod_export_listings.R | 152 +++--- tests/testthat/test-mod_listing.R | 540 +++++++++++----------- 5 files changed, 552 insertions(+), 549 deletions(-) diff --git a/tests/testthat/_snaps/mod_simple_table.md b/tests/testthat/_snaps/mod_simple_table.md index bd497f5..37f92b4 100644 --- a/tests/testthat/_snaps/mod_simple_table.md +++ b/tests/testthat/_snaps/mod_simple_table.md @@ -3,5 +3,5 @@ Code app$get_html(".datatables") Output - [1] "
\n \n \n \n
carmpg
1Mazda RX421
2Mazda RX4 Wag21
3Datsun 71022.8
4Hornet 4 Drive21.4
Showing 1 to 4 of 4 entries
" + [1] "
\n \n \n \n
carmpg
1Mazda RX421
2Mazda RX4 Wag21
3Datsun 71022.8
4Hornet 4 Drive21.4
Showing 1 to 4 of 4 entries
" diff --git a/tests/testthat/test-export_helpers.R b/tests/testthat/test-export_helpers.R index 779d5a1..42dbd39 100644 --- a/tests/testthat/test-export_helpers.R +++ b/tests/testthat/test-export_helpers.R @@ -11,7 +11,7 @@ test_that("export_modal_content() throws an error when argument types mismatch", cond_invalid <- list(NULL, 42, c("wrong", "type")) colnames_valid <- c("valid", "column", "names") colnames_invalid <- list(42) - + # perform tests purrr::walk(ns_invalid, ~ expect_error(export_modal_content(.x, file_name_valid, cond_valid, colnames_valid))) purrr::walk(file_name_invalid, ~ expect_error(export_modal_content(ns_valid, .x, cond_valid, colnames_valid))) @@ -22,7 +22,7 @@ test_that("export_modal_content() throws an error when argument types mismatch", test_that("export_modal_content() returns a shiny tagList with five element", { result <- export_modal_content(function(id) {}, "name", "true", c("valid", "column", "names")) - + checkmate::expect_list(result, len = 5) checkmate::expect_class(result, "shiny.tag.list") }) @@ -31,7 +31,7 @@ test_that("export_modal_content() shows/hides additional panels depending on con # show additional panels result <- export_modal_content(function(id) {}, "name", "true", c("column", "names")) expect_equal(result[[4]]$attribs$`data-display-if`, "true") - + # hide additional panels result <- export_modal_content(function(id) {}, "name", "false", c("column", "names")) expect_equal(result[[4]]$attribs$`data-display-if`, "false") @@ -48,7 +48,7 @@ test_that("shorten_entries() throws an error when argument types mismatch", { as.integer(2), # too_small as.integer(c(1, 2)) # too_long ) - + # perform tests purrr::walk(vec_invalid, ~ expect_error(shorten_entries(.x, len_max_valid))) purrr::walk(len_max_invalid, ~ expect_error(shorten_entries(vec_valid, .x))) @@ -59,7 +59,7 @@ test_that("shorten_entries() returns the original vector if strings are already # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(42) - + # perform test expect_identical(shorten_entries(vec, len_max), vec) }) @@ -68,7 +68,7 @@ test_that("shorten_entries() cuts strings to not exceed a specific length", { # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(5) - + # perform test expect_identical(nchar(shorten_entries(vec, len_max)), rep(len_max, length(vec))) }) @@ -77,7 +77,7 @@ test_that("shorten_entries() returns the correct string after cutting", { # arguments vec <- c("first_entry", "second_entry", "third_entry") len_max <- as.integer(5) - + # perform test expect_identical(shorten_entries(vec, len_max), c("fi...", "se...", "th...")) }) @@ -93,7 +93,7 @@ test_that("split_label() throws an error when argument types mismatch", { max_width_invalid <- list(as.integer(3), 10.5, c(as.integer(10), as.integer(12)), "Wrong type") label_width_valid <- as.integer(6) label_width_invalid <- list(as.integer(0), 5.8, c(as.integer(4), as.integer(7)), "Wrong type") - + # perform tests purrr::walk(label_invalid, ~ expect_error(split_label(.x, min_width_valid, max_width_valid, label_width_valid))) purrr::walk(min_width_invalid, ~ expect_error(split_label(label_valid, .x, max_width_valid, label_width_valid))) @@ -108,10 +108,10 @@ test_that("split_label() splits a simple label correctly", { min_width <- as.integer(5) max_width <- as.integer(10) label_width <- as.integer(5) - + # expected label_vec <- c("This", "is a", "simple", "label.") - + # perform test expect_identical( split_label(label, min_width, max_width, label_width), @@ -125,10 +125,10 @@ test_that("split_label() deals with labels that do not fit in the foreseen lines min_width <- as.integer(1) max_width <- as.integer(6) label_width <- as.integer(6) - + # expected label_vec <- c("This", "is a", "loo...", "label", "which", "doe...") - + # perform test expect_identical( split_label(label, min_width, max_width, label_width), @@ -142,10 +142,10 @@ test_that("split_label() directly returns the unchanged label and min_width in c min_width <- as.integer(50) max_width <- as.integer(100) label_width <- as.integer(6) - + # expected result <- list(label_vec = label, col_width = min_width) - + # perform test expect_identical(split_label(label, min_width, max_width, label_width), result) }) @@ -154,25 +154,25 @@ test_that("split_label() directly returns the unchanged label and min_width in c test_that("calculate_col_width() throws an error when argument types mismatch", { # arguments df_valid <- dm_dummy - + df_unnamed <- data.frame(test = cbind(1:10, 11:20)) colnames(df_unnamed) <- NULL df_duplicated_names <- data.frame(test = cbind(1:10, 11:20)) colnames(df_duplicated_names) <- c("name1", "name1") - + df_invalid <- list( "Not a data frame.", # type_mismatch df_unnamed, # unnamed df_duplicated_names, # duplicated names data.frame() # no_dimensions ) - + ref_valid <- paste0(names(df_valid)[1], " [", get_labels(df_valid[1]), "]") ref_invalid <- list( cbind(1:5, 6:10), # type_mismatch c("wrong", "entries") # wrong_entries ) - + # perform tests purrr::walk(df_invalid, ~ expect_error(calculate_col_width(.x, ref_valid))) purrr::walk(ref_invalid, ~ expect_error(calculate_col_width(df_valid, .x))) @@ -190,14 +190,14 @@ test_that("calculate_col_width() returns the correct results", { attributes(df[["name_13_chars"]])$label <- "label 1" attributes(df[["name2"]])$label <- "label 10 characters" attributes(df[["name3"]])$label <- "label 3" - + # ref argument ref_ind <- c(1, 2) ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") - + # result col_width_res <- calculate_col_width(df, ref) - + # expected table_width <- PDF_EXP$N_COL_CHARS - nchar(nrow(df)) label_vecs <- purrr::map2(get_labels(df), c(13, 5, 14), ~ { @@ -217,7 +217,7 @@ test_that("calculate_col_width() returns the correct results", { table_width = table_width, check_ref_cols = FALSE ) - + # perform test expect_identical(col_width_res, col_width_exp) }) @@ -230,7 +230,7 @@ test_that("calculate_col_width() detects that all columns are specified as refer )) colnames(df) <- c("name1", "name2") ref <- paste0(colnames(df), " [", get_labels(df), "]") - + # perform test expect_identical(calculate_col_width(df, ref)$check_ref_cols, TRUE) }) @@ -239,7 +239,7 @@ test_that("calculate_col_width() detects that reference columns take up too much # arguments df <- dm_dummy ref <- paste0(colnames(df)[1:15], " [", get_labels(df)[1:15], "]") - + # perform test expect_identical(calculate_col_width(df, ref)$check_ref_cols, TRUE) }) @@ -261,13 +261,13 @@ test_that("pdf_preprocessing() throws an error when argument types mismatch", { duplicated_names, # duplicated names data.frame() # no dimensions ) - + ref_valid <- paste0(names(df_valid)[1], " [", get_labels(df_valid[1]), "]") ref_invalid <- list( cbind(1:5, 6:10), # type_mismatch c("wrong", "entries") # wrong_entries ) - + # perform tests purrr::walk(df_invalid, ~ expect_error(pdf_preprocessing(.x, ref_valid))) purrr::walk(ref_invalid, ~ expect_error(pdf_preprocessing(df_valid, .x))) @@ -287,10 +287,10 @@ test_that("pdf_preprocessing() returns original df (without splitting) inclusive row.names(df_res) <- c("", rownames) attributes(df[["name1"]])$label <- labels[1] attributes(df[["name2"]])$label <- labels[2] - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) - + # expected pdf_preprocessing_exp <- list(data.frame(rbind( c("label", "label"), @@ -301,7 +301,7 @@ test_that("pdf_preprocessing() returns original df (without splitting) inclusive ))) colnames(pdf_preprocessing_exp[[1]]) <- c("name1", "name2") rownames(pdf_preprocessing_exp[[1]]) <- c(empty_rownames, 1, 2) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -310,16 +310,16 @@ test_that("pdf_preprocessing() deals with data frames containing only one column # df argument df <- data.frame(simple_dummy[1:5, 1]) colnames(df) <- c("name1") - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) - + # expected pdf_preprocessing_exp <- data.frame(c("No", "label", "", "", "", "", simple_dummy[1:5, 1])) colnames(pdf_preprocessing_exp) <- colnames(df) rownames(pdf_preprocessing_exp) <- c(empty_rownames, 1:5) pdf_preprocessing_exp <- list(pdf_preprocessing_exp) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -328,10 +328,10 @@ test_that("pdf_preprocessing() deals with data frames containing only one row", # df argument df <- data.frame(simple_dummy[1, 1:3]) colnames(df) <- c("name1", "name2", "name3") - + # result pdf_preprocessing_res <- pdf_preprocessing(df, "name2 [No label]") - + # expected pdf_preprocessing_exp <- data.frame(rbind( c("No", "No", "No"), @@ -343,43 +343,43 @@ test_that("pdf_preprocessing() deals with data frames containing only one row", rownames(pdf_preprocessing_exp) <- c(empty_rownames, seq_len(nrow(df))) pdf_preprocessing_exp <- pdf_preprocessing_exp[, c(2, 1, 3)] pdf_preprocessing_exp <- list(pdf_preprocessing_exp) - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) test_that("pdf_preprocessing() changes column order due to reference column specification" %>% - vdoc[["add_spec"]](specs$export_pdf), { - # df argument - len <- 4 - df <- simple_dummy[1:2, 1:len] - - # ref argument - ref_ind <- c(4, 2) - ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") - - # result - pdf_preprocessing_res <- pdf_preprocessing(df, ref) - - # expected - df_res <- data.frame(rbind( - rep("No", len), - rep("label", len), - matrix("", nrow = PDF_EXP$LABEL_WIDTH - 2, ncol = len), - as.matrix(df) - )) - rownames(df_res) <- c(empty_rownames, 1, 2) - pdf_preprocessing_exp <- list(cbind(df_res[, ref_ind], df_res[, !(1:len %in% ref_ind)])) - - - # perform test - expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) - }) + vdoc[["add_spec"]](specs$export_pdf), { + # df argument + len <- 4 + df <- simple_dummy[1:2, 1:len] + + # ref argument + ref_ind <- c(4, 2) + ref <- paste0(names(df)[ref_ind], " [", get_labels(df)[ref_ind], "]") + + # result + pdf_preprocessing_res <- pdf_preprocessing(df, ref) + + # expected + df_res <- data.frame(rbind( + rep("No", len), + rep("label", len), + matrix("", nrow = PDF_EXP$LABEL_WIDTH - 2, ncol = len), + as.matrix(df) + )) + rownames(df_res) <- c(empty_rownames, 1, 2) + pdf_preprocessing_exp <- list(cbind(df_res[, ref_ind], df_res[, !(1:len %in% ref_ind)])) + + + # perform test + expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) +}) test_that("pdf_preprocessing() splits df into disjoint sub dataframes that form together the original df when ignoring labels", { # nolint # df argument df <- dm_dummy[1:35, 1:10] - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL) pdf_preprocessing_res <- purrr::map(pdf_preprocessing_res, ~ { @@ -389,7 +389,7 @@ test_that("pdf_preprocessing() splits df into disjoint sub dataframes that form cbind(pdf_preprocessing_res[[1]], pdf_preprocessing_res[[2]]), cbind(pdf_preprocessing_res[[3]], pdf_preprocessing_res[[4]]) ) - + # perform test expect_identical(apply(pdf_preprocessing_res, 2, as.character), apply(df, 2, as.character)) }) @@ -405,13 +405,13 @@ test_that("pdf_preprocessing() shortens entries that do not fit on one page", { attributes(df[["name2"]])$label <- "label 2" long_entry <- paste0(c("this is a", rep("very", 25), "long entry"), collapse = " ") df[2, 1] <- long_entry - + # result pdf_preprocessing_res <- pdf_preprocessing(df, NULL)[[1]][8, 1] - + # expected pdf_preprocessing_exp <- paste0(substr(long_entry, 1, (PDF_EXP$N_COL_CHARS - nchar(nrow(df)) - 3)), "...") - + # perform test expect_identical(pdf_preprocessing_res, pdf_preprocessing_exp) }) @@ -436,7 +436,7 @@ test_that("prep_export_data() throws an error when argument types mismatch", { data_selection_name_invalid <- list(42, c("wrong", "type")) dataset_list_valid <- list("dummy_data" = simple_dummy) dataset_list_invalid <- list(c("wrong", "type"), list(1, 2, "no dataframe")) - + # perform tests purrr::walk(data_selection_invalid, ~ expect_error(prep_export_data( .x, @@ -477,46 +477,46 @@ test_that("prep_export_data() performs the correct transformation in the single attributes(dataset_list_valid$data1)$label <- "My Label" current_data_valid <- dataset_list_valid[[1]] data_selection_name_valid <- names(dataset_list_valid)[1] - + # result res <- prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid) - + # expected exp <- list("data1 (My Label)" = set_labels(data.frame(col1 = c("1", "2"), col2 = c("3", "4")))) - + # perform tests expect_identical(res, exp) }) test_that("prep_export_data() performs the correct transformation in the multiple dataset case" %>% - vdoc[["add_spec"]](specs$export_excel), { - # arguments - data_selection_valid <- "all" - dataset_list_valid <- list( - "dummy1" = simple_dummy, - "dummy2" = simple_dummy[1:5], - "dummy3" = simple_dummy[5:10] - ) - attributes(dataset_list_valid$dummy1)$label <- "My Label 1" - attributes(dataset_list_valid$dummy2)$label <- "My Label 2" - attributes(dataset_list_valid$dummy3)$label <- "My Label 3" - current_data_valid <- dataset_list_valid[[1]] - data_selection_name_valid <- names(dataset_list_valid)[1] - - # result - res <- prep_export_data( - data_selection_valid, - current_data_valid, - data_selection_name_valid, - dataset_list_valid - ) - - # perform tests - expect_identical(names(res), c("dummy1 (My Label 1)", "dummy2 (My Label 2)", "dummy3 (My Label 3)")) - expect_identical(res[[1]], set_labels(data.frame(sapply(dataset_list_valid[[1]], as.character)))) - expect_identical(res[[2]], set_labels(data.frame(sapply(dataset_list_valid[[2]], as.character)))) - expect_identical(res[[3]], set_labels(data.frame(sapply(dataset_list_valid[[3]], as.character)))) - }) + vdoc[["add_spec"]](specs$export_excel), { + # arguments + data_selection_valid <- "all" + dataset_list_valid <- list( + "dummy1" = simple_dummy, + "dummy2" = simple_dummy[1:5], + "dummy3" = simple_dummy[5:10] + ) + attributes(dataset_list_valid$dummy1)$label <- "My Label 1" + attributes(dataset_list_valid$dummy2)$label <- "My Label 2" + attributes(dataset_list_valid$dummy3)$label <- "My Label 3" + current_data_valid <- dataset_list_valid[[1]] + data_selection_name_valid <- names(dataset_list_valid)[1] + + # result + res <- prep_export_data( + data_selection_valid, + current_data_valid, + data_selection_name_valid, + dataset_list_valid + ) + + # perform tests + expect_identical(names(res), c("dummy1 (My Label 1)", "dummy2 (My Label 2)", "dummy3 (My Label 3)")) + expect_identical(res[[1]], set_labels(data.frame(sapply(dataset_list_valid[[1]], as.character)))) + expect_identical(res[[2]], set_labels(data.frame(sapply(dataset_list_valid[[2]], as.character)))) + expect_identical(res[[3]], set_labels(data.frame(sapply(dataset_list_valid[[3]], as.character)))) +}) test_that("prep_export_data() shortens dataset names if they exceed Excel's sheet name limit of 31 characters", { # arguments @@ -527,12 +527,12 @@ test_that("prep_export_data() shortens dataset names if they exceed Excel's shee attributes(dataset_list_valid$dummy3)$label <- "Short label" current_data_valid <- dataset_list_valid[[1]] data_selection_name_valid <- names(dataset_list_valid)[1] - + # result res <- nchar( names(prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid)) ) - + # perform tests expect_identical(res, as.integer(c(31, 31, 20))) }) @@ -544,51 +544,51 @@ test_that("excel_export() throws an error when argument types mismatch", { data_to_download_invalid <- list(c("wrong", "type"), list(1, 2, "no dataframe"), NULL) file_valid <- "./testfile.xlsx" file_invalid <- list(42, "./testfile.pdf") - + # perform tests purrr::walk(data_to_download_invalid, ~ expect_error(excel_export(.x, file_valid))) purrr::walk(file_invalid, ~ expect_error(excel_export(data_to_download_valid, .x))) }) test_that("excel_export() exports the .xlsx file as intended" %>% - vdoc[["add_spec"]](specs$export_excel), { - # arguments - data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) - file <- paste0(getwd(), "/testfile.xlsx") - - # result - excel_export(data_to_download, file, intended_use_label = "") - res_sheet2 <- openxlsx::read.xlsx(file, "dummy2", sep.names = " ") - - # expected - exp_sheet2 <- data_to_download$dummy2 - rownames(exp_sheet2) <- seq_len(nrow(exp_sheet2)) - colnames(exp_sheet2) <- paste0(colnames(exp_sheet2), " [", get_labels(exp_sheet2), "]") - - # perform tests - expect_equal(res_sheet2, exp_sheet2) - - # remove file - file.remove(file) - }) + vdoc[["add_spec"]](specs$export_excel), { + # arguments + data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) + file <- paste0(getwd(), "/testfile.xlsx") + + # result + excel_export(data_to_download, file, intended_use_label = "") + res_sheet2 <- openxlsx::read.xlsx(file, "dummy2", sep.names = " ") + + # expected + exp_sheet2 <- data_to_download$dummy2 + rownames(exp_sheet2) <- seq_len(nrow(exp_sheet2)) + colnames(exp_sheet2) <- paste0(colnames(exp_sheet2), " [", get_labels(exp_sheet2), "]") + + # perform tests + expect_equal(res_sheet2, exp_sheet2) + + # remove file + file.remove(file) +}) test_that("excel_export() generates the .xlsx file with a leading worksheet containing the disclaimer", { # arguments data_to_download <- list("dummy1" = simple_dummy, "dummy2" = simple_dummy[2:7]) file <- paste0(getwd(), "/testfile.xlsx") - + # result excel_export(data_to_download, file, intended_use_label = "test label") res_info_sheet <- openxlsx::read.xlsx(file, 1, sep.names = " ", colNames = FALSE) # 1 = leading # nolint colnames(res_info_sheet) <- NULL - + # expected exp_info_sheet <- data.frame(c(EXP$EXP_TITLE, "test label")) colnames(exp_info_sheet) <- NULL - + # perform tests expect_equal(res_info_sheet, exp_info_sheet) - + # remove file file.remove(file) }) @@ -610,7 +610,7 @@ test_that("pdf_export() throws an error when argument types mismatch", { file_invalid <- list(42, "./testfile.xlsx") metadata_valid <- c("text 1", "text 2", "text 3") metadata_invalid <- list(42, c("too", "many", "header/footer", "components")) - + # perform tests purrr::walk(data_to_download_invalid, ~ expect_error(pdf_export( .x, ref_valid, file_valid, metadata_valid, FALSE @@ -627,22 +627,22 @@ test_that("pdf_export() throws an error when argument types mismatch", { }) test_that("pdf_export() exports the .pdf file as intended" %>% - vdoc[["add_spec"]](specs$export_pdf), { - # arguments - data_to_download <- list("dummy_data" = simple_dummy) - ref <- c("var2 [No label]") - file <- paste0(getwd(), "/testfile.pdf") - metadata <- c("text 1", "text 2", "text 3") - - # result - pdf_export(data_to_download, ref, file, metadata, FALSE, "") - - # perform tests - expect_true(file.exists(file)) - - # remove file - file.remove(file) - }) + vdoc[["add_spec"]](specs$export_pdf), { + # arguments + data_to_download <- list("dummy_data" = simple_dummy) + ref <- c("var2 [No label]") + file <- paste0(getwd(), "/testfile.pdf") + metadata <- c("text 1", "text 2", "text 3") + + # result + pdf_export(data_to_download, ref, file, metadata, FALSE, "") + + # perform tests + expect_true(file.exists(file)) + + # remove file + file.remove(file) +}) test_that("pdf_export() generates the .pdf file with a title page containing the disclaimer", { skip("Setting titles and subtitles is Rmarkdown functionality and therefore not tested additionally.") @@ -658,7 +658,7 @@ test_that("warn_function() throws an error when argument types mismatch", { input_id_invalid <- list(NULL, 42) text_valid <- "warning" text_invalid <- list(c("wrong", "type")) - + # perform tests purrr::walk(cond_invalid, ~ expect_error(warn_function(.x, input_id_valid, text_valid))) purrr::walk(input_id_invalid, ~ expect_error(warn_function(cond_valid, .x, text_valid))) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 05267ba..c936e85 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -4,14 +4,14 @@ source("dummy-data.R") test_that("fill_default_vars() throws an error when dataset argument type mismatches", { # Correct default_vars argument default_vars <- NULL - + # Wrong dataset arguments type_mismatch <- "Not a list." # wrong argument type element_mismatch <- list(a = letters[1:6], b = 1:10) # wrong list element types unnamed <- list(simple_dummy, data.frame(test = 1:10)) # missing names duplicated_names <- list(data1 = simple_dummy, data1 = data.frame(test = 1:10)) # duplicated names inexistent <- NULL # no data - + # Perform tests purrr::walk( list(type_mismatch, element_mismatch, unnamed, duplicated_names, inexistent), @@ -21,9 +21,9 @@ test_that("fill_default_vars() throws an error when dataset argument type mismat test_that("fill_default_vars() throws an error when default_vars argument type mismatches", { dummy_names <- names(simple_dummy) - + # Wrong default_vars argument - + type_mismatch <- "Not a list." # wrong argument type element_mismatch <- list(dummy1 = 1:6, dummy2 = 1:10) # wrong list element types unnamed <- list(dummy_names[1:4], dummy_names[1:8]) # missing names @@ -33,10 +33,10 @@ test_that("fill_default_vars() throws an error when default_vars argument type m dummy1 = c(dummy_names[1:4], dummy_names[1:2]), dummy2 = dummy_names[1:8] ) wrong_values <- list(dummy1 = c(dummy_names[1:4], "wrong"), dummy2 = dummy_names[1:8]) # wrong vector entries - + # Correct dataset argument dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) - + # Perform tests purrr::walk(list( type_mismatch, element_mismatch, unnamed, duplicated_names, wrong_names, duplicated_values, wrong_values @@ -47,11 +47,11 @@ test_that("fill_default_vars() returns default_vars without transformation", { # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) default_vars <- list(dummy1 = names(simple_dummy)[1:4], dummy2 = names(simple_dummy)[1:8]) - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- default_vars - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -60,11 +60,11 @@ test_that("fill_default_vars() fills all entries of default_vars witth 6 column # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy) default_vars <- NULL - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list(dummy1 = names(simple_dummy)[1:6], dummy2 = names(simple_dummy)[1:6]) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -73,13 +73,13 @@ test_that("fill_default_vars() fills single missing entry of default_vars with 6 # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy, dummy3 = simple_dummy) default_vars <- list(dummy1 = names(simple_dummy)[1:4], dummy3 = names(simple_dummy)[1:8]) - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list( dummy1 = names(simple_dummy)[1:4], dummy2 = names(simple_dummy)[1:6], dummy3 = names(simple_dummy)[1:8] ) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -88,13 +88,13 @@ test_that("fill_default_vars() fills default_vars only with available columns in # Prepare dataset and default_vars dataset <- list(dummy1 = simple_dummy, dummy2 = simple_dummy[, 1:4], dummy3 = simple_dummy[, 1:2]) default_vars <- NULL - + # Run function default_vars_res <- fill_default_vars(default_vars, dataset) default_vars_exp <- list( dummy1 = names(simple_dummy)[1:6], dummy2 = names(simple_dummy)[1:4], dummy3 = names(simple_dummy)[1:2] ) - + # Perform test expect_identical(default_vars_res, default_vars_exp) # check values (as well as types, names and lengths) }) @@ -106,7 +106,7 @@ test_that("get_labels() throws an error when argument type mismatches", { type_mismatch <- "Not a data.frame or list" # wrong argument type element_mismatch <- list(a = letters[1:6], b = 1:10) # wrong list element types unnamed <- list(simple_dummy, data.frame(test = 1:10)) # missing names - + # Perform tests purrr::walk(list(type_mismatch, element_mismatch, unnamed), ~ expect_error(get_labels(.x))) }) @@ -116,7 +116,7 @@ test_that("get_labels() returns column labels of a data.frame in a character vec df <- simple_dummy[, 1:3] labels <- c("Label 1", "Label 2", "Label 3") purrr::walk2(names(df), labels, function(x, y) attributes(df[[x]])$label <<- y) - + # Perform test col_labs <- get_labels(df) expect_equal(col_labs, labels, ignore_attr = TRUE) # check only values @@ -130,7 +130,7 @@ test_that("get_labels() returns labels for each element of a list of data.frames df_list <- list(dummy1 = simple_dummy[, 1:3], dummy2 = simple_dummy) labels <- c("First label", "Second label") purrr::walk2(names(df_list), labels, function(x, y) attributes(df_list[[x]])$label <<- y) - + # Perform test df_labs <- get_labels(df_list) expect_equal(df_labs, labels, ignore_attr = TRUE) # check only values @@ -144,7 +144,7 @@ test_that("get_labels() returns NULL when the argument is empty or NULL", { empty_df <- data.frame() empty_list <- list() null_arg <- NULL - + # Perform tests purrr::walk(list(empty_df, empty_list, null_arg), ~ expect_null(get_labels(.x))) }) @@ -153,7 +153,7 @@ test_that("get_labels() substitutes missing labels with a 'No label' entry in th # We can directly use simple_dummy as it has no column labels missing_labs <- get_labels(simple_dummy) expected_labs <- rep("No label", times = ncol(simple_dummy)) - + # Perform test expect_equal(missing_labs, expected_labs, ignore_attr = TRUE) }) @@ -177,26 +177,27 @@ attributes(df1$mpg)$label <- "Col label 1" attributes(df1$type)$label <- "Col label 2" test_that("generate_choices() generates meaningful choices for datasets and columns to be used in the corresponding dropdown menues" %>% # nolint - vdoc[["add_spec"]]( - c(specs$listings_label, - specs$column_label - ) - ), { - df_list <- list(first = df1, second = df2) - - expected_df <- c("first [Test data 1]" = "first", "second [No label]" = "second") - actual_df <- generate_choices(df_list) - expect_equal(expected_df, actual_df) - - expected_col <- c( - "mpg [Col label 1]" = "mpg", - "cyl [No label]" = "cyl", - "disp [No label]" = "disp", - "type [Col label 2]" = "type" - ) - actual_col <- generate_choices(df1) - expect_equal(expected_col, actual_col) - }) + vdoc[["add_spec"]]( + c( + specs$listings_label, + specs$column_label + ) + ), { + df_list <- list(first = df1, second = df2) + + expected_df <- c("first [Test data 1]" = "first", "second [No label]" = "second") + actual_df <- generate_choices(df_list) + expect_equal(expected_df, actual_df) + + expected_col <- c( + "mpg [Col label 1]" = "mpg", + "cyl [No label]" = "cyl", + "disp [No label]" = "disp", + "type [Col label 2]" = "type" + ) + actual_col <- generate_choices(df1) + expect_equal(expected_col, actual_col) +}) test_that("set_data() throws an error when at leat one argument type mismatches", { @@ -209,11 +210,11 @@ test_that("set_data() throws an error when at leat one argument type mismatches" dimnames = list(c("row1", "row2"), c("C.1", "C.2", "C.3")) ) df <- simple_dummy - + ## ... for selector parameter not_char <- c(1, 2) char <- c("C.1", "C.2") - + # Perform tests expect_error(set_data(not_df, char)) expect_error(set_data(df, not_char)) @@ -231,7 +232,7 @@ test_that("set_data() returns a named list containing a data.frame, a character rows <- as.character(seq_len(nrow(df))) outcome <- set_data(df, selection) expected_names <- c("data", "col_names", "row_names") - + # Perform tests expect_type(outcome, "list") expect_length(outcome, 3) @@ -246,7 +247,7 @@ test_that("set_data() returns a character of length zero as row_names if data ha df <- simple_dummy[0, ] selection <- names(df)[1:3] outcome <- set_data(df, selection) - + # Perform tests testthat::expect_true(length(outcome[["row_names"]]) == 0) }) @@ -256,7 +257,7 @@ test_that("set_data() reduces the columns of base_data to those specified in sel df <- simple_dummy selection <- names(df)[3:5] outcome <- set_data(df, selection) - + # Perform tests checkmate::expect_data_frame(outcome[["data"]], ncols = length(selection)) expect_named(outcome[["data"]], selection) @@ -267,7 +268,7 @@ test_that("set_data() orders the columns of the returned data.frame according to df <- simple_dummy selection <- names(df)[5:3] outcome <- set_data(df, selection) - + # Perform test expect_named(outcome[["data"]], selection) }) @@ -279,7 +280,7 @@ test_that("set_data() creates descriptive column names consisting of the column purrr::walk2(names(df), labels, function(x, y) attributes(df[[x]])$label <<- y) expected <- c("var1 [First label]", "var2 [Second label]") outcome <- set_data(df, selector = names(df)[1:2]) - + # Perform test expect_equal(outcome[["col_names"]], expected) }) @@ -289,7 +290,7 @@ test_that("set_data() creates descriptive column names consisting of the column test_that("set_data() throws an error when argument type mismatches", { # Initialize test case df <- as.list(simple_dummy) - + # Perform test expect_error(convert_data(df)) }) @@ -299,13 +300,13 @@ test_that("set_data() returns the data.frame with converted column data types an df <- data.frame(A = c("a", "b", "c"), B = c("1", "2", "3")) attributes(df$A)$label <- "Character column" attributes(df$B)$label <- "Numeric column" - + # Perform test conv_df <- convert_data(df) - + expect_equal(attributes(conv_df$A)$label, attributes(df$A)$label) expect_equal(attributes(conv_df$B)$label, attributes(df$B)$label) - + expect_equal(class(conv_df$A), "factor") expect_equal(class(conv_df$B), "integer") }) @@ -314,15 +315,15 @@ test_that("set_data() returns the data.frame with converted column data types an test_that("set_up_datatable() returns correct column names, row names, and paging", { df <- data.frame(A = c("a", "b", "c"), B = c("1", "2", "3"), C = c("a", "b", "c")) - + attributes(df$A)$label <- "Label A" attributes(df$C)$label <- "Label C" - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expected <- list( col_names = c("A [Label A]", "B [No label]", "C [Label C]"), row_names = c("1", "2", "3"), @@ -337,12 +338,12 @@ test_that("set_up_datatable() automatically activates pagination for large datas B = sample(c("1", "2", "3"), 1001, replace = TRUE), C = sample(c("a", "b", "c"), 1001, replace = TRUE) ) - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expect_true(actual$paging) }) @@ -352,11 +353,11 @@ test_that("set_up_datatable() automatically deactivates pagination for small dat B = sample(c("1", "2", "3"), 100, replace = TRUE), C = sample(c("a", "b", "c"), 100, replace = TRUE) ) - + selected_cols <- c("A", "B", "C") pagination <- NULL - + actual <- set_up_datatable(df, selected_cols, pagination) - + expect_false(actual$paging) }) diff --git a/tests/testthat/test-mod_export_listings.R b/tests/testthat/test-mod_export_listings.R index 00a64e7..11ba8c3 100644 --- a/tests/testthat/test-mod_export_listings.R +++ b/tests/testthat/test-mod_export_listings.R @@ -28,7 +28,7 @@ test_that("mod_export_listings_UI fails when argument type mismatches", { test_that("mod_export_listings_UI returns a shiny tagList with three elements", { ui <- mod_export_listings_UI("test") - + checkmate::expect_list(ui, len = 3) checkmate::expect_class(ui, "shiny.tag.list") }) @@ -40,7 +40,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { 3, # wrong type "" # less than one character ) - + dataset_metadata_valid <- list( name = shiny::reactive("test"), date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) @@ -51,7 +51,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { list(name = shiny::reactive("test"), name = shiny::reactive("test2")), # not unique list(test1 = shiny::reactive("test"), test2 = shiny::reactive(c("01-01-2000", "01-01-2000"))) # wrong names ) - + dataset_list_valid <- shiny::reactive({ list(dm = dm_dummy, ae = ae_dummy) }) @@ -67,28 +67,28 @@ test_that("mod_export_listings_server fails when argument type mismatches", { list(dm_dummy, ae_dummy) }) # unnamed ) - + data_valid <- shiny::reactive({ list(data = dm_dummy, col_names = colnames(ae_dummy)) }) data_invalid <- list( c("wrong", "type") # wrong type ) - + data_selection_name_valid <- shiny::reactive("dm") data_selection_name_invalid <- list( shiny::reactive({ 3 }) # wrong type ) - + current_rows_valid <- shiny::reactive(seq_len(dim(dm_dummy)[2])) current_rows_invalid <- list( shiny::reactive({ c("wrong", "type") }) # wrong type ) - + # execute invalid test cases purrr::walk(id_invalid, ~ expect_error( shiny::testServer( @@ -193,7 +193,7 @@ test_that("mod_export_listings_server fails when argument type mismatches", { ) ) )) - + # verify that valid arguments launch the server as intended expect_success( shiny::testServer( @@ -217,50 +217,50 @@ test_that("mod_export_listings_server fails when argument type mismatches", { }) test_that("mod_export_listings_server updates file type choices when switching between single and all datasets" %>% # nolint - vdoc[["add_spec"]](specs$export), { - # server arguments - id <- "test" - dataset_metadata <- list( - name = shiny::reactive("test"), - date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) - ) - dataset_list <- shiny::reactive({ - list(dm = dm_dummy, ae = ae_dummy) - }) - data <- shiny::reactive({ - list(data = dm_dummy, col_names = colnames(dm_dummy)) - }) - data_selection_name <- shiny::reactive("dm") - current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - - # perform tests - shiny::testServer( - app = server_func, - expr = { - # initial expectation - # note: id is hard coded because pack of constants cannot be used within session$setInputs() - session$setInputs(which_data = "single") - actual_choices <- type_choices() - expected_choices <- c("Excel" = ".xlsx", "PDF" = ".pdf") - expect_equal(actual_choices, expected_choices) - - # after selection switch - session$setInputs(which_data = "all") - actual_choices <- type_choices() - expected_choices <- c("Excel" = ".xlsx") - expect_equal(actual_choices, expected_choices) - }, - args = list( - id = id, - dataset_metadata = dataset_metadata, - dataset_list = dataset_list, - data = data, - data_selection_name = data_selection_name, - current_rows = current_rows, - intended_use_label = NULL - ) - ) - }) + vdoc[["add_spec"]](specs$export), { + # server arguments + id <- "test" + dataset_metadata <- list( + name = shiny::reactive("test"), + date_range = shiny::reactive(c("01-01-2000", "01-01-2000")) + ) + dataset_list <- shiny::reactive({ + list(dm = dm_dummy, ae = ae_dummy) + }) + data <- shiny::reactive({ + list(data = dm_dummy, col_names = colnames(dm_dummy)) + }) + data_selection_name <- shiny::reactive("dm") + current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) + + # perform tests + shiny::testServer( + app = server_func, + expr = { + # initial expectation + # note: id is hard coded because pack of constants cannot be used within session$setInputs() + session$setInputs(which_data = "single") + actual_choices <- type_choices() + expected_choices <- c("Excel" = ".xlsx", "PDF" = ".pdf") + expect_equal(actual_choices, expected_choices) + + # after selection switch + session$setInputs(which_data = "all") + actual_choices <- type_choices() + expected_choices <- c("Excel" = ".xlsx") + expect_equal(actual_choices, expected_choices) + }, + args = list( + id = id, + dataset_metadata = dataset_metadata, + dataset_list = dataset_list, + data = data, + data_selection_name = data_selection_name, + current_rows = current_rows, + intended_use_label = NULL + ) + ) +}) test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) ticked", { # server arguments @@ -277,7 +277,7 @@ test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) }) data_selection_name <- shiny::reactive("dm") current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - + # perform tests shiny::testServer( app = server_func, @@ -289,7 +289,7 @@ test_that("mod_export_listings_server hides (shows) warning if checkbox is (not) actual_label <- gsub("[\r\n] *", "", actual_label) # remove newline tags and multiple spacing expected_label <- paste(EXP$DATAPROTECT_LABEL, intended_use_label) expect_equal(actual_label, expected_label) - + # after further selection switch session$setInputs(check = FALSE) # name must be set manually to avoid errors actual_label <- checkbox_label() @@ -325,7 +325,7 @@ test_that("mod_export_listings_server en-/disables download button if prerequesi }) data_selection_name <- shiny::reactive("dm") current_rows <- shiny::reactive(seq_len(dim(dm_dummy)[2])) - + # perform tests shiny::testServer( app = server_func, @@ -333,11 +333,11 @@ test_that("mod_export_listings_server en-/disables download button if prerequesi # ticking the checkbox and inserting file name should enable download button session$setInputs(name = "name", check = TRUE) expect_equal(download_enable(), TRUE) - + # removing file name should disable download button session$setInputs(name = "") expect_equal(download_enable(), FALSE) - + # reentering file name should enable download button session$setInputs(name = "test") expect_equal(download_enable(), TRUE) @@ -365,22 +365,22 @@ test_that("mod_export_listings_server places exported files in the local downloa app_dir <- "./apps/mm_app" test_that("mock_listings_mm exports all pages when downloading the currently displayed table in case of pagination turned on" %>% # nolint - vdoc[["add_spec"]](specs$export_active_listing), { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_row_order" - ) - - # Click buttons - app$wait_for_idle() - app$click("multi-export-download_data") - app$wait_for_idle() - - # Check if length(current_rows()) > 10 (more than one page) - testthat::expect_identical( - length(app$get_value(export = "multi-export-current_rows")), - as.integer(100) - ) - - app$stop() - }) + vdoc[["add_spec"]](specs$export_active_listing), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_row_order" + ) + + # Click buttons + app$wait_for_idle() + app$click("multi-export-download_data") + app$wait_for_idle() + + # Check if length(current_rows()) > 10 (more than one page) + testthat::expect_identical( + length(app$get_value(export = "multi-export-current_rows")), + as.integer(100) + ) + + app$stop() +}) diff --git a/tests/testthat/test-mod_listing.R b/tests/testthat/test-mod_listing.R index 500cf42..09c19c8 100644 --- a/tests/testthat/test-mod_listing.R +++ b/tests/testthat/test-mod_listing.R @@ -17,7 +17,7 @@ test_that("listings_server() fails when argument type mismatches", { id_valid <- "test" id_num <- 3 id_zero <- "" - + data_valid <- shiny::reactive({ list(dm = dm_dummy, ae = ae_dummy) }) @@ -25,12 +25,12 @@ test_that("listings_server() fails when argument type mismatches", { data_no_list <- shiny::reactive(ae_dummy) data_null <- shiny::reactive(NULL) data_unnamed <- shiny::reactive(list(dm_dummy, ae_dummy)) - + cols_valid <- list(dm = "USUBJID", ae = c("AETERM", "AESEV")) cols_null <- NULL cols_no_list <- "USUBJID" cols_unnamed <- list("USUBJID", c("AETERM", "AESEV")) - + metadata_valid <- list( name = shiny::reactive("test"), date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) @@ -42,18 +42,18 @@ test_that("listings_server() fails when argument type mismatches", { test1 = shiny::reactive("test"), test2 = shiny::reactive(c("01-01-2000", "31-12-2000")) ) - + pagination_valid <- NULL pagination_num <- 1 pagination_char <- "wrong" - + # Cases that expect an error test_id <- list(id_num, id_zero) # list to preserve types test_dataset_list <- list(data_no_df, data_no_list, data_unnamed) test_cols <- list(cols_no_list, cols_unnamed) test_metadata <- list(metadata_wrong_type, metadata_unnamed, metadata_not_unique, metadata_wrong_names) test_pagination <- list(pagination_num, pagination_char) - + # Execute test cases purrr::walk(test_id, ~ expect_error( shiny::testServer(server_func, args = list( @@ -87,7 +87,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) - + purrr::walk(test_metadata, ~ expect_error( shiny::testServer(server_func, args = list( id = id_valid, dataset_list = data_valid, @@ -98,7 +98,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) # test dataset_metadata parameter - + purrr::walk(test_pagination, ~ expect_error( shiny::testServer(server_func, args = list( id = id_valid, dataset_list = data_valid, @@ -109,7 +109,7 @@ test_that("listings_server() fails when argument type mismatches", { expect_true(TRUE) # to silence error that is caused from missing expectations }) )) # test pagination parameter - + # Verify that valid arguments launch the server as intended expect_success( shiny::testServer( @@ -131,61 +131,61 @@ test_that("listings_server() fails when argument type mismatches", { }) test_that("listings_server() saves default_vars in the selected_columns_in_dataset at app launch" %>% - vdoc[["add_spec"]](specs$default_vars), { - # Prepare test parameters - dataset_list <- list(dm = dm_dummy, ae = ae_dummy) - default_vars <- list(dm = c("USUBJID", "AGE", "SEX"), ae = c("USUBJID", "AETERM", "AESEV")) - dataset_metadata <- list( - name = shiny::reactive("trial_xy"), - date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) - ) - - # Perform tests - shiny::testServer( - server_func, - args = list( - dataset_list = shiny::reactive({ - dataset_list - }), - default_vars = default_vars, - dataset_metadata = dataset_metadata, - intended_use_label = NULL - ), - { - expect_equal(r_selected_columns_in_dataset(), default_vars) - } - ) - }) + vdoc[["add_spec"]](specs$default_vars), { + # Prepare test parameters + dataset_list <- list(dm = dm_dummy, ae = ae_dummy) + default_vars <- list(dm = c("USUBJID", "AGE", "SEX"), ae = c("USUBJID", "AETERM", "AESEV")) + dataset_metadata <- list( + name = shiny::reactive("trial_xy"), + date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) + ) + + # Perform tests + shiny::testServer( + server_func, + args = list( + dataset_list = shiny::reactive({ + dataset_list + }), + default_vars = default_vars, + dataset_metadata = dataset_metadata, + intended_use_label = NULL + ), + { + expect_equal(r_selected_columns_in_dataset(), default_vars) + } + ) +}) test_that("listings_server() adds default variables, if not specified by the app creator" %>% - vdoc[["add_spec"]](specs$default_vars), { - # Prepare test parameters - dataset_list <- list(dm = dm_dummy, ae = ae_dummy) - default_vars <- list(dm = c("USUBJID", "AGE", "SEX")) - expected_cols <- default_vars %>% - purrr::list_modify(ae = names(dataset_list$ae)[1:6]) - dataset_metadata <- list( - name = shiny::reactive("trial_xy"), - date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) - ) - - # Perform tests - shiny::testServer( - server_func, - args = list( - dataset_list = shiny::reactive({ - dataset_list - }), - default_vars = default_vars, - dataset_metadata = dataset_metadata, - intended_use_label = NULL - ), - { - session$setInputs(dataset = "ae") - expect_equal(r_selected_columns_in_dataset(), expected_cols) - } - ) - }) + vdoc[["add_spec"]](specs$default_vars), { + # Prepare test parameters + dataset_list <- list(dm = dm_dummy, ae = ae_dummy) + default_vars <- list(dm = c("USUBJID", "AGE", "SEX")) + expected_cols <- default_vars %>% + purrr::list_modify(ae = names(dataset_list$ae)[1:6]) + dataset_metadata <- list( + name = shiny::reactive("trial_xy"), + date_range = shiny::reactive(c("01-01-2000", "31-12-2000")) + ) + + # Perform tests + shiny::testServer( + server_func, + args = list( + dataset_list = shiny::reactive({ + dataset_list + }), + default_vars = default_vars, + dataset_metadata = dataset_metadata, + intended_use_label = NULL + ), + { + session$setInputs(dataset = "ae") + expect_equal(r_selected_columns_in_dataset(), expected_cols) + } + ) +}) app_dir <- "./apps/bookmarking_app" @@ -197,83 +197,83 @@ app <- shinytest2::AppDriver$new( app_dir <- app$get_url() test_that("listings_server() stores the selected_columns_in_dataset and the currently selected dataset for bookmarking" %>% # nolint - vdoc[["add_spec"]](specs$retain_last_selection), { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_on_bookmark_TAB-SO-763" - ) - - app_dir <- app$get_url() - - app$set_inputs(`listings-dataset` = "dummy2") - app$wait_for_idle() # make sure inputs are updated before bookmarking - app$set_inputs(`listings-col_sel` = c("var2", "var4")) - app$wait_for_idle() - app$set_inputs(!!"._bookmark_" := "click") - - tst <- app$get_value(export = "state") - bmk_url <- app$get_value(export = "url") - query_string_list <- parseQueryString(bmk_url, nested = TRUE) - - expected_elements <- c("dummy1", "var1", "var2", "var3", "dummy2", "var2", "var4") - exist <- purrr::map2_lgl( - expected_elements, - query_string_list$`listings-selected_columns_in_dataset`, - grepl - ) - - testthat::expect_true(all(exist)) - testthat::expect_true(grepl("dummy2", query_string_list$`listings-data_sel`)) - }) + vdoc[["add_spec"]](specs$retain_last_selection), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_on_bookmark_TAB-SO-763" + ) + + app_dir <- app$get_url() + + app$set_inputs(`listings-dataset` = "dummy2") + app$wait_for_idle() # make sure inputs are updated before bookmarking + app$set_inputs(`listings-col_sel` = c("var2", "var4")) + app$wait_for_idle() + app$set_inputs(!!"._bookmark_" := "click") + + tst <- app$get_value(export = "state") + bmk_url <- app$get_value(export = "url") + query_string_list <- parseQueryString(bmk_url, nested = TRUE) + + expected_elements <- c("dummy1", "var1", "var2", "var3", "dummy2", "var2", "var4") + exist <- purrr::map2_lgl( + expected_elements, + query_string_list$`listings-selected_columns_in_dataset`, + grepl + ) + + testthat::expect_true(all(exist)) + testthat::expect_true(grepl("dummy2", query_string_list$`listings-data_sel`)) +}) test_that("listings_server() restores the selected_columns_in_dataset and the currently selected dataset for bookmarking" %>% # nolint - vdoc[["add_spec"]](specs$retain_last_selection), { # nolint - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_bookmark_TAB-SO-777" - ) - - # Capture the background app's URL and add appropriate query parameters - bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=2&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint - # Open the bookmark URL in a new AppDriver object - app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_restore_bookmark") - - actual <- app$get_values(export = c("listings-selected_columns_in_dataset", "listings-data_sel")) - - expected <- list(export = list( - `listings-selected_columns_in_dataset` = list( - dummy1 = c("var1", "var2", "var3"), - dummy2 = c("var2", "var4") - ) - )) - - testthat::expect_equal(actual, expected) - }) - -test_that("listings_server() allows bookmarking for dataset and column selections" %>% - vdoc[["add_spec"]](specs$bookmarking), { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_on_bookmark_TAB-SO-777" - ) - - # Capture the background app's URL and add appropriate query parameters - bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=1&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint - - # Open the bookmark URL in a new AppDriver object - app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_on_bookmark") - - actual <- app$get_values(input = c("listings-dataset", "listings-col_sel")) - - expected <- list(input = list( - `listings-col_sel` = c("var2", "var4"), - `listings-dataset` = "dummy2" - )) - - testthat::expect_equal(actual, expected) - - app$stop() - }) + vdoc[["add_spec"]](specs$retain_last_selection), { # nolint + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_bookmark_TAB-SO-777" + ) + + # Capture the background app's URL and add appropriate query parameters + bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=2&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint + # Open the bookmark URL in a new AppDriver object + app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_restore_bookmark") + + actual <- app$get_values(export = c("listings-selected_columns_in_dataset", "listings-data_sel")) + + expected <- list(export = list( + `listings-selected_columns_in_dataset` = list( + dummy1 = c("var1", "var2", "var3"), + dummy2 = c("var2", "var4") + ) + )) + + testthat::expect_equal(actual, expected) +}) + +test_that("listings_server() allows bookmarking for dataset and column selections" %>% + vdoc[["add_spec"]](specs$bookmarking), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_on_bookmark_TAB-SO-777" + ) + + # Capture the background app's URL and add appropriate query parameters + bk_url <- paste0(app$get_url(), "?_inputs_&listings-dropdown_btn_state=false&listings-col_sel=%5B%22var2%22%2C%22var4%22%5D&listings-dataset=%22dummy2%22&listings-export-download_data=0&listings-dropdown_btn=1&_values_&listings-selected_columns_in_dataset=%7B%22dummy1%22%3A%5B%22var1%22%2C%22var2%22%2C%22var3%22%5D%2C%22dummy2%22%3A%5B%22var2%22%2C%22var4%22%5D%7D&listings-data_sel=%22dummy2%22") # nolint + + # Open the bookmark URL in a new AppDriver object + app <- shinytest2::AppDriver$new(app_dir = bk_url, name = "test_on_bookmark") + + actual <- app$get_values(input = c("listings-dataset", "listings-col_sel")) + + expected <- list(input = list( + `listings-col_sel` = c("var2", "var4"), + `listings-dataset` = "dummy2" + )) + + testthat::expect_equal(actual, expected) + + app$stop() +}) test_that("listings_server() displays default columns after SSO redirect", { skip("Cannot integrate SSO in unit test, i.e. this test has to be performed manually.") @@ -289,27 +289,27 @@ 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") - + names_test_cases <- list(dataset_names_no_chr, dataset_names_list) - + # Perform tests purrr::walk(names_test_cases, ~ expect_error(mod_listings(dataset_names = .x, module_id = "test_id"))) }) @@ -317,10 +317,10 @@ test_that("mod_listings() fails when argument types mismatch", { 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)) }) @@ -329,10 +329,10 @@ test_that("mod_listings() returns a list containing all information for dv.manag # Valid parameters disp <- dv.manager::mm_dispatch("filtered_dataset", "adsl") id <- "test_id" - + # Return value outcome <- mod_listings(dataset_disp = disp, module_id = id) - + # 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 @@ -343,55 +343,57 @@ test_that("mod_listings() returns a list containing all information for dv.manag -test_that("mod_listings() displays a data table, dataset selector and corresponding column selector at app launch" %>% - vdoc[["add_spec"]]( - c(specs$display_listing, - specs$listing_selection, - specs$column_selection - ) - ), { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_initial_state" - ) - - dataset_sel <- app$get_value(input = "listings-dataset") - column_sel <- app$get_value(input = "listings-col_sel") - table_out <- app$get_value(output = "listings-listing") - - # Verify that required elements exist - testthat::expect_true(!is.null(dataset_sel) && !is.null(column_sel) && !is.null(table_out)) - }) - -test_that("mod_listings() restores row order of the whole table when restoring a sorted variable" %>% - vdoc[["add_spec"]]( - c(specs$restore_row_order, - specs$sorting_columns - ) - ), { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_restore_row_order" - ) - - # Needed buttons to click - sort_selector <- '.dt-center.sorting[aria-label="var1 [My 1st label]: activate to sort column ascending"]' - reset_selector <- "div.dt-buttons>button" - - # Perform steps within test app - app$wait_for_idle() - initial_rows <- app$get_value(input = "listings-listing_rows_all") - app$click(selector = sort_selector) - app$wait_for_idle() - sorted_rows <- app$get_value(input = "listings-listing_rows_all") - app$click(selector = reset_selector) - app$wait_for_idle() - reset_rows <- app$get_value(input = "listings-listing_rows_all") - - # Perform test that row order changed and then gets restored - testthat::expect_false(all(initial_rows == sorted_rows)) - testthat::expect_identical(initial_rows, reset_rows) - }) +test_that("mod_listings() displays a data table, dataset selector and corresponding column selector at app launch" %>% + vdoc[["add_spec"]]( + c( + specs$display_listing, + specs$listing_selection, + specs$column_selection + ) + ), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_initial_state" + ) + + dataset_sel <- app$get_value(input = "listings-dataset") + column_sel <- app$get_value(input = "listings-col_sel") + table_out <- app$get_value(output = "listings-listing") + + # Verify that required elements exist + testthat::expect_true(!is.null(dataset_sel) && !is.null(column_sel) && !is.null(table_out)) +}) + +test_that("mod_listings() restores row order of the whole table when restoring a sorted variable" %>% + vdoc[["add_spec"]]( + c( + specs$restore_row_order, + specs$sorting_columns + ) + ), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_restore_row_order" + ) + + # Needed buttons to click + sort_selector <- '.dt-center.sorting[aria-label="var1 [My 1st label]: activate to sort column ascending"]' + reset_selector <- "div.dt-buttons>button" + + # Perform steps within test app + app$wait_for_idle() + initial_rows <- app$get_value(input = "listings-listing_rows_all") + app$click(selector = sort_selector) + app$wait_for_idle() + sorted_rows <- app$get_value(input = "listings-listing_rows_all") + app$click(selector = reset_selector) + app$wait_for_idle() + reset_rows <- app$get_value(input = "listings-listing_rows_all") + + # Perform test that row order changed and then gets restored + testthat::expect_false(all(initial_rows == sorted_rows)) + testthat::expect_identical(initial_rows, reset_rows) +}) app_dir <- "./apps/mm_app" # applies for all tests within this describe() @@ -406,7 +408,7 @@ test_that("mock_listings_mm() launches successfully the module via dv.manager", app_dir = app_dir, name = "test_launch_mm" ) app$wait_for_idle() - + value_list <- app$get_values( input = c("multi-dataset", "multi-col_sel"), export = "multi-output_table" @@ -414,70 +416,70 @@ test_that("mock_listings_mm() launches successfully the module via dv.manager", # check availability of: # values for dataset and column selection # output dataframe - + # Only the existence of values are checked not the actual values col_sel <- length(value_list[["input"]][["multi-col_sel"]]) > 0 data_sel <- length(value_list[["input"]][["multi-dataset"]]) == 1 - + out_table <- (nrow(value_list[["export"]][["multi-output_table"]]) > 0 && - ncol(value_list[["export"]][["multi-output_table"]]) > 0) # nolint - + ncol(value_list[["export"]][["multi-output_table"]]) > 0) # nolint + # Verify that module can be launched via module manager by expecting values for selectors and a output dataframe testthat::expect_true((col_sel && data_sel && out_table)) }) # integration -test_that("mock_table_mm() displays the column names with the corresponding labels" %>% - vdoc[["add_spec"]](specs$column_label), { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_col_labels_TAB-SO-760" - ) - - expected <- c( - "STUDYID [No label]", "DOMAIN [Domain Abbreviation]", - "USUBJID [Unique Subject Identifier]", "SUBJID [Subject Identifier for the Study]", - "RFSTDTC [Subject Reference Start Date/Time]", "RFENDTC [Subject Reference End Date/Time]", - "RFXSTDTC [Date/Time of First Study Treatment]", "RFXENDTC [Date/Time of Last Study Treatment]" - ) - - actual <- app$get_value(export = "multi-column_names") - - # Verify that dataset choices are displayed properly with their labels - testthat::expect_equal(actual, expected) - }) - -test_that("mock_table_mm() updates dropdown choices on dataset change in dv.manager" %>% - vdoc[["add_spec"]](specs$listings_label), { - # Initialize test app - app <- shinytest2::AppDriver$new( - app_dir = app_dir, name = "test_update_labels" - ) - - expected <- c( - "adsl [Subject Level]" = "adsl", - "adae [Adverse Events]" = "adae", - "small [Few columns]" = "small" - ) - - actual <- app$get_value(export = "multi-dataset_choices") - - # Verify that dataset choices are displayed properly with their labels - testthat::expect_equal(actual, expected = expected) - - # Switch overall dataset (via module manager) - app$set_inputs(selector = "demo no labels") - - expected <- c( - "adsl [No label]" = "adsl", - "adae [No label]" = "adae", - "small [No label]" = "small" - ) - - actual <- app$get_value(export = "multi-dataset_choices") - - # Verify that dataset choices were updated due to dataset switch - testthat::expect_equal(actual, expected = expected) - }) # integration +test_that("mock_table_mm() displays the column names with the corresponding labels" %>% + vdoc[["add_spec"]](specs$column_label), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_col_labels_TAB-SO-760" + ) + + expected <- c( + "STUDYID [No label]", "DOMAIN [Domain Abbreviation]", + "USUBJID [Unique Subject Identifier]", "SUBJID [Subject Identifier for the Study]", + "RFSTDTC [Subject Reference Start Date/Time]", "RFENDTC [Subject Reference End Date/Time]", + "RFXSTDTC [Date/Time of First Study Treatment]", "RFXENDTC [Date/Time of Last Study Treatment]" + ) + + actual <- app$get_value(export = "multi-column_names") + + # Verify that dataset choices are displayed properly with their labels + testthat::expect_equal(actual, expected) +}) + +test_that("mock_table_mm() updates dropdown choices on dataset change in dv.manager" %>% + vdoc[["add_spec"]](specs$listings_label), { + # Initialize test app + app <- shinytest2::AppDriver$new( + app_dir = app_dir, name = "test_update_labels" + ) + + expected <- c( + "adsl [Subject Level]" = "adsl", + "adae [Adverse Events]" = "adae", + "small [Few columns]" = "small" + ) + + actual <- app$get_value(export = "multi-dataset_choices") + + # Verify that dataset choices are displayed properly with their labels + testthat::expect_equal(actual, expected = expected) + + # Switch overall dataset (via module manager) + app$set_inputs(selector = "demo no labels") + + expected <- c( + "adsl [No label]" = "adsl", + "adae [No label]" = "adae", + "small [No label]" = "small" + ) + + actual <- app$get_value(export = "multi-dataset_choices") + + # Verify that dataset choices were updated due to dataset switch + testthat::expect_equal(actual, expected = expected) +}) # integration test_that("mock_table_mm() displays no table when global filter returns an empty data.frame", { # Initialize test app @@ -485,7 +487,7 @@ test_that("mock_table_mm() displays no table when global filter returns an empty app_dir = app_dir, name = "test_empty_df", timeout = 6000, load_timeout = 30000 ) - + # Choose global filter settings that lead to an empty data.frame # NOTE: It is not possible to put those two set_input() lines into only one call since we need to wait until the # first input is available! (Second call wouldn't be able to find it otherwise.) @@ -493,12 +495,12 @@ test_that("mock_table_mm() displays no table when global filter returns an empty app$wait_for_idle() app$set_inputs(`global_filter-RACE` = character(0)) app$wait_for_idle(duration = 3000) - + # Verify that a table with zero rows is shown - + dataset <- app$get_value(export = "multi-output_table") actual <- nrow(dataset) - + testthat::expect_equal(actual, expected = 0) }) # integration @@ -507,17 +509,17 @@ test_that("mock_table_mm() displays selected columns after activating global fil app <- shinytest2::AppDriver$new( app_dir = app_dir, name = "test_global_filter_selected_cols" ) - + # Set selected columns selected_cols <- c("STUDYID", "USUBJID") app$set_inputs(`multi-col_sel` = selected_cols) - + # Activate global filter app$set_inputs(`global_filter-vars` = "RACE") app$wait_for_idle() - + actual <- app$get_value(input = "multi-col_sel") - + testthat::expect_equal(actual, expected = selected_cols) }) # integration @@ -526,20 +528,20 @@ test_that("mock_table_mm() displays selected dataset after activating global fil app <- shinytest2::AppDriver$new( app_dir = app_dir, name = "test_global_filter_selected_dataset" ) - + selected <- "adae" # Switch dataset app$set_inputs(`multi-dataset` = selected) app$wait_for_idle() - + # Activate global filter app$set_inputs(`global_filter-vars` = "RACE") app$wait_for_idle() - + actual <- app$get_value(input = "multi-dataset") - + # Kill test app app$stop() - + testthat::expect_equal(actual, expected = selected) }) # integration From d08ca91e922a557b375d8353fcdfffb6a2befcd9 Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Wed, 19 Jun 2024 12:13:29 +0200 Subject: [PATCH 06/11] Update pkgdown.yml --- _pkgdown.yml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 69fb080..708f895 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -3,11 +3,12 @@ template: navbar: type: inverse + structure: + left: [intro, reference, articles, tutorials, news, qc] components: qc: text: Quality Control - href: articles/qc.html - + href: articles/qc.html home: title: dv.listings links: @@ -24,7 +25,3 @@ reference: - listings_UI - listings_server - mod_simple_listing -- title: Quality Control - desc: Quality Control - contents: - - qc From 11f583c074fd87a7c8ebb3a16c42f6cb8f3dcf09 Mon Sep 17 00:00:00 2001 From: Luis Moris Fernandez Date: Thu, 20 Jun 2024 09:17:06 +0200 Subject: [PATCH 07/11] update validation files --- inst/validation/utils-validation.R | 59 ++++++++++++++++++---------- inst/validation/val_report_child.Rmd | 7 ++-- 2 files changed, 41 insertions(+), 25 deletions(-) diff --git a/inst/validation/utils-validation.R b/inst/validation/utils-validation.R index 4dfafd6..06eeb3d 100644 --- a/inst/validation/utils-validation.R +++ b/inst/validation/utils-validation.R @@ -36,7 +36,7 @@ if (FALSE) { test_that(vdoc[["add_spec"]]("my test_description", my_spec), { ... }) - + test_that(vdoc[["add_spec"]]("my test_description", specs[["my"]][["hier"]][["spec"]]), { ... }) @@ -56,7 +56,7 @@ if (FALSE) { } # Validation code - +# nolint start cyclocomp_linter local({ specs <- source( system.file("validation", "specs.R", package = package_name, mustWork = TRUE), @@ -112,27 +112,44 @@ local({ } # This should be covered by pack of constants but just in case } else { spec_id_chr <- spec_id - } - structure(desc, spec_id = spec_id_chr, spec = spec) + } + paste0(desc, "__spec_ids{", paste0(spec_id_chr, collapse = ";"), "}") }, - get_spec = function(result) { - lapply( - result, - function(x) { - first_result <- try( - x[[1]][["test"]], - silent = TRUE - ) - if (inherits(first_result, "try-error")) { - list(spec_id = NULL, desc = NULL) - } else { - list( - spec_id = attr(first_result, "spec_id", exact = TRUE), - spec = attr(first_result, "spec", exact = TRUE) - ) - } + get_spec = function(test, specs) { + spec_ids <- utils::strcapture( + pattern = "__spec_ids\\{(.*)\\}", + x = test, + proto = list(spec = character()) + )[["spec"]] + + spec_ids <- strsplit(spec_ids, split = ";") + + specs_and_id <- list() + + for (idx in seq_along(spec_ids)){ + ids <- spec_ids[[idx]] + if (all(!is.na(ids))) { + this_specs <- list() + for (sub_idx in seq_along(ids)) { + id <- ids[[sub_idx]] + this_specs[[sub_idx]] <- eval(str2expression(paste0("specs$", id))) } - ) + specs_and_id[[idx]] <- list( + spec_id = ids, + spec = this_specs + ) + } else { + specs_and_id[[idx]] <- list( + spec_id = NULL, + spec = NULL + ) + } + } + specs_and_id } + + ) }) + +# nolint end cyclocomp_linter \ No newline at end of file diff --git a/inst/validation/val_report_child.Rmd b/inst/validation/val_report_child.Rmd index 6331537..bf7f1bc 100644 --- a/inst/validation/val_report_child.Rmd +++ b/inst/validation/val_report_child.Rmd @@ -17,7 +17,7 @@ vdoc <- local({ # ########## # package_name is used # INSIDE # the sourced file below - # ########## + # ########## package_name <- params[["package"]] utils_file_path <- system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE) source(utils_file_path, local = TRUE)[["value"]] @@ -30,7 +30,7 @@ suppressPackageStartupMessages(stopifnot(requireNamespace("devtools"))) # Parse tests ---- tests <- as.data.frame(params[["tests"]]) -tests[["validation_data"]] <- vdoc[["get_spec"]](tests[["result"]]) +tests[["validation_data"]] <- vdoc[["get_spec"]](tests[["test"]], vdoc[["specs"]]) tests[["spec_id"]] <- sapply(tests[["validation_data"]], function(x) x[["spec_id"]]) tests[["spec"]] <- sapply(tests[["validation_data"]], function(x) x[["spec"]]) tests[["spec_id_paste"]] <- vapply(tests[["spec_id"]], function(x) paste(x, collapse = "\n"), FUN.VALUE = character(1)) @@ -49,8 +49,7 @@ undeclared_spec <- tested_spec[!tested_spec %in% declared_spec] spec_tests[["are_declared"]] <- sapply(spec_tests[["spec_id"]], function(x) all(x %in% declared_spec)) # Count tests in the different categories ---- - -mask_failed <- !!spec_tests[["failed"]] +mask_failed <- !!spec_tests[["failed"]] | spec_tests[["error"]] mask_skipped <- !!spec_tests[["skipped"]] mask_declared <- spec_tests[["are_declared"]] n_pass_dec <- sum(!mask_failed & !mask_skipped & mask_declared) From 9fd144372d853dc6d7fe5caff91efa9356c3dc49 Mon Sep 17 00:00:00 2001 From: Korbinian Matthias <123395522+mattkorb@users.noreply.github.com> Date: Fri, 21 Jun 2024 09:46:47 +0200 Subject: [PATCH 08/11] Apply suggestions from code review MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Isabel Glauß <64188972+iglauss@users.noreply.github.com> --- inst/validation/specs.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/inst/validation/specs.R b/inst/validation/specs.R index 71a8bc8..cfcfff9 100644 --- a/inst/validation/specs.R +++ b/inst/validation/specs.R @@ -3,12 +3,12 @@ specs_list <- list listing <- specs_list( - "display_listing" = "dv.listings displays a dataset in a tabular form", - "listing_selection" = "dv.listings includes a dropdown menu to select which listing to be shown.", + "display_listing" = "dv.listings displays a dataset as listing", + "listing_selection" = "dv.listings includes a dropdown menu to select which dataset to be shown.", "listings_label" = "dv.listings displays the label of a listing if available. The label is concatenated to the listing’s dataset name and the resulting strings are provided as choices in the listings dropdown menu.", "column_selection" = "dv.listings includes a dropdown menu to select the columns from the selected listing to be shown and arrange their order.", - "column_label" = "dv.listings displays the column labels of a listing if available. Column names are pasted together with their label. These extended column titles replace the original column names, so that they are visible in the listings display and column dropdown menu.", - "sorting_columns" = "dv.listings includes sorting functionality for each of the different variables included in the dataset", + "column_label" = "dv.listings displays extended column headers consisting of the variable name pasted together with its label, if available. These extended column headers replace the original variable names in the column dropdown menu.", + "sorting_columns" = "dv.listings includes sorting functionality for each of the column.", "restore_row_order" = "dv.listings includes a button to restore the row order of a listing to the state as it is in the original data.", "default_vars" = "If pre-specifications for default columns are available, dv.listings will display them at app launch for the respective listing. If not, dv.listings will show the first six columns of the listing - or all columns, in case the number of columns is less than six.", "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the ", From 4b136d727eda834268f8003914e6968a57ffef76 Mon Sep 17 00:00:00 2001 From: Korbinian Matthias <123395522+mattkorb@users.noreply.github.com> Date: Fri, 21 Jun 2024 09:47:29 +0200 Subject: [PATCH 09/11] Update inst/validation/specs.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Isabel Glauß <64188972+iglauss@users.noreply.github.com> --- inst/validation/specs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/validation/specs.R b/inst/validation/specs.R index cfcfff9..720dd63 100644 --- a/inst/validation/specs.R +++ b/inst/validation/specs.R @@ -5,7 +5,7 @@ specs_list <- list listing <- specs_list( "display_listing" = "dv.listings displays a dataset as listing", "listing_selection" = "dv.listings includes a dropdown menu to select which dataset to be shown.", - "listings_label" = "dv.listings displays the label of a listing if available. The label is concatenated to the listing’s dataset name and the resulting strings are provided as choices in the listings dropdown menu.", + "listings_label" = "dv.listings displays the label of a dataset if available. The label is concatenated to the dataset name and the resulting strings are provided as choices in the module's dropdown menu.", "column_selection" = "dv.listings includes a dropdown menu to select the columns from the selected listing to be shown and arrange their order.", "column_label" = "dv.listings displays extended column headers consisting of the variable name pasted together with its label, if available. These extended column headers replace the original variable names in the column dropdown menu.", "sorting_columns" = "dv.listings includes sorting functionality for each of the column.", From 2b449652c3e10e200f34af87463d4b32859613f2 Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Fri, 21 Jun 2024 11:20:58 +0200 Subject: [PATCH 10/11] Update specs --- inst/validation/specs.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/inst/validation/specs.R b/inst/validation/specs.R index 720dd63..d90c50a 100644 --- a/inst/validation/specs.R +++ b/inst/validation/specs.R @@ -1,5 +1,5 @@ # Use a list to declare the specs -# nolint start +# nolint start line_length_linter specs_list <- list listing <- specs_list( @@ -11,7 +11,7 @@ listing <- specs_list( "sorting_columns" = "dv.listings includes sorting functionality for each of the column.", "restore_row_order" = "dv.listings includes a button to restore the row order of a listing to the state as it is in the original data.", "default_vars" = "If pre-specifications for default columns are available, dv.listings will display them at app launch for the respective listing. If not, dv.listings will show the first six columns of the listing - or all columns, in case the number of columns is less than six.", - "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the ", + "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the remebered selections for all listings after bookmarking.", "bookmarking" = "The module is compatible with the bookmarking feature of the dv.manager." ) export <- specs_list( @@ -20,9 +20,9 @@ export <- specs_list( "export_excel" = "For downloading all listings, the tables can be saved in .xlsx format only without considering local filters. Each listing will be placed in an individual worksheet within the file.", "export_pdf" = "For downloading in .pdf format, users can select one or multiple reference column(s), which will be displayed on all document pages." ) +# nolint end line_length_linter specs <- c( listing, export ) -# nolint end \ No newline at end of file From 2695e6857d147e47b5fdd74fc245b8e7aaa3195c Mon Sep 17 00:00:00 2001 From: "Matthias,Korbinian (MED BDS) BIP-DE-B" Date: Fri, 21 Jun 2024 11:34:29 +0200 Subject: [PATCH 11/11] Fix typo --- inst/validation/specs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/validation/specs.R b/inst/validation/specs.R index d90c50a..25a8640 100644 --- a/inst/validation/specs.R +++ b/inst/validation/specs.R @@ -11,7 +11,7 @@ listing <- specs_list( "sorting_columns" = "dv.listings includes sorting functionality for each of the column.", "restore_row_order" = "dv.listings includes a button to restore the row order of a listing to the state as it is in the original data.", "default_vars" = "If pre-specifications for default columns are available, dv.listings will display them at app launch for the respective listing. If not, dv.listings will show the first six columns of the listing - or all columns, in case the number of columns is less than six.", - "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the remebered selections for all listings after bookmarking.", + "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the remembered selections for all listings after bookmarking.", "bookmarking" = "The module is compatible with the bookmarking feature of the dv.manager." ) export <- specs_list(