diff --git a/R/init.R b/R/init.R
index a62034eaf8..005bc448f9 100644
--- a/R/init.R
+++ b/R/init.R
@@ -213,7 +213,7 @@ init <- function(data,
is_modules_ok <- check_modules_datanames(modules, ls(teal.code::get_env(data)))
if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
- lapply(is_modules_ok$string, warning, call. = FALSE)
+ warning(is_modules_ok, call. = FALSE)
}
is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data)))
diff --git a/R/module_teal.R b/R/module_teal.R
index 8624636dd2..3e913c2340 100644
--- a/R/module_teal.R
+++ b/R/module_teal.R
@@ -210,6 +210,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 899ef14028..ebf95b115f 100644
--- a/R/module_teal_data.R
+++ b/R/module_teal_data.R
@@ -222,15 +222,11 @@ srv_check_shiny_warnings <- 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..0397774e7b 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`,
@@ -340,59 +376,3 @@ strip_style <- function(string) {
useBytes = TRUE
)
}
-
-#' Convert character list to human readable html with commas and "and"
-#' @noRd
-paste_datanames_character <- function(x,
- tags = list(span = shiny::tags$span, code = shiny::tags$code),
- tagList = shiny::tagList) { # nolint: object_name.
- checkmate::assert_character(x)
- do.call(
- tagList,
- lapply(seq_along(x), function(.ix) {
- tagList(
- tags$code(x[.ix]),
- if (.ix != length(x)) {
- tags$span(ifelse(.ix == length(x) - 1, " and ", ", "))
- }
- )
- })
- )
-}
-
-#' Build datanames error string for error message
-#'
-#' tags and tagList are overwritten in arguments allowing to create strings for
-#' logging purposes
-#' @noRd
-build_datanames_error_message <- function(label = NULL,
- datanames,
- extra_datanames,
- tags = list(span = shiny::tags$span, code = shiny::tags$code),
- tagList = shiny::tagList) { # nolint: object_name.
- tags$span(
- tags$span(ifelse(length(extra_datanames) > 1, "Datasets", "Dataset")),
- paste_datanames_character(extra_datanames, tags, tagList),
- tags$span(
- paste0(
- ifelse(length(extra_datanames) > 1, "are missing", "is missing"),
- ifelse(is.null(label), ".", sprintf(" for tab '%s'.", label))
- )
- ),
- if (length(datanames) >= 1) {
- tagList(
- tags$span(ifelse(length(datanames) > 1, "Datasets", "Dataset")),
- tags$span("available in data:"),
- tagList(
- tags$span(
- paste_datanames_character(datanames, tags, tagList),
- tags$span(".", .noWS = "outside"),
- .noWS = c("outside")
- )
- )
- )
- } else {
- tags$span("No datasets are available in data.")
- }
- )
-}
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/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..2fa450ed60 100644
--- a/tests/testthat/test-module_teal.R
+++ b/tests/testthat/test-module_teal.R
@@ -551,32 +551,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", {