diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml
index b21cbeaed7..cc3d83e961 100644
--- a/.pre-commit-config.yaml
+++ b/.pre-commit-config.yaml
@@ -6,7 +6,7 @@ default_language_version:
python: python3
repos:
- repo: https://github.com/lorenzwalthert/precommit
- rev: v0.4.3.9001
+ rev: v0.4.3.9003
hooks:
- id: style-files
name: Style code with `styler`
diff --git a/DESCRIPTION b/DESCRIPTION
index 740129d307..479b340e88 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,8 +1,8 @@
Type: Package
Package: teal
Title: Exploratory Web Apps for Analyzing Clinical Trials Data
-Version: 0.15.2.9078
-Date: 2024-10-28
+Version: 0.15.2.9080
+Date: 2024-11-06
Authors@R: c(
person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre"),
comment = c(ORCID = "0000-0001-9533-457X")),
@@ -52,6 +52,7 @@ Imports:
teal.logger (>= 0.2.0),
teal.reporter (>= 0.3.1.9004),
teal.widgets (>= 0.4.0),
+ tools,
utils
Suggests:
bslib,
diff --git a/NEWS.md b/NEWS.md
index 7e97dcc07a..55d7d9f4ce 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,4 +1,4 @@
-# teal 0.15.2.9078
+# teal 0.15.2.9080
### New features
diff --git a/R/init.R b/R/init.R
index eddb9e6d19..005bc448f9 100644
--- a/R/init.R
+++ b/R/init.R
@@ -212,8 +212,8 @@ init <- function(data,
}
is_modules_ok <- check_modules_datanames(modules, ls(teal.code::get_env(data)))
- if (!isTRUE(is_modules_ok) && length(unlist(extract_transforms(modules))) == 0) {
- lapply(is_modules_ok$string, warning, call. = FALSE)
+ if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
+ warning(is_modules_ok, call. = FALSE)
}
is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data)))
diff --git a/R/module_data_summary.R b/R/module_data_summary.R
index e793c53f70..d97d4955e5 100644
--- a/R/module_data_summary.R
+++ b/R/module_data_summary.R
@@ -3,15 +3,17 @@
#' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
#'
#' @details Handling different data classes:
-#' `get_object_filter_overview()` is a pseudo S3 method which has variants for:
+#' `get_filter_overview()` is a pseudo S3 method which has variants for:
#' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
#' can be applied to any two-dimensional objects on which [ncol()] can be used.
#' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
+#' - For other data types module displays data name with warning icon and no more details.
#'
-#' @param id (`character(1)`)
-#' `shiny` module instance id.
-#' @param teal_data (`reactive` returning `teal_data`)
+#' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table
+#' containing datasets where number of observations are not calculated.
#'
+#' @param id (`character(1)`) `shiny` module instance id.
+#' @param teal_data (`reactive` returning `teal_data`)
#'
#' @name module_data_summary
#' @rdname module_data_summary
@@ -65,24 +67,7 @@ srv_data_summary <- function(id, teal_data) {
if (!length(ls(teal.code::get_env(teal_data())))) {
return(NULL)
}
-
- filter_overview <- get_filter_overview(teal_data)
- names(filter_overview)[[1]] <- "Data Name"
-
- filter_overview$Obs <- ifelse(
- !is.na(filter_overview$obs),
- sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
- ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
- )
-
- filter_overview$Subjects <- ifelse(
- !is.na(filter_overview$subjects),
- sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
- ""
- )
-
- filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
- Filter(function(col) !all(col == ""), filter_overview)
+ get_filter_overview_wrapper(teal_data)
})
output$table <- renderUI({
@@ -95,31 +80,26 @@ srv_data_summary <- function(id, teal_data) {
} else if (is.null(summary_table_out)) {
"no datasets to show"
} else {
+ is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))
+ summary_table_out[is.na(summary_table_out)] <- ""
body_html <- apply(
summary_table_out,
1,
function(x) {
- tags$tr(
- tagList(
- tags$td(
- if (all(x[-1] == "")) {
- icon(
- name = "fas fa-exclamation-triangle",
- title = "Unsupported dataset",
- `data-container` = "body",
- `data-toggle` = "popover",
- `data-content` = "object not supported by the data_summary module"
- )
- },
- x[1]
- ),
- lapply(x[-1], tags$td)
+ is_supported <- !all(x[-1] == "")
+ if (is_supported) {
+ tags$tr(
+ tagList(
+ tags$td(x[1]),
+ lapply(x[-1], tags$td)
+ )
)
- )
+ }
}
)
- header_labels <- names(summary_table())
+ header_labels <- tools::toTitleCase(names(summary_table_out))
+ header_labels[header_labels == "Dataname"] <- "Data Name"
header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
table_html <- tags$table(
@@ -127,28 +107,52 @@ srv_data_summary <- function(id, teal_data) {
tags$thead(header_html),
tags$tbody(body_html)
)
- table_html
+ div(
+ table_html,
+ if (any(is_unsupported)) {
+ p(
+ class = c("pull-right", "float-right", "text-secondary"),
+ style = "font-size: 0.8em;",
+ sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
+ icon(
+ name = "far fa-circle-question",
+ title = paste(
+ sep = "",
+ collapse = "\n",
+ shQuote(summary_table()[is_unsupported, "dataname"]),
+ " (",
+ vapply(
+ summary_table()[is_unsupported, "dataname"],
+ function(x) class(teal_data()[[x]])[1],
+ character(1L)
+ ),
+ ")"
+ )
+ )
+ )
+ }
+ )
}
})
- summary_table # testing purpose
+ NULL
}
)
}
#' @rdname module_data_summary
-get_filter_overview <- function(teal_data) {
+get_filter_overview_wrapper <- function(teal_data) {
datanames <- teal.data::datanames(teal_data())
joinkeys <- teal.data::join_keys(teal_data())
- filtered_data_objs <- sapply(
+ current_data_objs <- sapply(
datanames,
function(name) teal.code::get_var(teal_data(), name),
simplify = FALSE
)
- unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
+ initial_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
- rows <- lapply(
+ out <- lapply(
datanames,
function(dataname) {
parent <- teal.data::parent(joinkeys, dataname)
@@ -163,83 +167,86 @@ get_filter_overview <- function(teal_data) {
} else {
joinkeys[dataname, dataname]
}
- get_object_filter_overview(
- filtered_data = filtered_data_objs[[dataname]],
- unfiltered_data = unfiltered_data_objs[[dataname]],
+ get_filter_overview(
+ current_data = current_data_objs[[dataname]],
+ initial_data = initial_data_objs[[dataname]],
dataname = dataname,
subject_keys = subject_keys
)
}
)
- unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
- do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
+ do.call(.smart_rbind, out)
}
+
#' @rdname module_data_summary
-#' @param filtered_data (`list`) of filtered objects
-#' @param unfiltered_data (`list`) of unfiltered objects
+#' @param current_data (`object`) current object (after filtering and transforming).
+#' @param initial_data (`object`) initial object.
#' @param dataname (`character(1)`)
-get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
- if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
- get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
- } else if (inherits(filtered_data, "MultiAssayExperiment")) {
- get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
+#' @param subject_keys (`character`) names of the columns which determine a single unique subjects
+get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
+ if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
+ get_filter_overview_array(current_data, initial_data, dataname, subject_keys)
+ } else if (inherits(current_data, "MultiAssayExperiment")) {
+ get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)
} else {
- data.frame(
- dataname = dataname,
- obs = NA,
- obs_filtered = NA,
- subjects = NA,
- subjects_filtered = NA
- )
+ data.frame(dataname = dataname)
}
}
#' @rdname module_data_summary
-get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
- unfiltered_data,
- dataname,
- subject_keys) {
+get_filter_overview_array <- function(current_data,
+ initial_data,
+ dataname,
+ subject_keys) {
if (length(subject_keys) == 0) {
data.frame(
dataname = dataname,
- obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
- obs_filtered = nrow(filtered_data),
- subjects = NA,
- subjects_filtered = NA
+ obs = if (!is.null(initial_data)) {
+ sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+ } else {
+ nrow(current_data)
+ }
)
} else {
data.frame(
dataname = dataname,
- obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
- obs_filtered = nrow(filtered_data),
- subjects = nrow(unique(unfiltered_data[subject_keys])),
- subjects_filtered = nrow(unique(filtered_data[subject_keys]))
+ obs = if (!is.null(initial_data)) {
+ sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+ } else {
+ nrow(current_data)
+ },
+ subjects = if (!is.null(initial_data)) {
+ sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
+ } else {
+ nrow(unique(current_data[subject_keys]))
+ }
)
}
}
#' @rdname module_data_summary
-get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
- unfiltered_data,
- dataname) {
- experiment_names <- names(unfiltered_data)
+get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.
+ initial_data,
+ dataname) {
+ experiment_names <- names(current_data)
mae_info <- data.frame(
dataname = dataname,
- obs = NA,
- obs_filtered = NA,
- subjects = nrow(unfiltered_data@colData),
- subjects_filtered = nrow(filtered_data@colData)
+ subjects = if (!is.null(initial_data)) {
+ sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
+ } else {
+ nrow(current_data@colData)
+ }
)
experiment_obs_info <- do.call("rbind", lapply(
experiment_names,
function(experiment_name) {
transform(
- get_object_filter_overview(
- filtered_data[[experiment_name]],
- unfiltered_data[[experiment_name]],
+ get_filter_overview(
+ current_data[[experiment_name]],
+ initial_data[[experiment_name]],
dataname = experiment_name,
subject_keys = join_keys() # empty join keys
),
@@ -257,12 +264,19 @@ get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nol
experiment_names,
function(experiment_name) {
data.frame(
- subjects = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
- subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
+ subjects = if (!is.null(initial_data)) {
+ sprintf(
+ "%s/%s",
+ get_experiment_keys(current_data, current_data[[experiment_name]]),
+ get_experiment_keys(current_data, initial_data[[experiment_name]])
+ )
+ } else {
+ get_experiment_keys(current_data, current_data[[experiment_name]])
+ }
)
}
))
- experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
- rbind(mae_info, experiment_info)
+ experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
+ .smart_rbind(mae_info, experiment_info)
}
diff --git a/R/module_init_data.R b/R/module_init_data.R
index f2a39ce6e0..060d25afb5 100644
--- a/R/module_init_data.R
+++ b/R/module_init_data.R
@@ -95,7 +95,6 @@ srv_init_data <- function(id, data) {
#' @keywords internal
.add_signature_to_data <- function(data) {
hashes <- .get_hashes_code(data)
-
tdata <- do.call(
teal.data::teal_data,
c(
diff --git a/R/module_teal.R b/R/module_teal.R
index 478e816e91..acb0759786 100644
--- a/R/module_teal.R
+++ b/R/module_teal.R
@@ -218,6 +218,7 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
data_load_status <- reactive({
if (inherits(data_pulled(), "teal_data")) {
"ok"
+ # todo: should we hide warnings on top for a data?
} else if (inherits(data, "teal_data_module")) {
"teal_data_module failed"
} else {
diff --git a/R/module_teal_data.R b/R/module_teal_data.R
index 3ea560ee4d..b8765ccc96 100644
--- a/R/module_teal_data.R
+++ b/R/module_teal_data.R
@@ -222,15 +222,11 @@ srv_check_module_datanames <- function(id, data, modules) {
moduleServer(id, function(input, output, session) {
output$message <- renderUI({
if (inherits(data(), "teal_data")) {
- is_modules_ok <- check_modules_datanames(modules = modules, datanames = ls(teal.code::get_env(data())))
+ is_modules_ok <- check_modules_datanames_html(
+ modules = modules, datanames = ls(teal.code::get_env(data()))
+ )
if (!isTRUE(is_modules_ok)) {
- tags$div(
- class = "teal-output-warning",
- is_modules_ok$html(
- # Show modules prefix on message only in teal_data_module tab
- grepl(sprintf("data-teal_data_module-%s", id), session$ns(NULL), fixed = TRUE)
- )
- )
+ tags$div(is_modules_ok, class = "teal-output-warning")
}
}
})
diff --git a/R/utils.R b/R/utils.R
index e5830bf0ca..345350fe0d 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -122,76 +122,112 @@ report_card_template <- function(title, label, description = NULL, with_filter,
#' Check `datanames` in modules
#'
-#' This function ensures specified `datanames` in modules match those in the data object,
-#' returning error messages or `TRUE` for successful validation.
+#' These functions check if specified `datanames` in modules match those in the data object,
+#' returning error messages or `TRUE` for successful validation. Two functions return error message
+#' in different forms:
+#' - `check_modules_datanames` returns `character(1)` for basic assertion usage
+#' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app.
#'
#' @param modules (`teal_modules`) object
#' @param datanames (`character`) names of datasets available in the `data` object
#'
-#' @return A `character(1)` containing error message or `TRUE` if validation passes.
+#' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list`
#' @keywords internal
check_modules_datanames <- function(modules, datanames) {
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
- checkmate::assert_character(datanames)
+ out <- check_modules_datanames_html(modules, datanames)
+ if (inherits(out, "shiny.tag.list")) {
+ out_with_ticks <- gsub("|
", "`", toString(out))
+ out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
+ trimws(gsub("[[:space:]]+", " ", out_text))
+ } else {
+ out
+ }
+}
- recursive_check_datanames <- function(modules, datanames) {
- # check teal_modules against datanames
- if (inherits(modules, "teal_modules")) {
- result <- lapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
- result <- result[vapply(result, Negate(is.null), logical(1L))]
- if (length(result) == 0) {
- return(NULL)
- }
- list(
- string = do.call(c, as.list(unname(sapply(result, function(x) x$string)))),
- html = function(with_module_name = TRUE) {
- tagList(
- lapply(
- result,
- function(x) x$html(with_module_name = with_module_name)
+#' @rdname check_modules_datanames
+check_modules_datanames_html <- function(modules,
+ datanames) {
+ check_datanames <- check_modules_datanames_recursive(modules, datanames)
+ show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app
+ if (!length(check_datanames)) {
+ return(TRUE)
+ }
+ shiny::tagList(
+ lapply(
+ check_datanames,
+ function(mod) {
+ tagList(
+ tags$span(
+ tags$span(if (length(mod$missing_datanames) == 1) "Dataset" else "Datasets"),
+ to_html_code_list(mod$missing_datanames),
+ tags$span(
+ paste0(
+ if (length(mod$missing_datanames) > 1) "are missing" else "is missing",
+ if (show_module_info) sprintf(" for module '%s'.", mod$label) else "."
+ )
)
- )
- }
- )
- } else {
- extra_datanames <- setdiff(modules$datanames, c("all", datanames))
- if (length(extra_datanames)) {
- list(
- string = build_datanames_error_message(
- modules$label,
- datanames,
- extra_datanames,
- tags = list(
- span = function(..., .noWS = NULL) { # nolint: object_name
- trimws(paste(..., sep = ifelse(is.null(.noWS), " ", ""), collapse = " "))
- },
- code = function(x) toString(dQuote(x, q = FALSE))
- ),
- tagList = function(...) trimws(paste(...))
),
- # Build HTML representation of the error message with
formatting - html = function(with_module_name = TRUE) { + if (length(datanames) >= 1) { tagList( - build_datanames_error_message( - if (with_module_name) modules$label, - datanames, - extra_datanames - ), - tags$br(.noWS = "before") + tags$span(if (length(datanames) == 1) "Dataset" else "Datasets"), + tags$span("available in data:"), + tagList( + tags$span( + to_html_code_list(datanames), + tags$span(".", .noWS = "outside"), + .noWS = c("outside") + ) + ) ) - } + } else { + tags$span("No datasets are available in data.") + }, + tags$br(.noWS = "before") ) } - } - } - check_datanames <- recursive_check_datanames(modules, datanames) - if (length(check_datanames)) { - check_datanames + ) + ) +} + +#' Recursively checks modules and returns list for every datanames mismatch between module and data +#' @noRd +check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length + checkmate::assert_multi_class(modules, c("teal_module", "teal_modules")) + checkmate::assert_character(datanames) + if (inherits(modules, "teal_modules")) { + unlist( + lapply(modules$children, check_modules_datanames_recursive, datanames = datanames), + recursive = FALSE + ) } else { - TRUE + missing_datanames <- setdiff(modules$datanames, c("all", datanames)) + if (length(missing_datanames)) { + list(list( + label = modules$label, + missing_datanames = missing_datanames + )) + } } } +#' Convert character vector to html code separated with commas and "and" +#' @noRd +to_html_code_list <- function(x) { + checkmate::assert_character(x) + do.call( + tagList, + lapply(seq_along(x), function(.ix) { + tagList( + tags$code(x[.ix]), + if (.ix != length(x)) { + if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before") + } + ) + }) + ) +} + + #' Check `datanames` in filters #' #' This function checks whether `datanames` in filters correspond to those in `data`, @@ -396,3 +432,23 @@ build_datanames_error_message <- function(label = NULL, } ) } + +#' Smart `rbind` +#' +#' Combine `data.frame` objects which have different columns +#' +#' @param ... (`data.frame`) +#' @keywords internal +.smart_rbind <- function(...) { + dots <- list(...) + checkmate::assert_list(dots, "data.frame", .var.name = "...") + Reduce( + x = dots, + function(x, y) { + all_columns <- union(colnames(x), colnames(y)) + x[setdiff(all_columns, colnames(x))] <- NA + y[setdiff(all_columns, colnames(y))] <- NA + rbind(x, y) + } + ) +} diff --git a/man/check_modules_datanames.Rd b/man/check_modules_datanames.Rd index 7fef35aec0..b01270eae2 100644 --- a/man/check_modules_datanames.Rd +++ b/man/check_modules_datanames.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/utils.R \name{check_modules_datanames} \alias{check_modules_datanames} +\alias{check_modules_datanames_html} \title{Check \code{datanames} in modules} \usage{ check_modules_datanames(modules, datanames) + +check_modules_datanames_html(modules, datanames) } \arguments{ \item{modules}{(\code{teal_modules}) object} @@ -12,10 +15,15 @@ check_modules_datanames(modules, datanames) \item{datanames}{(\code{character}) names of datasets available in the \code{data} object} } \value{ -A \code{character(1)} containing error message or \code{TRUE} if validation passes. +\code{TRUE} if validation passes, otherwise \code{character(1)} or \code{shiny.tag.list} } \description{ -This function ensures specified \code{datanames} in modules match those in the data object, -returning error messages or \code{TRUE} for successful validation. +These functions check if specified \code{datanames} in modules match those in the data object, +returning error messages or \code{TRUE} for successful validation. Two functions return error message +in different forms: +\itemize{ +\item \code{check_modules_datanames} returns \code{character(1)} for basic assertion usage +\item \code{check_modules_datanames_html} returns \code{shiny.tag.list} to display it in the app. +} } \keyword{internal} diff --git a/man/dot-smart_rbind.Rd b/man/dot-smart_rbind.Rd new file mode 100644 index 0000000000..13dfa94102 --- /dev/null +++ b/man/dot-smart_rbind.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{.smart_rbind} +\alias{.smart_rbind} +\title{Smart \code{rbind}} +\usage{ +.smart_rbind(...) +} +\arguments{ +\item{...}{(\code{data.frame})} +} +\description{ +Combine \code{data.frame} objects which have different columns +} +\keyword{internal} diff --git a/man/module_data_summary.Rd b/man/module_data_summary.Rd index 2bc009a17a..7deaf4d81b 100644 --- a/man/module_data_summary.Rd +++ b/man/module_data_summary.Rd @@ -4,49 +4,36 @@ \alias{module_data_summary} \alias{ui_data_summary} \alias{srv_data_summary} +\alias{get_filter_overview_wrapper} \alias{get_filter_overview} -\alias{get_object_filter_overview} -\alias{get_object_filter_overview_array} -\alias{get_object_filter_overview_MultiAssayExperiment} +\alias{get_filter_overview_array} +\alias{get_filter_overview_MultiAssayExperiment} \title{Data summary} \usage{ ui_data_summary(id) srv_data_summary(id, teal_data) -get_filter_overview(teal_data) +get_filter_overview_wrapper(teal_data) -get_object_filter_overview( - filtered_data, - unfiltered_data, - dataname, - subject_keys -) +get_filter_overview(current_data, initial_data, dataname, subject_keys) -get_object_filter_overview_array( - filtered_data, - unfiltered_data, - dataname, - subject_keys -) +get_filter_overview_array(current_data, initial_data, dataname, subject_keys) -get_object_filter_overview_MultiAssayExperiment( - filtered_data, - unfiltered_data, - dataname -) +get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname) } \arguments{ -\item{id}{(\code{character(1)}) -\code{shiny} module instance id.} +\item{id}{(\code{character(1)}) \code{shiny} module instance id.} \item{teal_data}{(\code{reactive} returning \code{teal_data})} -\item{filtered_data}{(\code{list}) of filtered objects} +\item{current_data}{(\code{object}) current object (after filtering and transforming).} -\item{unfiltered_data}{(\code{list}) of unfiltered objects} +\item{initial_data}{(\code{object}) initial object.} \item{dataname}{(\code{character(1)})} + +\item{subject_keys}{(\code{character}) names of the columns which determine a single unique subjects} } \value{ \code{NULL}. @@ -56,11 +43,15 @@ Module and its utils to display the number of rows and subjects in the filtered } \details{ Handling different data classes: -\code{get_object_filter_overview()} is a pseudo S3 method which has variants for: +\code{get_filter_overview()} is a pseudo S3 method which has variants for: \itemize{ \item \code{array} (\code{data.frame}, \code{DataFrame}, \code{array}, \code{Matrix} and \code{SummarizedExperiment}): Method variant can be applied to any two-dimensional objects on which \code{\link[=ncol]{ncol()}} can be used. \item \code{MultiAssayExperiment}: for which summary contains counts for \code{colData} and all \code{experiments}. +\item For other data types module displays data name with warning icon and no more details. } + +Module includes also "Show/Hide unsupported" button to toggle rows of the summary table +containing datasets where number of observations are not calculated. } \keyword{internal} diff --git a/tests/testthat/test-init.R b/tests/testthat/test-init.R index d0a022330c..1ebca65fa2 100644 --- a/tests/testthat/test-init.R +++ b/tests/testthat/test-init.R @@ -64,7 +64,20 @@ testthat::test_that( data = teal.data::teal_data(mtcars = mtcars), modules = list(example_module(datanames = "iris")) ), - "Dataset \"iris\" is missing for tab 'example teal module'. Dataset available in data: \"mtcars\"." + "Dataset `iris` is missing for module 'example teal module'. Dataset available in data: `mtcars`." + ) + } +) + +testthat::test_that( + "init throws warning when datanames in modules incompatible w/ datanames in data and there is no transformers", + { + testthat::expect_warning( + init( + data = teal.data::teal_data(mtcars = mtcars), + modules = list(example_module(datanames = c("a", "b"))) + ), + "Datasets `a` and `b` are missing for module 'example teal module'. Dataset available in data: `mtcars`." ) } ) diff --git a/tests/testthat/test-module_teal.R b/tests/testthat/test-module_teal.R index ed01caaef4..0ddf0e7717 100644 --- a/tests/testthat/test-module_teal.R +++ b/tests/testthat/test-module_teal.R @@ -221,7 +221,6 @@ testthat::describe("srv_teal teal_modules", { ) ), expr = { - testthat::expect_error(data_init(), NULL) testthat::expect_null(modules_output$module_1()) testthat::expect_null(modules_output$module_2()) } @@ -240,7 +239,6 @@ testthat::describe("srv_teal teal_modules", { ) ), expr = { - testthat::expect_error(data_init()) session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_identical(modules_output$module_1(), 101L) testthat::expect_null(modules_output$module_2()) @@ -263,7 +261,6 @@ testthat::describe("srv_teal teal_modules", { ) ), expr = { - testthat::expect_error(data_init()) session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_identical(modules_output$module_1(), 101L) testthat::expect_null(modules_output$module_2()) @@ -294,7 +291,6 @@ testthat::describe("srv_teal teal_modules", { ) ), expr = { - testthat::expect_error(data_init()) session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_identical(modules_output$module_1(), 101L) testthat::expect_null(modules_output$module_2()) @@ -347,7 +343,6 @@ testthat::describe("srv_teal teal_modules", { ) ), expr = { - testthat::expect_error(data_init()) session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_s4_class(modules_output$module_1()(), "teal_data") } @@ -374,7 +369,6 @@ testthat::describe("srv_teal teal_modules", { ), expr = { testthat::expect_null(modules_output$module_1()) - testthat::expect_error(data_init()) session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_null(modules_output$module_1()) } @@ -401,7 +395,7 @@ testthat::describe("srv_teal teal_modules", { ), expr = { testthat::expect_null(modules_output$module_1()) - testthat::expect_error(data_init()) + testthat::expect_s3_class(data_pulled(), "shiny.silent.error") session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_null(modules_output$module_1()) } @@ -417,7 +411,7 @@ testthat::describe("srv_teal teal_modules", { ui = function(id) NULL, server = function(id) { moduleServer(id, function(input, output, session) { - reactive(validate(need(FALSE, "my error"))) + reactive(stop("my error")) }) } ), @@ -428,7 +422,7 @@ testthat::describe("srv_teal teal_modules", { ), expr = { testthat::expect_null(modules_output$module_1()) - testthat::expect_error(data_init()) + testthat::expect_s3_class(data_pulled(), "simpleError") session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_null(modules_output$module_1()) } @@ -455,7 +449,7 @@ testthat::describe("srv_teal teal_modules", { ), expr = { testthat::expect_null(modules_output$module_1()) - testthat::expect_error(data_init()) + testthat::expect_s3_class(data_pulled(), "qenv.error") session$setInputs(`teal_modules-active_tab` = "module_1") testthat::expect_null(modules_output$module_1()) } @@ -551,32 +545,115 @@ testthat::describe("srv_teal teal_modules", { ) }) - testthat::it("throws warning when dataname is not available", { - testthat::skip_if_not_installed("rvest") - shiny::testServer( - app = srv_teal, - args = list( - id = "test", - data = teal_data(mtcars = mtcars), - modules = modules( - module("module_1", server = function(id, data) data, datanames = c("iris")) - ) - ), - expr = { - session$setInputs(`teal_modules-active_tab` = "module_1") + testthat::describe("warnings on missing datanames", { + testthat::it("warns when dataname is not available", { + testthat::skip_if_not_installed("rvest") + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = teal_data(iris = iris), + modules = modules( + module("module_1", server = function(id, data) data, datanames = c("iris", "missing")) + ) + ), + expr = { + session$setInputs(`teal_modules-active_tab` = "module_1") + testthat::expect_equal( + trimws( + rvest::html_text2( + rvest::read_html( + output[["teal_modules-module_1-validate_datanames-shiny_warnings-message"]]$html + ) + ) + ), + "Dataset missing is missing. Dataset available in data: iris." + ) + } + ) + }) - testthat::expect_equal( - trimws( - rvest::html_text2( - rvest::read_html( - output[["teal_modules-module_1-validate_datanames-shiny_warnings-message"]]$html + testthat::it("warns when datanames are not available", { + testthat::skip_if_not_installed("rvest") + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = teal_data(mtcars = mtcars, iris = iris), + modules = modules( + module("module_1", datanames = c("mtcars", "iris", "missing1", "missing2")) + ) + ), + expr = { + session$setInputs(`teal_modules-active_tab` = "module_1") + + testthat::expect_equal( + trimws( + rvest::html_text2( + rvest::read_html( + output[["teal_modules-module_1-validate_datanames-shiny_warnings-message"]]$html + ) ) - ) - ), - "Dataset iris is missing. No datasets are available in data." - ) - } - ) + ), + "Datasets missing1 and missing2 are missing. Datasets available in data: iris and mtcars." + ) + } + ) + }) + + testthat::it("warns about empty data when none of module$datanames is available (even if data is not empty)", { + testthat::skip_if_not_installed("rvest") + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = teal_data(mtcars = mtcars), + modules = modules( + module("module_1", datanames = c("missing1", "missing2")) + ) + ), + expr = { + session$setInputs(`teal_modules-active_tab` = "module_1") + testthat::expect_equal( + trimws( + rvest::html_text2( + rvest::read_html( + output[["teal_modules-module_1-validate_datanames-shiny_warnings-message"]]$html + ) + ) + ), + "Datasets missing1 and missing2 are missing. No datasets are available in data." + ) + } + ) + }) + + testthat::it("warns about empty data when none of module$datanames is available", { + testthat::skip_if_not_installed("rvest") + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = reactive(teal_data(mtcars = mtcars)), + modules = modules( + module("module_1", datanames = c("missing1", "missing2")) + ) + ), + expr = { + session$setInputs(`teal_modules-active_tab` = "module_1") + testthat::expect_equal( + trimws( + rvest::html_text2( + rvest::read_html( + output[["validate-shiny_warnings-message"]]$html + ) + ) + ), + "Datasets missing1 and missing2 are missing for module 'module_1'. Dataset available in data: mtcars." + ) + } + ) + }) }) testthat::it("is called and receives data even if datanames in `teal_data` are not sufficient", { @@ -2128,6 +2205,78 @@ testthat::describe("srv_teal summary table", { } ) }) + + testthat::test_that("summary table displays MAE dataset added in transforms", { + data <- within(teal.data::teal_data(), { + iris <- iris + mtcars <- mtcars + foo <- identity + }) + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = data, + modules = modules(module("module_1", server = function(id, data) data, datanames = "all", transformers = list( + teal_transform_module( + server = function(id, data) { + reactive({ + within(data(), { + withr::with_package("MultiAssayExperiment", { + data("miniACC", package = "MultiAssayExperiment", envir = environment()) + }) + }) + }) + } + ) + ))) + ), + expr = { + # throws warning as data("miniACC") hasn't been detected as miniACC dependency + suppressWarnings(session$setInputs("teal_modules-active_tab" = "module_1")) + testthat::expect_equal( + module_summary_table(output, "module_1"), + data.frame( + "Data Name" = c( + "iris", "miniACC", "- RNASeq2GeneNorm", "- gistict", + "- RPPAArray", "- Mutations", "- miRNASeqGene", "mtcars" + ), + Obs = c("150/150", "", "198", "198", "33", "97", "471", "32/32"), + Subjects = c(NA_integer_, 92, 79, 90, 46, 90, 80, NA_integer_), + check.names = FALSE + ) + ) + } + ) + }) + + testthat::it("displays unsupported datasets", { + data <- within(teal.data::teal_data(), { + iris <- iris + mtcars <- mtcars + foo <- identity + }) + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + data = data, + modules = modules(module("module_1", server = function(id, data) data, datanames = "all")) + ), + expr = { + session$setInputs("teal_modules-active_tab" = "module_1") + session$flushReact() + testthat::expect_identical( + module_summary_table(output, "module_1"), + data.frame( + "Data Name" = c("iris", "mtcars"), + Obs = c("150/150", "32/32"), + check.names = FALSE + ) + ) + } + ) + }) }) testthat::describe("srv_teal snapshot manager", { diff --git a/tests/testthat/test-rcode_utils.R b/tests/testthat/test-rcode_utils.R index 2d7cc4b946..8983355517 100644 --- a/tests/testthat/test-rcode_utils.R +++ b/tests/testthat/test-rcode_utils.R @@ -52,8 +52,8 @@ testthat::test_that("get_datasets_code returns code only for specified datanames # todo: need to use code dependency? Or test it later via public functions/modules datasets <- teal.slice::init_filtered_data( list( - IRIS = list(dataset = iris), - MTCARS = list(dataset = mtcars) + IRIS = iris, + MTCARS = mtcars ) ) testthat::expect_true(TRUE) diff --git a/tests/testthat/test-shinytest2-data_summary.R b/tests/testthat/test-shinytest2-data_summary.R index c97c861110..27cdc2918d 100644 --- a/tests/testthat/test-shinytest2-data_summary.R +++ b/tests/testthat/test-shinytest2-data_summary.R @@ -1,23 +1,20 @@ -testthat::test_that("e2e: data summary list only data names if there is no MAE or data.frames in teal_data", { +testthat::test_that("e2e: data summary just list the unfilterable objects at the bottom when provided", { skip_if_too_deep(5) app <- TealAppDriver$new( - data = teal.data::teal_data(x = 1), + data = teal.data::teal_data(x = 1, y = "z", foo = function() NULL), modules = example_module() ) - testthat::expect_identical( - as.data.frame(app$get_active_data_summary_table()), - data.frame( - `Data Name` = c("x"), - check.names = FALSE - ) + testthat::expect_match( + app$get_text(sprintf("#%s", app$active_data_summary_ns())), + "\\And 3 more unfilterable object\\(s\\)" ) app$stop() }) -testthat::test_that("e2e: data summary is displayed with 2 columns data without keys", { +testthat::test_that("e2e: data summary table is displayed with 2 columns data without keys", { skip_if_too_deep(5) app <- TealAppDriver$new( data = simple_teal_data(), # iris, mtcars @@ -36,7 +33,7 @@ testthat::test_that("e2e: data summary is displayed with 2 columns data without app$stop() }) -testthat::test_that("e2e: data summary displays datasets by topological_sort of join_keys", { +testthat::test_that("e2e: data summary table displays datasets by topological_sort of join_keys", { skip_if_too_deep(5) data <- teal.data::teal_data(mtcars1 = mtcars, mtcars2 = data.frame(am = c(0, 1), test = c("a", "b"))) @@ -58,7 +55,7 @@ testthat::test_that("e2e: data summary displays datasets by topological_sort of app$stop() }) -testthat::test_that("e2e: data summary is displayed with 3 columns for data with join keys", { +testthat::test_that("e2e: data summary table is displayed with 3 columns for data with join keys", { skip_if_too_deep(5) data <- teal.data::teal_data(mtcars1 = mtcars, mtcars2 = data.frame(am = c(0, 1), test = c("a", "b"))) @@ -86,7 +83,7 @@ testthat::test_that("e2e: data summary is displayed with 3 columns for data with }) testthat::test_that( - "e2e: data summary is displayed properly if teal_data include data.frames with join keys, MAE objects and vectors", + "e2e: data summary table does not list unsupported objects", { testthat::skip_if_not_installed("MultiAssayExperiment") skip_if_too_deep(5) @@ -99,16 +96,10 @@ testthat::test_that( iris <- iris library(MultiAssayExperiment) data("miniACC", package = "MultiAssayExperiment", envir = environment()) - # nolint start: object_name. - CO2 <- CO2 - factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) - CO2[factors] <- lapply(CO2[factors], as.character) + unsupported <- function(x) x # nolint end: object_name. } ) - - datanames(data) <- c("CO2", "iris", "miniACC", "mtcars2", "mtcars1", "factors") - teal.data::join_keys(data) <- teal.data::join_keys( teal.data::join_key("mtcars2", "mtcars1", keys = c("am")) ) @@ -122,11 +113,11 @@ testthat::test_that( as.data.frame(app$get_active_data_summary_table()), data.frame( `Data Name` = c( - "CO2", "iris", "miniACC", "- RNASeq2GeneNorm", "- gistict", "- RPPAArray", "- Mutations", "- miRNASeqGene", - "mtcars2", "mtcars1", "factors" + "iris", "miniACC", "- RNASeq2GeneNorm", "- gistict", "- RPPAArray", "- Mutations", "- miRNASeqGene", + "mtcars2", "mtcars1" ), - Obs = c("84/84", "150/150", "", "198/198", "198/198", "33/33", "97/97", "471/471", "2/2", "32/32", ""), - Subjects = c("", "", "92/92", "79/79", "90/90", "46/46", "90/90", "80/80", "", "2/2", ""), + Obs = c("150/150", "", "198/198", "198/198", "33/33", "97/97", "471/471", "2/2", "32/32"), + Subjects = c("", "92/92", "79/79", "90/90", "46/46", "90/90", "80/80", "", "2/2"), check.names = FALSE ) ) @@ -135,7 +126,7 @@ testthat::test_that( } ) -testthat::test_that("e2e: data summary displays datasets by datanames() order if no join_keys", { +testthat::test_that("e2e: data summary table displays datasets by datanames() order if no join_keys", { skip_if_too_deep(5) data <- teal.data::teal_data(mtcars1 = mtcars, mtcars2 = data.frame(am = c(0, 1), test = c("a", "b"))) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 41c06581b6..d04208a2b3 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -13,7 +13,7 @@ testthat::test_that("get_teal_bs_theme", { }) testthat::test_that("report_card_template function returns TealReportCard object with appropriate content and labels", { - fd <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) + fd <- teal.slice::init_filtered_data(list(iris = iris)) filter_panel_api <- teal.slice::FilterPanelAPI$new(fd) card <- shiny::isolate(report_card_template(