From daffef93729531048fb969ef3a6e1e6a6230c3d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= Date: Wed, 6 Nov 2024 14:26:15 +0100 Subject: [PATCH] Accept functions (#1393) Closes #1352 This PR enables including any data type in the `data` (`teal_data`) object. - unfilterable datasets (not data.frame nor MAE) are not included in the filter-panel, but they are preserved in the `data` - unsupported data types are displayed in the data-summary-table but they are hidden by default - if any unsupported dataset is in the data they data-summary displays "show/hide unsupported" to toggle rows containing unsupported - functions are excluded from a hash calculation and this code is not included in SRC
hide unsupported show unsupported
image image
App example ```r devtools::load_all("teal.slice") devtools::load_all("teal") options("teal.bs_theme" = bslib::bs_theme(version = "5")) data <- teal_data() |> within({ library(MultiAssayExperiment) data(miniACC, envir = environment()) iris <- iris foo <- function(x) cat("hello\n") vector <- letters }) modules <- modules( example_module( transformers = teal_transform_module(server = function(id, data) { moduleServer(id, function(input, output, session) { reactive({ data() |> within({ foo2 <- function() NULL }) }) }) }) ), example_module(datanames = "iris") ) app <- init(data = data, modules = modules) runApp(app) ```
--------- Signed-off-by: Vedha Viyash <49812166+vedhav@users.noreply.github.com> Co-authored-by: Marcin <133694481+m7pr@users.noreply.github.com> Co-authored-by: vedhav Co-authored-by: Vedha Viyash <49812166+vedhav@users.noreply.github.com> --- DESCRIPTION | 1 + R/module_data_summary.R | 196 ++++++++++-------- R/module_init_data.R | 1 - R/utils.R | 76 +++++++ man/dot-smart_rbind.Rd | 15 ++ man/module_data_summary.Rd | 43 ++-- tests/testthat/test-module_teal.R | 86 +++++++- tests/testthat/test-rcode_utils.R | 4 +- tests/testthat/test-shinytest2-data_summary.R | 39 ++-- tests/testthat/test-utils.R | 2 +- 10 files changed, 308 insertions(+), 155 deletions(-) create mode 100644 man/dot-smart_rbind.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 32392c391c..cdf23630c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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/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/utils.R b/R/utils.R index 0397774e7b..345350fe0d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -376,3 +376,79 @@ 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.") + } + ) +} + +#' 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/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-module_teal.R b/tests/testthat/test-module_teal.R index 2fa450ed60..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()) } @@ -2211,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(