1 |
#' Create a `tdata` object |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("deprecated")` |
|
4 |
#' |
|
5 |
#' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames` |
|
6 |
#' (or `MultiAssayExperiment`), with attributes: |
|
7 |
#' - `code` (`reactive`) containing code used to generate the data |
|
8 |
#' - join_keys (`join_keys`) containing the relationships between the data |
|
9 |
#' - metadata (named `list`) containing any metadata associated with the data frames |
|
10 |
#' |
|
11 |
#' @name tdata |
|
12 |
#' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects, |
|
13 |
#' which optionally can be `reactive`. |
|
14 |
#' Inside this object all of these items will be made `reactive`. |
|
15 |
#' @param code (`character` or `reactive` which evaluates to a `character`) containing |
|
16 |
#' the code used to generate the data. This should be `reactive` if the code is changing |
|
17 |
#' during a reactive context (e.g. if filtering changes the code). Inside this |
|
18 |
#' object `code` will be made reactive |
|
19 |
#' @param join_keys (`teal.data::join_keys`) object containing relationships between the |
|
20 |
#' datasets. |
|
21 |
#' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame` |
|
22 |
#' Each element of these list should be atomic and length one. |
|
23 |
#' @return A `tdata` object. |
|
24 |
#' |
|
25 |
#' @seealso `as_tdata` |
|
26 |
#' |
|
27 |
#' @examples |
|
28 |
#' |
|
29 |
#' data <- new_tdata( |
|
30 |
#' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)), |
|
31 |
#' code = "iris <- iris |
|
32 |
#' mtcars <- mtcars |
|
33 |
#' dd <- data.frame(x = 1:10)", |
|
34 |
#' metadata = list(dd = list(author = "NEST"), iris = list(version = 1)) |
|
35 |
#' ) |
|
36 |
#' |
|
37 |
#' # Extract a data.frame |
|
38 |
#' isolate(data[["iris"]]()) |
|
39 |
#' |
|
40 |
#' # Get code |
|
41 |
#' isolate(get_code_tdata(data)) |
|
42 |
#' |
|
43 |
#' # Get metadata |
|
44 |
#' get_metadata(data, "iris") |
|
45 |
#' |
|
46 |
#' @export |
|
47 |
new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) { |
|
48 | 34x |
lifecycle::deprecate_soft( |
49 | 34x |
when = "0.15.0", |
50 | 34x |
what = "tdata()", |
51 | 34x |
details = paste( |
52 | 34x |
"tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n", |
53 | 34x |
"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987." |
54 |
) |
|
55 |
) |
|
56 | 34x |
checkmate::assert_list( |
57 | 34x |
data, |
58 | 34x |
any.missing = FALSE, names = "unique", |
59 | 34x |
types = c("data.frame", "reactive", "MultiAssayExperiment") |
60 |
) |
|
61 | 30x |
checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE) |
62 | 29x |
checkmate::assert_multi_class(code, c("character", "reactive")) |
63 | ||
64 | 28x |
checkmate::assert_list(metadata, names = "unique", null.ok = TRUE) |
65 | 26x |
checkmate::assert_subset(names(metadata), names(data)) |
66 | ||
67 | 25x |
if (is.reactive(code)) { |
68 | 9x |
isolate(checkmate::assert_class(code(), "character", .var.name = "code")) |
69 |
} |
|
70 | ||
71 |
# create reactive data.frames |
|
72 | 24x |
for (x in names(data)) { |
73 | 47x |
if (!is.reactive(data[[x]])) { |
74 | 31x |
data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x])) |
75 |
} |
|
76 |
} |
|
77 | ||
78 |
# set attributes |
|
79 | 24x |
attr(data, "code") <- if (is.reactive(code)) code else reactive(code) |
80 | 24x |
attr(data, "join_keys") <- join_keys |
81 | 24x |
attr(data, "metadata") <- metadata |
82 | ||
83 |
# set class |
|
84 | 24x |
class(data) <- c("tdata", class(data)) |
85 | 24x |
data |
86 |
} |
|
87 | ||
88 |
#' Function to convert a `tdata` object to an `environment` |
|
89 |
#' |
|
90 |
#' Any `reactive` expressions inside `tdata` are evaluated first. |
|
91 |
#' @param data (`tdata`) object |
|
92 |
#' @return An `environment`. |
|
93 |
#' @examples |
|
94 |
#' |
|
95 |
#' data <- new_tdata( |
|
96 |
#' data = list(iris = iris, mtcars = reactive(mtcars)), |
|
97 |
#' code = "iris <- iris |
|
98 |
#' mtcars = mtcars" |
|
99 |
#' ) |
|
100 |
#' |
|
101 |
#' my_env <- isolate(tdata2env(data)) |
|
102 |
#' |
|
103 |
#' @export |
|
104 |
tdata2env <- function(data) { |
|
105 | 2x |
checkmate::assert_class(data, "tdata") |
106 | 1x |
list2env(lapply(data, function(x) if (is.reactive(x)) x() else x)) |
107 |
} |
|
108 | ||
109 | ||
110 |
#' Wrapper for `get_code.tdata` |
|
111 |
#' |
|
112 |
#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object. |
|
113 |
#' |
|
114 |
#' @param data (`tdata`) object |
|
115 |
#' |
|
116 |
#' @return (`character`) code used in the `tdata` object. |
|
117 |
#' @export |
|
118 |
get_code_tdata <- function(data) { |
|
119 | 7x |
checkmate::assert_class(data, "tdata") |
120 | 5x |
attr(data, "code")() |
121 |
} |
|
122 | ||
123 |
#' Extract `join_keys` from `tdata` |
|
124 |
#' @param data (`tdata`) object |
|
125 |
#' @param ... Additional arguments (not used) |
|
126 |
#' @export |
|
127 |
join_keys.tdata <- function(data, ...) { |
|
128 | 2x |
attr(data, "join_keys") |
129 |
} |
|
130 | ||
131 |
#' Function to get metadata from a `tdata` object |
|
132 |
#' @param data (`tdata` - object) to extract the data from |
|
133 |
#' @param dataname (`character(1)`) the dataset name whose metadata is requested |
|
134 |
#' @return Either list of metadata or NULL if no metadata. |
|
135 |
#' @export |
|
136 |
get_metadata <- function(data, dataname) { |
|
137 | 4x |
checkmate::assert_string(dataname) |
138 | 4x |
UseMethod("get_metadata", data) |
139 |
} |
|
140 | ||
141 |
#' @rdname get_metadata |
|
142 |
#' @export |
|
143 |
get_metadata.tdata <- function(data, dataname) { |
|
144 | 4x |
metadata <- attr(data, "metadata") |
145 | 4x |
if (is.null(metadata)) { |
146 | 1x |
return(NULL) |
147 |
} |
|
148 | 3x |
metadata[[dataname]] |
149 |
} |
|
150 | ||
151 |
#' @rdname get_metadata |
|
152 |
#' @export |
|
153 |
get_metadata.default <- function(data, dataname) { |
|
154 | ! |
stop("get_metadata function not implemented for this object") |
155 |
} |
|
156 | ||
157 | ||
158 |
#' Downgrade `teal_data` objects in modules for compatibility |
|
159 |
#' |
|
160 |
#' Convert `teal_data` to `tdata` in `teal` modules. |
|
161 |
#' |
|
162 |
#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object |
|
163 |
#' to be passed to the `data` argument but instead they receive a `teal_data` object, |
|
164 |
#' which is additionally wrapped in a reactive expression in the server functions. |
|
165 |
#' In order to easily adapt such modules without a proper refactor, |
|
166 |
#' use this function to downgrade the `data` argument. |
|
167 |
#' |
|
168 |
#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression |
|
169 |
#' |
|
170 |
#' @return Object of class `tdata`. |
|
171 |
#' |
|
172 |
#' @examples |
|
173 |
#' td <- teal_data() |
|
174 |
#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars) |
|
175 |
#' td |
|
176 |
#' as_tdata(td) |
|
177 |
#' as_tdata(reactive(td)) |
|
178 |
#' |
|
179 |
#' @export |
|
180 |
#' @rdname tdata_deprecation |
|
181 |
#' |
|
182 |
as_tdata <- function(x) { |
|
183 | 8x |
if (inherits(x, "tdata")) { |
184 | 2x |
return(x) |
185 |
} |
|
186 | 6x |
if (is.reactive(x)) { |
187 | 1x |
checkmate::assert_class(isolate(x()), "teal_data") |
188 | 1x |
datanames <- isolate(teal_data_datanames(x())) |
189 | 1x |
datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE) |
190 | 1x |
code <- reactive(teal.code::get_code(x())) |
191 | 1x |
join_keys <- isolate(teal.data::join_keys(x())) |
192 | 5x |
} else if (inherits(x, "teal_data")) { |
193 | 5x |
datanames <- teal_data_datanames(x) |
194 | 5x |
datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE) |
195 | 5x |
code <- reactive(teal.code::get_code(x)) |
196 | 5x |
join_keys <- isolate(teal.data::join_keys(x)) |
197 |
} |
|
198 | ||
199 | 6x |
new_tdata(data = datasets, code = code, join_keys = join_keys) |
200 |
} |
1 |
.onLoad <- function(libname, pkgname) { |
|
2 |
# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
|
3 | ! |
teal_default_options <- list(teal.show_js_log = FALSE) |
4 | ||
5 | ! |
op <- options() |
6 | ! |
toset <- !(names(teal_default_options) %in% names(op)) |
7 | ! |
if (any(toset)) options(teal_default_options[toset]) |
8 | ||
9 | ! |
options("shiny.sanitize.errors" = FALSE) |
10 | ||
11 |
# Set up the teal logger instance |
|
12 | ! |
teal.logger::register_logger("teal") |
13 | ||
14 | ! |
invisible() |
15 |
} |
|
16 | ||
17 |
.onAttach <- function(libname, pkgname) { |
|
18 | 2x |
packageStartupMessage( |
19 | 2x |
"\nYou are using teal version ", |
20 |
# `system.file` uses the `shim` of `system.file` by `teal` |
|
21 |
# we avoid `desc` dependency here to get the version |
|
22 | 2x |
read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"] |
23 |
) |
|
24 |
} |
|
25 | ||
26 |
# This one is here because setdiff_teal_slice should not be exported from teal.slice. |
|
27 |
setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice") |
|
28 |
# This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice. |
|
29 |
coalesce_r <- getFromNamespace("coalesce_r", "teal.slice") |
|
30 |
# all *Block objects are private in teal.reporter |
|
31 |
RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint: object_name. |
|
32 | ||
33 |
# Use non-exported function(s) from teal.code |
|
34 |
# This one is here because lang2calls should not be exported from teal.code |
|
35 |
lang2calls <- getFromNamespace("lang2calls", "teal.code") |
1 |
#' @title `TealReportCard` |
|
2 |
#' @description `r lifecycle::badge("experimental")` |
|
3 |
#' Child class of [`ReportCard`] that is used for `teal` specific applications. |
|
4 |
#' In addition to the parent methods, it supports rendering `teal` specific elements such as |
|
5 |
#' the source code, the encodings panel content and the filter panel content as part of the |
|
6 |
#' meta data. |
|
7 |
#' @export |
|
8 |
#' |
|
9 |
TealReportCard <- R6::R6Class( # nolint: object_name. |
|
10 |
classname = "TealReportCard", |
|
11 |
inherit = teal.reporter::ReportCard, |
|
12 |
public = list( |
|
13 |
#' @description Appends the source code to the `content` meta data of this `TealReportCard`. |
|
14 |
#' |
|
15 |
#' @param src (`character(1)`) code as text. |
|
16 |
#' @param ... any `rmarkdown` `R` chunk parameter and its value. |
|
17 |
#' But `eval` parameter is always set to `FALSE`. |
|
18 |
#' @return Object of class `TealReportCard`, invisibly. |
|
19 |
#' @examples |
|
20 |
#' card <- TealReportCard$new()$append_src( |
|
21 |
#' "plot(iris)" |
|
22 |
#' ) |
|
23 |
#' card$get_content()[[1]]$get_content() |
|
24 |
append_src = function(src, ...) { |
|
25 | 4x |
checkmate::assert_character(src, min.len = 0, max.len = 1) |
26 | 4x |
params <- list(...) |
27 | 4x |
params$eval <- FALSE |
28 | 4x |
rblock <- RcodeBlock$new(src) |
29 | 4x |
rblock$set_params(params) |
30 | 4x |
self$append_content(rblock) |
31 | 4x |
self$append_metadata("SRC", src) |
32 | 4x |
invisible(self) |
33 |
}, |
|
34 |
#' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`. |
|
35 |
#' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses |
|
36 |
#' the default `yaml::as.yaml` to format the list. |
|
37 |
#' If the filter state list is empty, nothing is appended to the `content`. |
|
38 |
#' |
|
39 |
#' @param fs (`teal_slices`) object returned from [teal_slices()] function. |
|
40 |
#' @return `self`, invisibly. |
|
41 |
append_fs = function(fs) { |
|
42 | 5x |
checkmate::assert_class(fs, "teal_slices") |
43 | 4x |
self$append_text("Filter State", "header3") |
44 | 4x |
if (length(fs)) { |
45 | 3x |
self$append_content(TealSlicesBlock$new(fs)) |
46 |
} else { |
|
47 | 1x |
self$append_text("No filters specified.") |
48 |
} |
|
49 | 4x |
invisible(self) |
50 |
}, |
|
51 |
#' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`. |
|
52 |
#' |
|
53 |
#' @param encodings (`list`) list of encodings selections of the `teal` app. |
|
54 |
#' @return `self`, invisibly. |
|
55 |
#' @examples |
|
56 |
#' card <- TealReportCard$new()$append_encodings(list(variable1 = "X")) |
|
57 |
#' card$get_content()[[1]]$get_content() |
|
58 |
#' |
|
59 |
append_encodings = function(encodings) { |
|
60 | 4x |
checkmate::assert_list(encodings) |
61 | 4x |
self$append_text("Selected Options", "header3") |
62 | 4x |
if (requireNamespace("yaml", quietly = TRUE)) { |
63 | 4x |
self$append_text(yaml::as.yaml(encodings, handlers = list( |
64 | 4x |
POSIXct = function(x) format(x, "%Y-%m-%d"), |
65 | 4x |
POSIXlt = function(x) format(x, "%Y-%m-%d"), |
66 | 4x |
Date = function(x) format(x, "%Y-%m-%d") |
67 | 4x |
)), "verbatim") |
68 |
} else { |
|
69 | ! |
stop("yaml package is required to format the encodings list") |
70 |
} |
|
71 | 4x |
self$append_metadata("Encodings", encodings) |
72 | 4x |
invisible(self) |
73 |
} |
|
74 |
), |
|
75 |
private = list() |
|
76 |
) |
|
77 | ||
78 |
#' @title `RcodeBlock` |
|
79 |
#' @keywords internal |
|
80 |
TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter. |
|
81 |
classname = "TealSlicesBlock", |
|
82 |
inherit = teal.reporter:::TextBlock, |
|
83 |
public = list( |
|
84 |
#' @description Returns a `TealSlicesBlock` object. |
|
85 |
#' |
|
86 |
#' @details Returns a `TealSlicesBlock` object with no content and no parameters. |
|
87 |
#' |
|
88 |
#' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|
89 |
#' @param style (`character(1)`) string specifying style to apply. |
|
90 |
#' |
|
91 |
#' @return Object of class `TealSlicesBlock`, invisibly. |
|
92 |
#' |
|
93 |
initialize = function(content = teal_slices(), style = "verbatim") { |
|
94 | 9x |
self$set_content(content) |
95 | 8x |
self$set_style(style) |
96 | 8x |
invisible(self) |
97 |
}, |
|
98 | ||
99 |
#' @description Sets content of this `TealSlicesBlock`. |
|
100 |
#' Sets content as `YAML` text which represents a list generated from `teal_slices`. |
|
101 |
#' The list displays limited number of fields from `teal_slice` objects, but this list is |
|
102 |
#' sufficient to conclude which filters were applied. |
|
103 |
#' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min" |
|
104 |
#' |
|
105 |
#' |
|
106 |
#' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|
107 |
#' @return `self`, invisibly. |
|
108 |
set_content = function(content) { |
|
109 | 10x |
checkmate::assert_class(content, "teal_slices") |
110 | 9x |
if (length(content) != 0) { |
111 | 7x |
states_list <- lapply(content, function(x) { |
112 | 7x |
x_list <- shiny::isolate(as.list(x)) |
113 | 7x |
if ( |
114 | 7x |
inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) && |
115 | 7x |
length(x_list$choices) == 2 && |
116 | 7x |
length(x_list$selected) == 2 |
117 |
) { |
|
118 | ! |
x_list$range <- paste(x_list$selected, collapse = " - ") |
119 | ! |
x_list["selected"] <- NULL |
120 |
} |
|
121 | 7x |
if (!is.null(x_list$arg)) { |
122 | ! |
x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples" |
123 |
} |
|
124 | ||
125 | 7x |
x_list <- x_list[ |
126 | 7x |
c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf") |
127 |
] |
|
128 | 7x |
names(x_list) <- c( |
129 | 7x |
"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression", |
130 | 7x |
"Selected Values", "Selected range", "Include NA values", "Include Inf values" |
131 |
) |
|
132 | ||
133 | 7x |
Filter(Negate(is.null), x_list) |
134 |
}) |
|
135 | ||
136 | 7x |
if (requireNamespace("yaml", quietly = TRUE)) { |
137 | 7x |
super$set_content(yaml::as.yaml(states_list)) |
138 |
} else { |
|
139 | ! |
stop("yaml package is required to format the filter state list") |
140 |
} |
|
141 |
} |
|
142 | 9x |
private$teal_slices <- content |
143 | 9x |
invisible(self) |
144 |
}, |
|
145 |
#' @description Create the `RcodeBlock` from a list. |
|
146 |
#' @param x (named `list`) with two fields `c("text", "params")`. |
|
147 |
#' Use the `get_available_params` method to get all possible parameters. |
|
148 |
#' @return `self`, invisibly. |
|
149 |
from_list = function(x) { |
|
150 | 1x |
checkmate::assert_list(x) |
151 | 1x |
checkmate::assert_names(names(x), must.include = c("teal_slices")) |
152 | 1x |
self$set_content(x$teal_slices) |
153 | 1x |
invisible(self) |
154 |
}, |
|
155 |
#' @description Convert the `RcodeBlock` to a list. |
|
156 |
#' @return named `list` with a text and `params`. |
|
157 | ||
158 |
to_list = function() { |
|
159 | 2x |
list(teal_slices = private$teal_slices) |
160 |
} |
|
161 |
), |
|
162 |
private = list( |
|
163 |
style = "verbatim", |
|
164 |
teal_slices = NULL # teal_slices |
|
165 |
) |
|
166 |
) |
1 |
#' Generates library calls from current session info |
|
2 |
#' |
|
3 |
#' Function to create multiple library calls out of current session info to ensure reproducible code works. |
|
4 |
#' |
|
5 |
#' @return Character vector of `library(<package>)` calls. |
|
6 |
#' @keywords internal |
|
7 |
get_rcode_libraries <- function() { |
|
8 | 6x |
vapply( |
9 | 6x |
utils::sessionInfo()$otherPkgs, |
10 | 6x |
function(x) { |
11 | 36x |
paste0("library(", x$Package, ")") |
12 |
}, |
|
13 | 6x |
character(1) |
14 |
) %>% |
|
15 |
# put it into reverse order to correctly simulate executed code |
|
16 | 6x |
rev() %>% |
17 | 6x |
paste0(sep = "\n") %>% |
18 | 6x |
paste0(collapse = "") |
19 |
} |
|
20 | ||
21 |
#' @noRd |
|
22 |
#' @keywords internal |
|
23 |
get_rcode_str_install <- function() { |
|
24 | 10x |
code_string <- getOption("teal.load_nest_code") |
25 | 10x |
if (is.character(code_string)) { |
26 | 2x |
code_string |
27 |
} else { |
|
28 | 8x |
"# Add any code to install/load your NEST environment here\n" |
29 |
} |
|
30 |
} |
|
31 | ||
32 |
#' Get datasets code |
|
33 |
#' |
|
34 |
#' Retrieve complete code to create, verify, and filter a dataset. |
|
35 |
#' |
|
36 |
#' @param datanames (`character`) names of datasets to extract code from |
|
37 |
#' @param datasets (`FilteredData`) object |
|
38 |
#' @param hashes named (`list`) of hashes per dataset |
|
39 |
#' |
|
40 |
#' @return Character string concatenated from the following elements: |
|
41 |
#' - data pre-processing code (from `data` argument in `init`) |
|
42 |
#' - hash check of loaded objects |
|
43 |
#' - filter code (if any) |
|
44 |
#' |
|
45 |
#' @keywords internal |
|
46 |
get_datasets_code <- function(datanames, datasets, hashes) { |
|
47 |
# preprocessing code |
|
48 | 4x |
str_prepro <- attr(datasets, "preprocessing_code") |
49 | 4x |
if (length(str_prepro) == 0) { |
50 | ! |
str_prepro <- "message('Preprocessing is empty')" |
51 |
} else { |
|
52 | 4x |
str_prepro <- paste(str_prepro, collapse = "\n") |
53 |
} |
|
54 | ||
55 |
# hash checks |
|
56 | 4x |
str_hash <- vapply(datanames, function(dataname) { |
57 | 6x |
sprintf( |
58 | 6x |
"stopifnot(%s == %s)", |
59 | 6x |
deparse1(bquote(rlang::hash(.(as.name(dataname))))), |
60 | 6x |
deparse1(hashes[[dataname]]) |
61 |
) |
|
62 | 4x |
}, character(1)) |
63 | 4x |
str_hash <- paste(str_hash, collapse = "\n") |
64 | ||
65 |
# filter expressions |
|
66 | 4x |
str_filter <- teal.slice::get_filter_expr(datasets, datanames) |
67 | 4x |
if (str_filter == "") { |
68 | 2x |
str_filter <- character(0) |
69 |
} |
|
70 | ||
71 |
# concatenate all code |
|
72 | 4x |
str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n") |
73 | 4x |
sprintf("%s\n", str_code) |
74 |
} |
1 |
#' Create `teal_module` and `teal_modules` objects |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Create a nested tab structure to embed modules in a `teal` application. |
|
7 |
#' |
|
8 |
#' @details |
|
9 |
#' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application. |
|
10 |
#' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel. |
|
11 |
#' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object, |
|
12 |
#' which results in a nested structure corresponding to the nested tabs in the final application. |
|
13 |
#' |
|
14 |
#' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument, |
|
15 |
#' otherwise it will be captured by `...`. |
|
16 |
#' |
|
17 |
#' The labels `"global_filters"` and `"Report previewer"` are reserved |
|
18 |
#' because they are used by the `mapping` argument of [teal_slices()] |
|
19 |
#' and the report previewer module [reporter_previewer_module()], respectively. |
|
20 |
#' |
|
21 |
#' @param label (`character(1)`) Label shown in the navigation item for the module or module group. |
|
22 |
#' For `modules()` defaults to `"root"`. See `Details`. |
|
23 |
#' @param server (`function`) `shiny` module with following arguments: |
|
24 |
#' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]). |
|
25 |
#' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()] |
|
26 |
#' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use |
|
27 |
#' [shiny::moduleServer()] instead which doesn't require these arguments. |
|
28 |
#' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of |
|
29 |
#' reactive (filtered) data specified in the `filters` argument) as the value of this argument. |
|
30 |
#' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the |
|
31 |
#' value of this argument. (See [`teal.slice::FilteredData`]). |
|
32 |
#' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value |
|
33 |
#' of this argument. (See [`teal.reporter::Reporter`]). |
|
34 |
#' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object |
|
35 |
#' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]). |
|
36 |
#' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument |
|
37 |
#' or to the `...`. |
|
38 |
#' @param ui (`function`) `shiny` UI module function with following arguments: |
|
39 |
#' - `id` - `teal` will set proper `shiny` namespace for this module. |
|
40 |
#' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument |
|
41 |
#' or to the `...`. |
|
42 |
#' @param filters (`character`) Deprecated. Use `datanames` instead. |
|
43 |
#' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The |
|
44 |
#' filter panel will automatically update the shown filters to include only |
|
45 |
#' filters in the listed datasets. `NULL` will hide the filter panel, |
|
46 |
#' and the keyword `"all"` will show filters of all datasets. `datanames` also determines |
|
47 |
#' a subset of datasets which are appended to the `data` argument in server function. |
|
48 |
#' @param server_args (named `list`) with additional arguments passed on to the server function. |
|
49 |
#' @param ui_args (named `list`) with additional arguments passed on to the UI function. |
|
50 |
#' @param x (`teal_module` or `teal_modules`) Object to format/print. |
|
51 |
#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more. |
|
52 |
#' @param ... |
|
53 |
#' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab. |
|
54 |
#' - For `format()` and `print()`: Arguments passed to other methods. |
|
55 |
#' |
|
56 |
#' @return |
|
57 |
#' `module()` returns an object of class `teal_module`. |
|
58 |
#' |
|
59 |
#' `modules()` returns a `teal_modules` object which contains following fields: |
|
60 |
#' - `label`: taken from the `label` argument. |
|
61 |
#' - `children`: a list containing objects passed in `...`. List elements are named after |
|
62 |
#' their `label` attribute converted to a valid `shiny` id. |
|
63 |
#' |
|
64 |
#' @name teal_modules |
|
65 |
#' @aliases teal_module |
|
66 |
#' |
|
67 |
#' @examples |
|
68 |
#' library(shiny) |
|
69 |
#' |
|
70 |
#' module_1 <- module( |
|
71 |
#' label = "a module", |
|
72 |
#' server = function(id, data) { |
|
73 |
#' moduleServer( |
|
74 |
#' id, |
|
75 |
#' module = function(input, output, session) { |
|
76 |
#' output$data <- renderDataTable(data()[["iris"]]) |
|
77 |
#' } |
|
78 |
#' ) |
|
79 |
#' }, |
|
80 |
#' ui = function(id) { |
|
81 |
#' ns <- NS(id) |
|
82 |
#' tagList(dataTableOutput(ns("data"))) |
|
83 |
#' }, |
|
84 |
#' datanames = "all" |
|
85 |
#' ) |
|
86 |
#' |
|
87 |
#' module_2 <- module( |
|
88 |
#' label = "another module", |
|
89 |
#' server = function(id) { |
|
90 |
#' moduleServer( |
|
91 |
#' id, |
|
92 |
#' module = function(input, output, session) { |
|
93 |
#' output$text <- renderText("Another Module") |
|
94 |
#' } |
|
95 |
#' ) |
|
96 |
#' }, |
|
97 |
#' ui = function(id) { |
|
98 |
#' ns <- NS(id) |
|
99 |
#' tagList(textOutput(ns("text"))) |
|
100 |
#' }, |
|
101 |
#' datanames = NULL |
|
102 |
#' ) |
|
103 |
#' |
|
104 |
#' modules <- modules( |
|
105 |
#' label = "modules", |
|
106 |
#' modules( |
|
107 |
#' label = "nested modules", |
|
108 |
#' module_1 |
|
109 |
#' ), |
|
110 |
#' module_2 |
|
111 |
#' ) |
|
112 |
#' |
|
113 |
#' app <- init( |
|
114 |
#' data = teal_data(iris = iris), |
|
115 |
#' modules = modules |
|
116 |
#' ) |
|
117 |
#' |
|
118 |
#' if (interactive()) { |
|
119 |
#' shinyApp(app$ui, app$server) |
|
120 |
#' } |
|
121 | ||
122 |
#' @rdname teal_modules |
|
123 |
#' @export |
|
124 |
#' |
|
125 |
module <- function(label = "module", |
|
126 |
server = function(id, ...) { |
|
127 | ! |
moduleServer(id, function(input, output, session) {}) |
128 |
}, |
|
129 |
ui = function(id, ...) { |
|
130 | ! |
tags$p(paste0("This module has no UI (id: ", id, " )")) |
131 |
}, |
|
132 |
filters, |
|
133 |
datanames = "all", |
|
134 |
server_args = NULL, |
|
135 |
ui_args = NULL) { |
|
136 |
# argument checking (independent) |
|
137 |
## `label` |
|
138 | 147x |
checkmate::assert_string(label) |
139 | 144x |
if (label == "global_filters") { |
140 | 1x |
stop( |
141 | 1x |
sprintf("module(label = \"%s\", ...\n ", label), |
142 | 1x |
"Label 'global_filters' is reserved in teal. Please change to something else.", |
143 | 1x |
call. = FALSE |
144 |
) |
|
145 |
} |
|
146 | 143x |
if (label == "Report previewer") { |
147 | ! |
stop( |
148 | ! |
sprintf("module(label = \"%s\", ...\n ", label), |
149 | ! |
"Label 'Report previewer' is reserved in teal. Please change to something else.", |
150 | ! |
call. = FALSE |
151 |
) |
|
152 |
} |
|
153 | ||
154 |
## server |
|
155 | 143x |
checkmate::assert_function(server) |
156 | 143x |
server_formals <- names(formals(server)) |
157 | 143x |
if (!( |
158 | 143x |
"id" %in% server_formals || |
159 | 143x |
all(c("input", "output", "session") %in% server_formals) |
160 |
)) { |
|
161 | 2x |
stop( |
162 | 2x |
"\nmodule() `server` argument requires a function with following arguments:", |
163 | 2x |
"\n - id - `teal` will set proper `shiny` namespace for this module.", |
164 | 2x |
"\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.", |
165 | 2x |
"\n\nFollowing arguments can be used optionaly:", |
166 | 2x |
"\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument", |
167 | 2x |
"\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
168 | 2x |
"\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`", |
169 | 2x |
"\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).", |
170 | 2x |
"\n - `...` server_args elements will be passed to the module named argument or to the `...`" |
171 |
) |
|
172 |
} |
|
173 | 141x |
if ("datasets" %in% server_formals) { |
174 | 2x |
warning( |
175 | 2x |
sprintf("Called from module(label = \"%s\", ...)\n ", label), |
176 | 2x |
"`datasets` argument in the server is deprecated and will be removed in the next release. ", |
177 | 2x |
"Please use `data` instead.", |
178 | 2x |
call. = FALSE |
179 |
) |
|
180 |
} |
|
181 | ||
182 | ||
183 |
## UI |
|
184 | 141x |
checkmate::assert_function(ui) |
185 | 141x |
ui_formals <- names(formals(ui)) |
186 | 141x |
if (!"id" %in% ui_formals) { |
187 | 1x |
stop( |
188 | 1x |
"\nmodule() `ui` argument requires a function with following arguments:", |
189 | 1x |
"\n - id - `teal` will set proper `shiny` namespace for this module.", |
190 | 1x |
"\n\nFollowing arguments can be used optionally:", |
191 | 1x |
"\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`" |
192 |
) |
|
193 |
} |
|
194 | 140x |
if (any(c("data", "datasets") %in% ui_formals)) { |
195 | 2x |
stop( |
196 | 2x |
sprintf("Called from module(label = \"%s\", ...)\n ", label), |
197 | 2x |
"UI with `data` or `datasets` argument is no longer accepted.\n ", |
198 | 2x |
"If some UI inputs depend on data, please move the logic to your server instead.\n ", |
199 | 2x |
"Possible solutions are renderUI() or updateXyzInput() functions." |
200 |
) |
|
201 |
} |
|
202 | ||
203 | ||
204 |
## `filters` |
|
205 | 138x |
if (!missing(filters)) { |
206 | ! |
datanames <- filters |
207 | ! |
msg <- |
208 | ! |
"The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead." |
209 | ! |
logger::log_warn(msg) |
210 | ! |
warning(msg) |
211 |
} |
|
212 | ||
213 |
## `datanames` (also including deprecated `filters`) |
|
214 |
# please note a race condition between datanames set when filters is not missing and data arg in server function |
|
215 | 138x |
if (!is.element("data", server_formals) && !is.null(datanames)) { |
216 | 50x |
message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label)) |
217 | 50x |
datanames <- NULL |
218 |
} |
|
219 | 138x |
checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
220 | ||
221 |
## `server_args` |
|
222 | 137x |
checkmate::assert_list(server_args, null.ok = TRUE, names = "named") |
223 | 135x |
srv_extra_args <- setdiff(names(server_args), server_formals) |
224 | 135x |
if (length(srv_extra_args) > 0 && !"..." %in% server_formals) { |
225 | 1x |
stop( |
226 | 1x |
"\nFollowing `server_args` elements have no equivalent in the formals of the server:\n", |
227 | 1x |
paste(paste(" -", srv_extra_args), collapse = "\n"), |
228 | 1x |
"\n\nUpdate the server arguments by including above or add `...`" |
229 |
) |
|
230 |
} |
|
231 | ||
232 |
## `ui_args` |
|
233 | 134x |
checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") |
234 | 132x |
ui_extra_args <- setdiff(names(ui_args), ui_formals) |
235 | 132x |
if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) { |
236 | 1x |
stop( |
237 | 1x |
"\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n", |
238 | 1x |
paste(paste(" -", ui_extra_args), collapse = "\n"), |
239 | 1x |
"\n\nUpdate the UI arguments by including above or add `...`" |
240 |
) |
|
241 |
} |
|
242 | ||
243 | 131x |
structure( |
244 | 131x |
list( |
245 | 131x |
label = label, |
246 | 131x |
server = server, ui = ui, datanames = unique(datanames), |
247 | 131x |
server_args = server_args, ui_args = ui_args |
248 |
), |
|
249 | 131x |
class = "teal_module" |
250 |
) |
|
251 |
} |
|
252 | ||
253 |
#' @rdname teal_modules |
|
254 |
#' @export |
|
255 |
#' |
|
256 |
modules <- function(..., label = "root") { |
|
257 | 102x |
checkmate::assert_string(label) |
258 | 100x |
submodules <- list(...) |
259 | 100x |
if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) { |
260 | 2x |
stop( |
261 | 2x |
"The only character argument to modules() must be 'label' and it must be named, ", |
262 | 2x |
"change modules('lab', ...) to modules(label = 'lab', ...)" |
263 |
) |
|
264 |
} |
|
265 | ||
266 | 98x |
checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules")) |
267 |
# name them so we can more easily access the children |
|
268 |
# beware however that the label of the submodules should not be changed as it must be kept synced |
|
269 | 95x |
labels <- vapply(submodules, function(submodule) submodule$label, character(1)) |
270 | 95x |
names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_") |
271 | 95x |
structure( |
272 | 95x |
list( |
273 | 95x |
label = label, |
274 | 95x |
children = submodules |
275 |
), |
|
276 | 95x |
class = "teal_modules" |
277 |
) |
|
278 |
} |
|
279 | ||
280 |
# printing methods ---- |
|
281 | ||
282 |
#' @rdname teal_modules |
|
283 |
#' @export |
|
284 |
format.teal_module <- function(x, indent = 0, ...) { |
|
285 | 3x |
paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "") |
286 |
} |
|
287 | ||
288 | ||
289 |
#' @rdname teal_modules |
|
290 |
#' @export |
|
291 |
print.teal_module <- function(x, ...) { |
|
292 | ! |
cat(format(x, ...)) |
293 | ! |
invisible(x) |
294 |
} |
|
295 | ||
296 | ||
297 |
#' @rdname teal_modules |
|
298 |
#' @export |
|
299 |
format.teal_modules <- function(x, indent = 0, ...) { |
|
300 | 1x |
paste( |
301 | 1x |
c( |
302 | 1x |
paste0(rep(" ", indent), "+ ", x$label, "\n"), |
303 | 1x |
unlist(lapply(x$children, format, indent = indent + 1, ...)) |
304 |
), |
|
305 | 1x |
collapse = "" |
306 |
) |
|
307 |
} |
|
308 | ||
309 | ||
310 |
#' @rdname teal_modules |
|
311 |
#' @export |
|
312 |
print.teal_modules <- print.teal_module |
|
313 | ||
314 | ||
315 |
# utilities ---- |
|
316 |
## subset or modify modules ---- |
|
317 | ||
318 |
#' Append a `teal_module` to `children` of a `teal_modules` object |
|
319 |
#' @keywords internal |
|
320 |
#' @param modules (`teal_modules`) |
|
321 |
#' @param module (`teal_module`) object to be appended onto the children of `modules` |
|
322 |
#' @return A `teal_modules` object with `module` appended. |
|
323 |
append_module <- function(modules, module) { |
|
324 | 8x |
checkmate::assert_class(modules, "teal_modules") |
325 | 6x |
checkmate::assert_class(module, "teal_module") |
326 | 4x |
modules$children <- c(modules$children, list(module)) |
327 | 4x |
labels <- vapply(modules$children, function(submodule) submodule$label, character(1)) |
328 | 4x |
names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_") |
329 | 4x |
modules |
330 |
} |
|
331 | ||
332 |
#' Extract/Remove module(s) of specific class |
|
333 |
#' |
|
334 |
#' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`. |
|
335 |
#' |
|
336 |
#' @param modules (`teal_modules`) |
|
337 |
#' @param class The class name of `teal_module` to be extracted or dropped. |
|
338 |
#' @keywords internal |
|
339 |
#' @return |
|
340 |
#' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`. |
|
341 |
#' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`. |
|
342 |
#' @rdname module_management |
|
343 |
extract_module <- function(modules, class) { |
|
344 | 20x |
if (inherits(modules, class)) { |
345 | ! |
modules |
346 | 20x |
} else if (inherits(modules, "teal_module")) { |
347 | 11x |
NULL |
348 | 9x |
} else if (inherits(modules, "teal_modules")) { |
349 | 9x |
Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class)) |
350 |
} |
|
351 |
} |
|
352 | ||
353 |
#' @keywords internal |
|
354 |
#' @return `teal_modules` |
|
355 |
#' @rdname module_management |
|
356 |
drop_module <- function(modules, class) { |
|
357 | ! |
if (inherits(modules, class)) { |
358 | ! |
NULL |
359 | ! |
} else if (inherits(modules, "teal_module")) { |
360 | ! |
modules |
361 | ! |
} else if (inherits(modules, "teal_modules")) { |
362 | ! |
do.call( |
363 | ! |
"modules", |
364 | ! |
c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label) |
365 |
) |
|
366 |
} |
|
367 |
} |
|
368 | ||
369 |
## read modules ---- |
|
370 | ||
371 |
#' Does the object make use of the `arg` |
|
372 |
#' |
|
373 |
#' @param modules (`teal_module` or `teal_modules`) object |
|
374 |
#' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules. |
|
375 |
#' @return `logical` whether the object makes use of `arg`. |
|
376 |
#' @rdname is_arg_used |
|
377 |
#' @keywords internal |
|
378 |
is_arg_used <- function(modules, arg) { |
|
379 | 286x |
checkmate::assert_string(arg) |
380 | 283x |
if (inherits(modules, "teal_modules")) { |
381 | 29x |
any(unlist(lapply(modules$children, is_arg_used, arg))) |
382 | 254x |
} else if (inherits(modules, "teal_module")) { |
383 | 43x |
is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg) |
384 | 211x |
} else if (is.function(modules)) { |
385 | 209x |
isTRUE(arg %in% names(formals(modules))) |
386 |
} else { |
|
387 | 2x |
stop("is_arg_used function not implemented for this object") |
388 |
} |
|
389 |
} |
|
390 | ||
391 | ||
392 |
#' Get module depth |
|
393 |
#' |
|
394 |
#' Depth starts at 0, so a single `teal.module` has depth 0. |
|
395 |
#' Nesting it increases overall depth by 1. |
|
396 |
#' |
|
397 |
#' @inheritParams init |
|
398 |
#' @param depth optional, integer determining current depth level |
|
399 |
#' |
|
400 |
#' @return Depth level for given module. |
|
401 |
#' @keywords internal |
|
402 |
modules_depth <- function(modules, depth = 0L) { |
|
403 | 12x |
checkmate::assert_multi_class(modules, c("teal_module", "teal_modules")) |
404 | 12x |
checkmate::assert_int(depth, lower = 0) |
405 | 11x |
if (inherits(modules, "teal_modules")) { |
406 | 4x |
max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L)) |
407 |
} else { |
|
408 | 7x |
depth |
409 |
} |
|
410 |
} |
|
411 | ||
412 |
#' Retrieve labels from `teal_modules` |
|
413 |
#' |
|
414 |
#' @param modules (`teal_modules`) |
|
415 |
#' @return A `list` containing the labels of the modules. If the modules are nested, |
|
416 |
#' the function returns a nested `list` of labels. |
|
417 |
#' @keywords internal |
|
418 |
module_labels <- function(modules) { |
|
419 | ! |
if (inherits(modules, "teal_modules")) { |
420 | ! |
lapply(modules$children, module_labels) |
421 |
} else { |
|
422 | ! |
modules$label |
423 |
} |
|
424 |
} |
1 |
#' Manage multiple `FilteredData` objects |
|
2 |
#' |
|
3 |
#' Oversee filter states across the entire application. |
|
4 |
#' |
|
5 |
#' This module observes changes in the filters of each `FilteredData` object |
|
6 |
#' and keeps track of all filters used. A mapping of filters to modules |
|
7 |
#' is kept in the `mapping_matrix` object (which is actually a `data.frame`) |
|
8 |
#' that tracks which filters (rows) are active in which modules (columns). |
|
9 |
#' |
|
10 |
#' @name module_filter_manager |
|
11 |
#' |
|
12 |
#' @param id (`character(1)`) |
|
13 |
#' `shiny` module id. |
|
14 |
#' @param filtered_data_list (named `list`) |
|
15 |
#' A list, possibly nested, of `FilteredData` objects. |
|
16 |
#' Each `FilteredData` will be served to one module in the `teal` application. |
|
17 |
#' The structure of the list must reflect the nesting of modules in tabs |
|
18 |
#' and the names of the list must match the labels of their respective modules. |
|
19 |
#' @inheritParams init |
|
20 |
#' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`. |
|
21 |
#' @keywords internal |
|
22 |
#' |
|
23 |
NULL |
|
24 | ||
25 |
#' Filter manager modal |
|
26 |
#' |
|
27 |
#' Opens a modal containing the filter manager UI. |
|
28 |
#' |
|
29 |
#' @name module_filter_manager_modal |
|
30 |
#' @inheritParams module_filter_manager |
|
31 |
#' @keywords internal |
|
32 |
#' |
|
33 |
NULL |
|
34 | ||
35 |
#' @rdname module_filter_manager_modal |
|
36 |
filter_manager_modal_ui <- function(id) { |
|
37 | ! |
ns <- NS(id) |
38 | ! |
tags$button( |
39 | ! |
id = ns("show"), |
40 | ! |
class = "btn action-button filter_manager_button", |
41 | ! |
title = "Show filters manager modal", |
42 | ! |
icon("gear") |
43 |
) |
|
44 |
} |
|
45 | ||
46 |
#' @rdname module_filter_manager_modal |
|
47 |
filter_manager_modal_srv <- function(id, filtered_data_list, filter) { |
|
48 | 3x |
moduleServer(id, function(input, output, session) { |
49 | 3x |
observeEvent(input$show, { |
50 | ! |
logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.") |
51 | ! |
showModal( |
52 | ! |
modalDialog( |
53 | ! |
filter_manager_ui(session$ns("filter_manager")), |
54 | ! |
size = "l", |
55 | ! |
footer = NULL, |
56 | ! |
easyClose = TRUE |
57 |
) |
|
58 |
) |
|
59 |
}) |
|
60 | ||
61 | 3x |
filter_manager_srv("filter_manager", filtered_data_list, filter) |
62 |
}) |
|
63 |
} |
|
64 | ||
65 |
#' @rdname module_filter_manager |
|
66 |
filter_manager_ui <- function(id) { |
|
67 | ! |
ns <- NS(id) |
68 | ! |
div( |
69 | ! |
class = "filter_manager_content", |
70 | ! |
tableOutput(ns("slices_table")), |
71 | ! |
snapshot_manager_ui(ns("snapshot_manager")) |
72 |
) |
|
73 |
} |
|
74 | ||
75 |
#' @rdname module_filter_manager |
|
76 |
filter_manager_srv <- function(id, filtered_data_list, filter) { |
|
77 | 5x |
moduleServer(id, function(input, output, session) { |
78 | 5x |
logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.") |
79 | ||
80 | 5x |
is_module_specific <- isTRUE(attr(filter, "module_specific")) |
81 | ||
82 |
# Create a global list of slices. |
|
83 |
# Contains all available teal_slice objects available to all modules. |
|
84 |
# Passed whole to instances of FilteredData used for individual modules. |
|
85 |
# Down there a subset that pertains to the data sets used in that module is applied and displayed. |
|
86 | 5x |
slices_global <- reactiveVal(filter) |
87 | ||
88 | 5x |
filtered_data_list <- |
89 | 5x |
if (!is_module_specific) { |
90 |
# Retrieve the first FilteredData from potentially nested list. |
|
91 |
# List of length one is named "global_filters" because that name is forbidden for a module label. |
|
92 | 4x |
list(global_filters = unlist(filtered_data_list)[[1]]) |
93 |
} else { |
|
94 |
# Flatten potentially nested list of FilteredData objects while maintaining useful names. |
|
95 |
# Simply using `unlist` would result in concatenated names. |
|
96 | 1x |
flatten_nested <- function(x, name = NULL) { |
97 | 5x |
if (inherits(x, "FilteredData")) { |
98 | 3x |
setNames(list(x), name) |
99 |
} else { |
|
100 | 2x |
unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name))) |
101 |
} |
|
102 |
} |
|
103 | 1x |
flatten_nested(filtered_data_list) |
104 |
} |
|
105 | ||
106 |
# Create mapping of filters to modules in matrix form (presented as data.frame). |
|
107 |
# Modules get NAs for filters that cannot be set for them. |
|
108 | 5x |
mapping_matrix <- reactive({ |
109 | 5x |
state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id") |
110 | 5x |
mapping_smooth <- lapply(filtered_data_list, function(x) { |
111 | 7x |
state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id") |
112 | 7x |
state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id") |
113 | 7x |
states_active <- state_ids_global %in% state_ids_local |
114 | 7x |
ifelse(state_ids_global %in% state_ids_allowed, states_active, NA) |
115 |
}) |
|
116 | ||
117 | 5x |
as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE) |
118 |
}) |
|
119 | ||
120 | 5x |
output$slices_table <- renderTable( |
121 | 5x |
expr = { |
122 |
# Display logical values as UTF characters. |
|
123 | 2x |
mm <- mapping_matrix() |
124 | 2x |
mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060)) |
125 | 2x |
mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x)) |
126 | 2x |
if (!is_module_specific) colnames(mm) <- "Global Filters" |
127 | ||
128 |
# Display placeholder if no filters defined. |
|
129 | 2x |
if (nrow(mm) == 0L) { |
130 | 2x |
mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE) |
131 | 2x |
rownames(mm) <- "" |
132 |
} |
|
133 | ||
134 |
# Report Previewer will not be displayed. |
|
135 | 2x |
mm[names(mm) != "Report previewer"] |
136 |
}, |
|
137 | 5x |
align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""), |
138 | 5x |
rownames = TRUE |
139 |
) |
|
140 | ||
141 |
# Create list of module calls. |
|
142 | 5x |
modules_out <- lapply(names(filtered_data_list), function(module_name) { |
143 | 7x |
filter_manager_module_srv( |
144 | 7x |
id = module_name, |
145 | 7x |
module_fd = filtered_data_list[[module_name]], |
146 | 7x |
slices_global = slices_global |
147 |
) |
|
148 |
}) |
|
149 | ||
150 |
# Call snapshot manager. |
|
151 | 5x |
snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list) |
152 | ||
153 | 5x |
modules_out # returned for testing purpose |
154 |
}) |
|
155 |
} |
|
156 | ||
157 |
#' Module specific filter manager |
|
158 |
#' |
|
159 |
#' Tracks filter states in a single module. |
|
160 |
#' |
|
161 |
#' This module tracks the state of a single `FilteredData` object and global `teal_slices` |
|
162 |
#' and updates both objects as necessary. Filter states added in different modules |
|
163 |
#' Filter states added any individual module are added to global `teal_slices` |
|
164 |
#' and from there become available in other modules |
|
165 |
#' by setting `private$available_teal_slices` in each `FilteredData`. |
|
166 |
#' |
|
167 |
#' @param id (`character(1)`) |
|
168 |
#' `shiny` module id. |
|
169 |
#' @param module_fd (`FilteredData`) |
|
170 |
#' Object containing the data to be filtered in a single `teal` module. |
|
171 |
#' @param slices_global (`reactiveVal`) |
|
172 |
#' stores `teal_slices` with all available filters; allows the following actions: |
|
173 |
#' - to disable/enable a specific filter in a module |
|
174 |
#' - to restore saved filter settings |
|
175 |
#' - to save current filter panel settings |
|
176 |
#' @return A `reactive` expression containing the slices active in this module. |
|
177 |
#' @keywords internal |
|
178 |
#' |
|
179 |
filter_manager_module_srv <- function(id, module_fd, slices_global) { |
|
180 | 7x |
moduleServer(id, function(input, output, session) { |
181 |
# Only operate on slices that refer to data sets present in this module. |
|
182 | 7x |
module_fd$set_available_teal_slices(reactive(slices_global())) |
183 | ||
184 |
# Track filter state of this module. |
|
185 | 7x |
slices_module <- reactive(module_fd$get_filter_state()) |
186 | ||
187 |
# Reactive values for comparing states. |
|
188 | 7x |
previous_slices <- reactiveVal(isolate(slices_module())) |
189 | 7x |
slices_added <- reactiveVal(NULL) |
190 | ||
191 |
# Observe changes in module filter state and trigger appropriate actions. |
|
192 | 7x |
observeEvent(slices_module(), ignoreNULL = FALSE, { |
193 | 2x |
logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.") |
194 | 2x |
added <- setdiff_teal_slices(slices_module(), slices_global()) |
195 | ! |
if (length(added)) slices_added(added) |
196 | 2x |
previous_slices(slices_module()) |
197 |
}) |
|
198 | ||
199 | 7x |
observeEvent(slices_added(), ignoreNULL = TRUE, { |
200 | ! |
logger::log_trace("filter_manager_srv@2 added filter in module: { id }.") |
201 |
# In case the new state has the same id as an existing state, add a suffix to it. |
|
202 | ! |
global_ids <- vapply(slices_global(), `[[`, character(1L), "id") |
203 | ! |
lapply( |
204 | ! |
slices_added(), |
205 | ! |
function(slice) { |
206 | ! |
if (slice$id %in% global_ids) { |
207 | ! |
slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1) |
208 |
} |
|
209 |
} |
|
210 |
) |
|
211 | ! |
slices_global_new <- c(slices_global(), slices_added()) |
212 | ! |
slices_global(slices_global_new) |
213 | ! |
slices_added(NULL) |
214 |
}) |
|
215 | ||
216 | 7x |
slices_module # returned for testing purpose |
217 |
}) |
|
218 |
} |
1 |
#' Filter settings for `teal` applications |
|
2 |
#' |
|
3 |
#' Specify initial filter states and filtering settings for a `teal` app. |
|
4 |
#' |
|
5 |
#' Produces a `teal_slices` object. |
|
6 |
#' The `teal_slice` components will specify filter states that will be active when the app starts. |
|
7 |
#' Attributes (created with the named arguments) will configure the way the app applies filters. |
|
8 |
#' See argument descriptions for details. |
|
9 |
#' |
|
10 |
#' @inheritParams teal.slice::teal_slices |
|
11 |
#' |
|
12 |
#' @param module_specific optional (`logical(1)`) |
|
13 |
#' - `FALSE` (default) when one filter panel applied to all modules. |
|
14 |
#' All filters will be shared by all modules. |
|
15 |
#' - `TRUE` when filter panel module-specific. |
|
16 |
#' Modules can have different set of filters specified - see `mapping` argument. |
|
17 |
#' @param mapping `r lifecycle::badge("experimental")` |
|
18 |
#' _This is a new feature. Do kindly share your opinions on |
|
19 |
#' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._ |
|
20 |
#' |
|
21 |
#' (named `list`) specifies which filters will be active in which modules on app start. |
|
22 |
#' Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]). |
|
23 |
#' Names of the list should correspond to `teal_module` `label` set in [module()] function. |
|
24 |
#' - `id`s listed under `"global_filters` will be active in all modules. |
|
25 |
#' - If missing, all filters will be applied to all modules. |
|
26 |
#' - If empty list, all filters will be available to all modules but will start inactive. |
|
27 |
#' - If `module_specific` is `FALSE`, only `global_filters` will be active on start. |
|
28 |
#' @param app_id (`character(1)`) |
|
29 |
#' For internal use only, do not set manually. |
|
30 |
#' Added by `init` so that a `teal_slices` can be matched to the app in which it was used. |
|
31 |
#' Used for verifying snapshots uploaded from file. See `snapshot`. |
|
32 |
#' |
|
33 |
#' @param x (`list`) of lists to convert to `teal_slices` |
|
34 |
#' |
|
35 |
#' @return |
|
36 |
#' A `teal_slices` object. |
|
37 |
#' |
|
38 |
#' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()] |
|
39 |
#' |
|
40 |
#' @examples |
|
41 |
#' filter <- teal_slices( |
|
42 |
#' teal_slice(dataname = "iris", varname = "Species", id = "species"), |
|
43 |
#' teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), |
|
44 |
#' teal_slice( |
|
45 |
#' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" |
|
46 |
#' ), |
|
47 |
#' teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), |
|
48 |
#' mapping = list( |
|
49 |
#' module1 = c("species", "sepal_length"), |
|
50 |
#' module2 = c("mtcars_mpg"), |
|
51 |
#' global_filters = "long_petals" |
|
52 |
#' ) |
|
53 |
#' ) |
|
54 |
#' |
|
55 |
#' app <- init( |
|
56 |
#' data = teal_data(iris = iris, mtcars = mtcars), |
|
57 |
#' modules = list( |
|
58 |
#' module("module1"), |
|
59 |
#' module("module2") |
|
60 |
#' ), |
|
61 |
#' filter = filter |
|
62 |
#' ) |
|
63 |
#' |
|
64 |
#' if (interactive()) { |
|
65 |
#' shinyApp(app$ui, app$server) |
|
66 |
#' } |
|
67 |
#' |
|
68 |
#' @export |
|
69 |
teal_slices <- function(..., |
|
70 |
exclude_varnames = NULL, |
|
71 |
include_varnames = NULL, |
|
72 |
count_type = NULL, |
|
73 |
allow_add = TRUE, |
|
74 |
module_specific = FALSE, |
|
75 |
mapping, |
|
76 |
app_id = NULL) { |
|
77 | 79x |
shiny::isolate({ |
78 | 79x |
checkmate::assert_flag(allow_add) |
79 | 79x |
checkmate::assert_flag(module_specific) |
80 | 33x |
if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named") |
81 | 76x |
checkmate::assert_string(app_id, null.ok = TRUE) |
82 | ||
83 | 76x |
slices <- list(...) |
84 | 76x |
all_slice_id <- vapply(slices, `[[`, character(1L), "id") |
85 | ||
86 | 76x |
if (missing(mapping)) { |
87 | 46x |
mapping <- list(global_filters = all_slice_id) |
88 |
} |
|
89 | 76x |
if (!module_specific) { |
90 | 71x |
mapping[setdiff(names(mapping), "global_filters")] <- NULL |
91 |
} |
|
92 | ||
93 | 76x |
failed_slice_id <- setdiff(unlist(mapping), all_slice_id) |
94 | 76x |
if (length(failed_slice_id)) { |
95 | 1x |
stop(sprintf( |
96 | 1x |
"Filters in mapping don't match any available filter.\n %s not in %s", |
97 | 1x |
toString(failed_slice_id), |
98 | 1x |
toString(all_slice_id) |
99 |
)) |
|
100 |
} |
|
101 | ||
102 | 75x |
tss <- teal.slice::teal_slices( |
103 |
..., |
|
104 | 75x |
exclude_varnames = exclude_varnames, |
105 | 75x |
include_varnames = include_varnames, |
106 | 75x |
count_type = count_type, |
107 | 75x |
allow_add = allow_add |
108 |
) |
|
109 | 75x |
attr(tss, "mapping") <- mapping |
110 | 75x |
attr(tss, "module_specific") <- module_specific |
111 | 75x |
attr(tss, "app_id") <- app_id |
112 | 75x |
class(tss) <- c("modules_teal_slices", class(tss)) |
113 | 75x |
tss |
114 |
}) |
|
115 |
} |
|
116 | ||
117 | ||
118 |
#' @rdname teal_slices |
|
119 |
#' @export |
|
120 |
#' @keywords internal |
|
121 |
#' |
|
122 |
as.teal_slices <- function(x) { # nolint: object_name. |
|
123 | 10x |
checkmate::assert_list(x) |
124 | 10x |
lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
125 | ||
126 | 10x |
attrs <- attributes(unclass(x)) |
127 | 10x |
ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
128 | 10x |
do.call(teal_slices, c(ans, attrs)) |
129 |
} |
|
130 | ||
131 | ||
132 |
#' @rdname teal_slices |
|
133 |
#' @export |
|
134 |
#' @keywords internal |
|
135 |
#' |
|
136 |
c.teal_slices <- function(...) { |
|
137 | ! |
x <- list(...) |
138 | ! |
checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
139 | ||
140 | ! |
all_attributes <- lapply(x, attributes) |
141 | ! |
all_attributes <- coalesce_r(all_attributes) |
142 | ! |
all_attributes <- all_attributes[names(all_attributes) != "class"] |
143 | ||
144 | ! |
do.call( |
145 | ! |
teal_slices, |
146 | ! |
c( |
147 | ! |
unique(unlist(x, recursive = FALSE)), |
148 | ! |
all_attributes |
149 |
) |
|
150 |
) |
|
151 |
} |
|
152 | ||
153 | ||
154 |
#' Deep copy `teal_slices` |
|
155 |
#' |
|
156 |
#' it's important to create a new copy of `teal_slices` when |
|
157 |
#' starting a new `shiny` session. Otherwise, object will be shared |
|
158 |
#' by multiple users as it is created in global environment before |
|
159 |
#' `shiny` session starts. |
|
160 |
#' @param filter (`teal_slices`) |
|
161 |
#' @return `teal_slices` |
|
162 |
#' @keywords internal |
|
163 |
deep_copy_filter <- function(filter) { |
|
164 | 1x |
checkmate::assert_class(filter, "teal_slices") |
165 | 1x |
shiny::isolate({ |
166 | 1x |
filter_copy <- lapply(filter, function(slice) { |
167 | 2x |
teal.slice::as.teal_slice(as.list(slice)) |
168 |
}) |
|
169 | 1x |
attributes(filter_copy) <- attributes(filter) |
170 | 1x |
filter_copy |
171 |
}) |
|
172 |
} |
1 |
#' Send input validation messages to output |
|
2 |
#' |
|
3 |
#' Captures messages from `InputValidator` objects and collates them |
|
4 |
#' into one message passed to `validate`. |
|
5 |
#' |
|
6 |
#' `shiny::validate` is used to withhold rendering of an output element until |
|
7 |
#' certain conditions are met and to print a validation message in place |
|
8 |
#' of the output element. |
|
9 |
#' `shinyvalidate::InputValidator` allows to validate input elements |
|
10 |
#' and to display specific messages in their respective input widgets. |
|
11 |
#' `validate_inputs` provides a hybrid solution. |
|
12 |
#' Given an `InputValidator` object, messages corresponding to inputs that fail validation |
|
13 |
#' are extracted and placed in one validation message that is passed to a `validate`/`need` call. |
|
14 |
#' This way the input `validator` messages are repeated in the output. |
|
15 |
#' |
|
16 |
#' The `...` argument accepts any number of `InputValidator` objects |
|
17 |
#' or a nested list of such objects. |
|
18 |
#' If `validators` are passed directly, all their messages are printed together |
|
19 |
#' under one (optional) header message specified by `header`. If a list is passed, |
|
20 |
#' messages are grouped by `validator`. The list's names are used as headers |
|
21 |
#' for their respective message groups. |
|
22 |
#' If neither of the nested list elements is named, a header message is taken from `header`. |
|
23 |
#' |
|
24 |
#' @param ... either any number of `InputValidator` objects |
|
25 |
#' or an optionally named, possibly nested `list` of `InputValidator` |
|
26 |
#' objects, see `Details` |
|
27 |
#' @param header (`character(1)`) generic validation message; set to NULL to omit |
|
28 |
#' |
|
29 |
#' @return |
|
30 |
#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. |
|
31 |
#' |
|
32 |
#' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`] |
|
33 |
#' |
|
34 |
#' @examples |
|
35 |
#' library(shiny) |
|
36 |
#' library(shinyvalidate) |
|
37 |
#' |
|
38 |
#' ui <- fluidPage( |
|
39 |
#' selectInput("method", "validation method", c("sequential", "combined", "grouped")), |
|
40 |
#' sidebarLayout( |
|
41 |
#' sidebarPanel( |
|
42 |
#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])), |
|
43 |
#' selectInput("number", "select a number:", 1:6), |
|
44 |
#' br(), |
|
45 |
#' selectInput("color", "select a color:", |
|
46 |
#' c("black", "indianred2", "springgreen2", "cornflowerblue"), |
|
47 |
#' multiple = TRUE |
|
48 |
#' ), |
|
49 |
#' sliderInput("size", "select point size:", |
|
50 |
#' min = 0.1, max = 4, value = 0.25 |
|
51 |
#' ) |
|
52 |
#' ), |
|
53 |
#' mainPanel(plotOutput("plot")) |
|
54 |
#' ) |
|
55 |
#' ) |
|
56 |
#' |
|
57 |
#' server <- function(input, output) { |
|
58 |
#' # set up input validation |
|
59 |
#' iv <- InputValidator$new() |
|
60 |
#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter")) |
|
61 |
#' iv$add_rule("number", function(x) { |
|
62 |
#' if (as.integer(x) %% 2L == 1L) "choose an even number" |
|
63 |
#' }) |
|
64 |
#' iv$enable() |
|
65 |
#' # more input validation |
|
66 |
#' iv_par <- InputValidator$new() |
|
67 |
#' iv_par$add_rule("color", sv_required(message = "choose a color")) |
|
68 |
#' iv_par$add_rule("color", function(x) { |
|
69 |
#' if (length(x) > 1L) "choose only one color" |
|
70 |
#' }) |
|
71 |
#' iv_par$add_rule( |
|
72 |
#' "size", |
|
73 |
#' sv_between( |
|
74 |
#' left = 0.5, right = 3, |
|
75 |
#' message_fmt = "choose a value between {left} and {right}" |
|
76 |
#' ) |
|
77 |
#' ) |
|
78 |
#' iv_par$enable() |
|
79 |
#' |
|
80 |
#' output$plot <- renderPlot({ |
|
81 |
#' # validate output |
|
82 |
#' switch(input[["method"]], |
|
83 |
#' "sequential" = { |
|
84 |
#' validate_inputs(iv) |
|
85 |
#' validate_inputs(iv_par, header = "Set proper graphical parameters") |
|
86 |
#' }, |
|
87 |
#' "combined" = validate_inputs(iv, iv_par), |
|
88 |
#' "grouped" = validate_inputs(list( |
|
89 |
#' "Some inputs require attention" = iv, |
|
90 |
#' "Set proper graphical parameters" = iv_par |
|
91 |
#' )) |
|
92 |
#' ) |
|
93 |
#' |
|
94 |
#' plot(faithful$eruptions ~ faithful$waiting, |
|
95 |
#' las = 1, pch = 16, |
|
96 |
#' col = input[["color"]], cex = input[["size"]] |
|
97 |
#' ) |
|
98 |
#' }) |
|
99 |
#' } |
|
100 |
#' |
|
101 |
#' if (interactive()) { |
|
102 |
#' shinyApp(ui, server) |
|
103 |
#' } |
|
104 |
#' |
|
105 |
#' @export |
|
106 |
#' |
|
107 |
validate_inputs <- function(..., header = "Some inputs require attention") { |
|
108 | 36x |
dots <- list(...) |
109 | 2x |
if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof") |
110 | ||
111 | 34x |
messages <- extract_validator(dots, header) |
112 | 34x |
failings <- if (!any_names(dots)) { |
113 | 29x |
add_header(messages, header) |
114 |
} else { |
|
115 | 5x |
unlist(messages) |
116 |
} |
|
117 | ||
118 | 34x |
shiny::validate(shiny::need(is.null(failings), failings)) |
119 |
} |
|
120 | ||
121 |
### internal functions |
|
122 | ||
123 |
#' @noRd |
|
124 |
#' @keywords internal |
|
125 |
# recursive object type test |
|
126 |
# returns logical of length 1 |
|
127 |
is_validators <- function(x) { |
|
128 | 118x |
all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator")) |
129 |
} |
|
130 | ||
131 |
#' @noRd |
|
132 |
#' @keywords internal |
|
133 |
# test if an InputValidator object is enabled |
|
134 |
# returns logical of length 1 |
|
135 |
# official method requested at https://github.com/rstudio/shinyvalidate/issues/64 |
|
136 |
validator_enabled <- function(x) { |
|
137 | 49x |
x$.__enclos_env__$private$enabled |
138 |
} |
|
139 | ||
140 |
#' Recursively extract messages from validator list |
|
141 |
#' @return A character vector or a list of character vectors, possibly nested and named. |
|
142 |
#' @noRd |
|
143 |
#' @keywords internal |
|
144 |
extract_validator <- function(iv, header) { |
|
145 | 113x |
if (inherits(iv, "InputValidator")) { |
146 | 49x |
add_header(gather_messages(iv), header) |
147 |
} else { |
|
148 | 58x |
if (is.null(names(iv))) names(iv) <- rep("", length(iv)) |
149 | 64x |
mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE) |
150 |
} |
|
151 |
} |
|
152 | ||
153 |
#' Collate failing messages from validator. |
|
154 |
#' @return `list` |
|
155 |
#' @noRd |
|
156 |
#' @keywords internal |
|
157 |
gather_messages <- function(iv) { |
|
158 | 49x |
if (validator_enabled(iv)) { |
159 | 46x |
status <- iv$validate() |
160 | 46x |
failing_inputs <- Filter(Negate(is.null), status) |
161 | 46x |
unique(lapply(failing_inputs, function(x) x[["message"]])) |
162 |
} else { |
|
163 | 3x |
warning("Validator is disabled and will be omitted.") |
164 | 3x |
list() |
165 |
} |
|
166 |
} |
|
167 | ||
168 |
#' Add optional header to failing messages |
|
169 |
#' @noRd |
|
170 |
#' @keywords internal |
|
171 |
add_header <- function(messages, header = "") { |
|
172 | 78x |
ans <- unlist(messages) |
173 | 78x |
if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) { |
174 | 31x |
ans <- c(paste0(header, "\n"), ans, "\n") |
175 |
} |
|
176 | 78x |
ans |
177 |
} |
|
178 | ||
179 |
#' Recursively check if the object contains a named list |
|
180 |
#' @noRd |
|
181 |
#' @keywords internal |
|
182 |
any_names <- function(x) { |
|
183 | 103x |
any( |
184 | 103x |
if (is.list(x)) { |
185 | 58x |
if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names)) |
186 |
} else { |
|
187 | 40x |
FALSE |
188 |
} |
|
189 |
) |
|
190 |
} |
1 |
#' Filter state snapshot management |
|
2 |
#' |
|
3 |
#' Capture and restore snapshots of the global (app) filter state. |
|
4 |
#' |
|
5 |
#' This module introduces snapshots: stored descriptions of the filter state of the entire application. |
|
6 |
#' Snapshots allow the user to save the current filter state of the application for later use in the session, |
|
7 |
#' as well as to save it to file in order to share it with an app developer or other users, |
|
8 |
#' who in turn can upload it to their own session. |
|
9 |
#' |
|
10 |
#' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner. |
|
11 |
#' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow. |
|
12 |
#' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file |
|
13 |
#' and applies the filter states therein, and clicking the arrow resets initial application state. |
|
14 |
#' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button. |
|
15 |
#' |
|
16 |
#' @section Server logic: |
|
17 |
#' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance |
|
18 |
#' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices` |
|
19 |
#' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation |
|
20 |
#' (attributes are maintained). |
|
21 |
#' |
|
22 |
#' Snapshots are stored in a `reactiveVal` as a named list. |
|
23 |
#' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit. |
|
24 |
#' |
|
25 |
#' For every snapshot except the initial one, a piece of UI is generated that contains |
|
26 |
#' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file. |
|
27 |
#' The initial snapshot is restored by a separate "reset" button. |
|
28 |
#' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that. |
|
29 |
#' |
|
30 |
#' @section Snapshot mechanics: |
|
31 |
#' When a snapshot is captured, the user is prompted to name it. |
|
32 |
#' Names are displayed as is but since they are used to create button ids, |
|
33 |
#' under the hood they are converted to syntactically valid strings. |
|
34 |
#' New snapshot names are validated so that their valid versions are unique. |
|
35 |
#' Leading and trailing white space is trimmed. |
|
36 |
#' |
|
37 |
#' The module can read the global state of the application from `slices_global` and `mapping_matrix`. |
|
38 |
#' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module. |
|
39 |
#' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot. |
|
40 |
#' The snapshot contains the `mapping` attribute of the initial application state |
|
41 |
#' (or one that has been restored), which may not reflect the current one, |
|
42 |
#' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that, |
|
43 |
#' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping. |
|
44 |
#' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list. |
|
45 |
#' |
|
46 |
#' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object. |
|
47 |
#' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared |
|
48 |
#' and set anew according to the `mapping` attribute of the snapshot. |
|
49 |
#' The snapshot is then set as the current content of `slices_global`. |
|
50 |
#' |
|
51 |
#' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring, |
|
52 |
#' and then saved to file with [slices_store()]. |
|
53 |
#' |
|
54 |
#' When a snapshot is uploaded, it will first be added to storage just like a newly created one, |
|
55 |
#' and then used to restore app state much like a snapshot taken from storage. |
|
56 |
#' Upon clicking the upload icon the user will be prompted for a file to upload |
|
57 |
#' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped) |
|
58 |
#' and normal naming rules apply. Loading the file yields a `teal_slices` object, |
|
59 |
#' which is disassembled for storage and used directly for restoring app state. |
|
60 |
#' |
|
61 |
#' @section Transferring snapshots: |
|
62 |
#' Snapshots uploaded from disk should only be used in the same application they come from, |
|
63 |
#' _i.e._ an application that uses the same data and the same modules. |
|
64 |
#' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of |
|
65 |
#' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that |
|
66 |
#' of the current app state and only if the match is the snapshot admitted to the session. |
|
67 |
#' |
|
68 |
#' @param id (`character(1)`) `shiny` module id |
|
69 |
#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object |
|
70 |
#' containing all `teal_slice`s existing in the app, both active and inactive |
|
71 |
#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation |
|
72 |
#' of the mapping of filter state ids (rows) to modules labels (columns); |
|
73 |
#' all columns are `logical` vectors |
|
74 |
#' @param filtered_data_list non-nested (named `list`) that contains `FilteredData` objects |
|
75 |
#' |
|
76 |
#' @return Nothing is returned. |
|
77 |
#' |
|
78 |
#' @name snapshot_manager_module |
|
79 |
#' @aliases snapshot snapshot_manager |
|
80 |
#' |
|
81 |
#' @author Aleksander Chlebowski |
|
82 |
#' |
|
83 |
#' @rdname snapshot_manager_module |
|
84 |
#' @keywords internal |
|
85 |
#' |
|
86 |
snapshot_manager_ui <- function(id) { |
|
87 | ! |
ns <- NS(id) |
88 | ! |
div( |
89 | ! |
class = "snapshot_manager_content", |
90 | ! |
div( |
91 | ! |
class = "snapshot_table_row", |
92 | ! |
span(tags$b("Snapshot manager")), |
93 | ! |
actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"), |
94 | ! |
actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"), |
95 | ! |
actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"), |
96 | ! |
NULL |
97 |
), |
|
98 | ! |
uiOutput(ns("snapshot_list")) |
99 |
) |
|
100 |
} |
|
101 | ||
102 |
#' @rdname snapshot_manager_module |
|
103 |
#' @keywords internal |
|
104 |
#' |
|
105 |
snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) { |
|
106 | 6x |
checkmate::assert_character(id) |
107 | 6x |
checkmate::assert_true(is.reactive(slices_global)) |
108 | 6x |
checkmate::assert_class(isolate(slices_global()), "teal_slices") |
109 | 6x |
checkmate::assert_true(is.reactive(mapping_matrix)) |
110 | 6x |
checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE) |
111 | 6x |
checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named") |
112 | ||
113 | 6x |
moduleServer(id, function(input, output, session) { |
114 | 6x |
ns <- session$ns |
115 | ||
116 |
# Store global filter states ---- |
|
117 | 6x |
filter <- isolate(slices_global()) |
118 | 6x |
snapshot_history <- reactiveVal({ |
119 | 6x |
list( |
120 | 6x |
"Initial application state" = as.list(filter, recursive = TRUE) |
121 |
) |
|
122 |
}) |
|
123 | ||
124 |
# Snapshot current application state ---- |
|
125 |
# Name snaphsot. |
|
126 | 6x |
observeEvent(input$snapshot_add, { |
127 | ! |
showModal( |
128 | ! |
modalDialog( |
129 | ! |
textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"), |
130 | ! |
footer = tagList( |
131 | ! |
actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")), |
132 | ! |
modalButton(label = "Cancel", icon = icon("thumbs-down")) |
133 |
), |
|
134 | ! |
size = "s" |
135 |
) |
|
136 |
) |
|
137 |
}) |
|
138 |
# Store snaphsot. |
|
139 | 6x |
observeEvent(input$snapshot_name_accept, { |
140 | ! |
snapshot_name <- trimws(input$snapshot_name) |
141 | ! |
if (identical(snapshot_name, "")) { |
142 | ! |
showNotification( |
143 | ! |
"Please name the snapshot.", |
144 | ! |
type = "message" |
145 |
) |
|
146 | ! |
updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
147 | ! |
} else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) { |
148 | ! |
showNotification( |
149 | ! |
"This name is in conflict with other snapshot names. Please choose a different one.", |
150 | ! |
type = "message" |
151 |
) |
|
152 | ! |
updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
153 |
} else { |
|
154 | ! |
snapshot <- as.list(slices_global(), recursive = TRUE) |
155 | ! |
attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix()) |
156 | ! |
snapshot_update <- c(snapshot_history(), list(snapshot)) |
157 | ! |
names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
158 | ! |
snapshot_history(snapshot_update) |
159 | ! |
removeModal() |
160 |
# Reopen filter manager modal by clicking button in the main application. |
|
161 | ! |
shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE) |
162 |
} |
|
163 |
}) |
|
164 | ||
165 |
# Upload a snapshot file ---- |
|
166 |
# Select file. |
|
167 | 6x |
observeEvent(input$snapshot_load, { |
168 | ! |
showModal( |
169 | ! |
modalDialog( |
170 | ! |
fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"), |
171 | ! |
textInput( |
172 | ! |
ns("snapshot_name"), |
173 | ! |
"Name the snapshot (optional)", |
174 | ! |
width = "100%", |
175 | ! |
placeholder = "Meaningful, unique name" |
176 |
), |
|
177 | ! |
footer = tagList( |
178 | ! |
actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")), |
179 | ! |
modalButton(label = "Cancel", icon = icon("thumbs-down")) |
180 |
) |
|
181 |
) |
|
182 |
) |
|
183 |
}) |
|
184 |
# Store new snapshot to list and restore filter states. |
|
185 | 6x |
observeEvent(input$snaphot_file_accept, { |
186 | ! |
snapshot_name <- trimws(input$snapshot_name) |
187 | ! |
if (identical(snapshot_name, "")) { |
188 | ! |
snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name) |
189 |
} |
|
190 | ! |
if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) { |
191 | ! |
showNotification( |
192 | ! |
"This name is in conflict with other snapshot names. Please choose a different one.", |
193 | ! |
type = "message" |
194 |
) |
|
195 | ! |
updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
196 |
} else { |
|
197 |
# Restore snapshot and verify app compatibility. |
|
198 | ! |
snapshot_state <- try(slices_restore(input$snapshot_file$datapath)) |
199 | ! |
if (!inherits(snapshot_state, "modules_teal_slices")) { |
200 | ! |
showNotification( |
201 | ! |
"File appears to be corrupt.", |
202 | ! |
type = "error" |
203 |
) |
|
204 | ! |
} else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) { |
205 | ! |
showNotification( |
206 | ! |
"This snapshot file is not compatible with the app and cannot be loaded.", |
207 | ! |
type = "warning" |
208 |
) |
|
209 |
} else { |
|
210 |
# Add to snapshot history. |
|
211 | ! |
snapshot <- as.list(snapshot_state, recursive = TRUE) |
212 | ! |
snapshot_update <- c(snapshot_history(), list(snapshot)) |
213 | ! |
names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
214 | ! |
snapshot_history(snapshot_update) |
215 |
### Begin simplified restore procedure. ### |
|
216 | ! |
mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
217 | ! |
mapply( |
218 | ! |
function(filtered_data, filter_ids) { |
219 | ! |
filtered_data$clear_filter_states(force = TRUE) |
220 | ! |
slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
221 | ! |
filtered_data$set_filter_state(slices) |
222 |
}, |
|
223 | ! |
filtered_data = filtered_data_list, |
224 | ! |
filter_ids = mapping_unfolded |
225 |
) |
|
226 | ! |
slices_global(snapshot_state) |
227 | ! |
removeModal() |
228 |
### End simplified restore procedure. ### |
|
229 |
} |
|
230 |
} |
|
231 |
}) |
|
232 |
# Apply newly added snapshot. |
|
233 | ||
234 |
# Restore initial state ---- |
|
235 | 6x |
observeEvent(input$snapshot_reset, { |
236 | ! |
s <- "Initial application state" |
237 |
### Begin restore procedure. ### |
|
238 | ! |
snapshot <- snapshot_history()[[s]] |
239 | ! |
snapshot_state <- as.teal_slices(snapshot) |
240 | ! |
mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
241 | ! |
mapply( |
242 | ! |
function(filtered_data, filter_ids) { |
243 | ! |
filtered_data$clear_filter_states(force = TRUE) |
244 | ! |
slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
245 | ! |
filtered_data$set_filter_state(slices) |
246 |
}, |
|
247 | ! |
filtered_data = filtered_data_list, |
248 | ! |
filter_ids = mapping_unfolded |
249 |
) |
|
250 | ! |
slices_global(snapshot_state) |
251 | ! |
removeModal() |
252 |
### End restore procedure. ### |
|
253 |
}) |
|
254 | ||
255 |
# Build snapshot table ---- |
|
256 |
# Create UI elements and server logic for the snapshot table. |
|
257 |
# Observers must be tracked to avoid duplication and excess reactivity. |
|
258 |
# Remaining elements are tracked likewise for consistency and a slight speed margin. |
|
259 | 6x |
observers <- reactiveValues() |
260 | 6x |
handlers <- reactiveValues() |
261 | 6x |
divs <- reactiveValues() |
262 | ||
263 | 6x |
observeEvent(snapshot_history(), { |
264 | 2x |
lapply(names(snapshot_history())[-1L], function(s) { |
265 | ! |
id_pickme <- sprintf("pickme_%s", make.names(s)) |
266 | ! |
id_saveme <- sprintf("saveme_%s", make.names(s)) |
267 | ! |
id_rowme <- sprintf("rowme_%s", make.names(s)) |
268 | ||
269 |
# Observer for restoring snapshot. |
|
270 | ! |
if (!is.element(id_pickme, names(observers))) { |
271 | ! |
observers[[id_pickme]] <- observeEvent(input[[id_pickme]], { |
272 |
### Begin restore procedure. ### |
|
273 | ! |
snapshot <- snapshot_history()[[s]] |
274 | ! |
snapshot_state <- as.teal_slices(snapshot) |
275 | ! |
mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
276 | ! |
mapply( |
277 | ! |
function(filtered_data, filter_ids) { |
278 | ! |
filtered_data$clear_filter_states(force = TRUE) |
279 | ! |
slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
280 | ! |
filtered_data$set_filter_state(slices) |
281 |
}, |
|
282 | ! |
filtered_data = filtered_data_list, |
283 | ! |
filter_ids = mapping_unfolded |
284 |
) |
|
285 | ! |
slices_global(snapshot_state) |
286 | ! |
removeModal() |
287 |
### End restore procedure. ### |
|
288 |
}) |
|
289 |
} |
|
290 |
# Create handler for downloading snapshot. |
|
291 | ! |
if (!is.element(id_saveme, names(handlers))) { |
292 | ! |
output[[id_saveme]] <- downloadHandler( |
293 | ! |
filename = function() { |
294 | ! |
sprintf("teal_snapshot_%s_%s.json", s, Sys.Date()) |
295 |
}, |
|
296 | ! |
content = function(file) { |
297 | ! |
snapshot <- snapshot_history()[[s]] |
298 | ! |
snapshot_state <- as.teal_slices(snapshot) |
299 | ! |
slices_store(tss = snapshot_state, file = file) |
300 |
} |
|
301 |
) |
|
302 | ! |
handlers[[id_saveme]] <- id_saveme |
303 |
} |
|
304 |
# Create a row for the snapshot table. |
|
305 | ! |
if (!is.element(id_rowme, names(divs))) { |
306 | ! |
divs[[id_rowme]] <- div( |
307 | ! |
class = "snapshot_table_row", |
308 | ! |
span(h5(s)), |
309 | ! |
actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"), |
310 | ! |
downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file") |
311 |
) |
|
312 |
} |
|
313 |
}) |
|
314 |
}) |
|
315 | ||
316 |
# Create table to display list of snapshots and their actions. |
|
317 | 6x |
output$snapshot_list <- renderUI({ |
318 | 2x |
rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d) |
319 | 2x |
if (length(rows) == 0L) { |
320 | 2x |
div( |
321 | 2x |
class = "snapshot_manager_placeholder", |
322 | 2x |
"Snapshots will appear here." |
323 |
) |
|
324 |
} else { |
|
325 | ! |
rows |
326 |
} |
|
327 |
}) |
|
328 |
}) |
|
329 |
} |
|
330 | ||
331 |
### utility functions ---- |
|
332 | ||
333 |
#' Explicitly enumerate global filters. |
|
334 |
#' |
|
335 |
#' Transform module mapping such that global filters are explicitly specified for every module. |
|
336 |
#' |
|
337 |
#' @param mapping (named `list`) as stored in mapping parameter of `teal_slices` |
|
338 |
#' @param module_names (`character`) vector containing names of all modules in the app |
|
339 |
#' @return A `named_list` with one element per module, each element containing all filters applied to that module. |
|
340 |
#' @keywords internal |
|
341 |
#' |
|
342 |
unfold_mapping <- function(mapping, module_names) { |
|
343 | ! |
module_names <- structure(module_names, names = module_names) |
344 | ! |
lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]])) |
345 |
} |
|
346 | ||
347 |
#' Convert mapping matrix to filter mapping specification. |
|
348 |
#' |
|
349 |
#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module, |
|
350 |
#' to a list specification like the one used in the `mapping` attribute of `teal_slices`. |
|
351 |
#' Global filters are gathered in one list element. |
|
352 |
#' If a module has no active filters but the global ones, it will not be mentioned in the output. |
|
353 |
#' |
|
354 |
#' @param mapping_matrix (`data.frame`) of logical vectors where |
|
355 |
#' columns represent modules and row represent `teal_slice`s |
|
356 |
#' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object. |
|
357 |
#' @keywords internal |
|
358 |
#' |
|
359 |
matrix_to_mapping <- function(mapping_matrix) { |
|
360 | ! |
mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x)) |
361 | ! |
global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L)) |
362 | ! |
global_filters <- names(global[global]) |
363 | ! |
local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ] |
364 | ||
365 | ! |
mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters)) |
366 | ! |
Filter(function(x) length(x) != 0L, mapping) |
367 |
} |
1 |
# This module is the main teal module that puts everything together. |
|
2 | ||
3 |
#' `teal` main app module |
|
4 |
#' |
|
5 |
#' This is the main `teal` app that puts everything together. |
|
6 |
#' |
|
7 |
#' It displays the splash UI which is used to fetch the data, possibly |
|
8 |
#' prompting for a password input to fetch the data. Once the data is ready, |
|
9 |
#' the splash screen is replaced by the actual `teal` UI that is tabsetted and |
|
10 |
#' has a filter panel with `datanames` that are relevant for the current tab. |
|
11 |
#' Nested tabs are possible, but we limit it to two nesting levels for reasons |
|
12 |
#' of clarity of the UI. |
|
13 |
#' |
|
14 |
#' The splash screen functionality can also be used |
|
15 |
#' for non-delayed data which takes time to load into memory, avoiding |
|
16 |
#' `shiny` session timeouts. |
|
17 |
#' |
|
18 |
#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the |
|
19 |
#' `datasets` object that is shared across modules. |
|
20 |
#' Once it is ready and non-`NULL`, the splash screen is replaced by the |
|
21 |
#' main `teal` UI that depends on the data. |
|
22 |
#' The currently active tab is tracked and the right filter panel |
|
23 |
#' updates the displayed datasets to filter for according to the active `datanames` |
|
24 |
#' of the tab. |
|
25 |
#' |
|
26 |
#' It is written as a `shiny` module so it can be added into other apps as well. |
|
27 |
#' |
|
28 |
#' @name module_teal |
|
29 |
#' |
|
30 |
#' @inheritParams module_teal_with_splash |
|
31 |
#' |
|
32 |
#' @param splash_ui (`shiny.tag`) UI to display initially, |
|
33 |
#' can be a splash screen or a `shiny` module UI. For the latter, see |
|
34 |
#' [init()] about how to call the corresponding server function. |
|
35 |
#' |
|
36 |
#' @param teal_data_rv (`reactive`) |
|
37 |
#' returns the `teal_data`, only evaluated once, `NULL` value is ignored |
|
38 |
#' |
|
39 |
#' @return |
|
40 |
#' Returns a `reactive` expression which returns the currently active module. |
|
41 |
#' |
|
42 |
#' @keywords internal |
|
43 |
#' |
|
44 |
NULL |
|
45 | ||
46 |
#' @rdname module_teal |
|
47 |
ui_teal <- function(id, |
|
48 |
splash_ui = tags$h2("Starting the Teal App"), |
|
49 |
title = build_app_title(), |
|
50 |
header = tags$p(), |
|
51 |
footer = tags$p()) { |
|
52 | 7x |
checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
53 | ||
54 | 7x |
checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html")) |
55 | ||
56 | 7x |
if (is.character(title)) { |
57 | ! |
title <- build_app_title(title) |
58 |
} else { |
|
59 | 7x |
validate_app_title_tag(title) |
60 |
} |
|
61 | ||
62 | 7x |
checkmate::assert( |
63 | 7x |
.var.name = "header", |
64 | 7x |
checkmate::check_string(header), |
65 | 7x |
checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html")) |
66 |
) |
|
67 | 7x |
if (checkmate::test_string(header)) { |
68 | ! |
header <- tags$p(header) |
69 |
} |
|
70 | ||
71 | 7x |
checkmate::assert( |
72 | 7x |
.var.name = "footer", |
73 | 7x |
checkmate::check_string(footer), |
74 | 7x |
checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html")) |
75 |
) |
|
76 | 7x |
if (checkmate::test_string(footer)) { |
77 | ! |
footer <- tags$p(footer) |
78 |
} |
|
79 | ||
80 | 7x |
ns <- NS(id) |
81 | ||
82 |
# Once the data is loaded, we will remove this element and add the real teal UI instead |
|
83 | 7x |
splash_ui <- div( |
84 |
# id so we can remove the splash screen once ready, which is the first child of this container |
|
85 | 7x |
id = ns("main_ui_container"), |
86 |
# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
|
87 |
# just the first item of the tagList) |
|
88 | 7x |
div(splash_ui) |
89 |
) |
|
90 | ||
91 |
# show busy icon when `shiny` session is busy computing stuff |
|
92 |
# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length. |
|
93 | 7x |
shiny_busy_message_panel <- conditionalPanel( |
94 | 7x |
condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length. |
95 | 7x |
div( |
96 | 7x |
icon("arrows-rotate", "spin fa-spin"), |
97 | 7x |
"Computing ...", |
98 |
# CSS defined in `custom.css` |
|
99 | 7x |
class = "shinybusymessage" |
100 |
) |
|
101 |
) |
|
102 | ||
103 | 7x |
fluidPage( |
104 | 7x |
title = title, |
105 | 7x |
theme = get_teal_bs_theme(), |
106 | 7x |
include_teal_css_js(), |
107 | 7x |
tags$header(header), |
108 | 7x |
tags$hr(class = "my-2"), |
109 | 7x |
shiny_busy_message_panel, |
110 | 7x |
splash_ui, |
111 | 7x |
tags$hr(), |
112 | 7x |
tags$footer( |
113 | 7x |
div( |
114 | 7x |
footer, |
115 | 7x |
teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"), |
116 | 7x |
textOutput(ns("identifier")) |
117 |
) |
|
118 |
) |
|
119 |
) |
|
120 |
} |
|
121 | ||
122 | ||
123 |
#' @rdname module_teal |
|
124 |
srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) { |
|
125 | 19x |
stopifnot(is.reactive(teal_data_rv)) |
126 | 18x |
moduleServer(id, function(input, output, session) { |
127 | 18x |
logger::log_trace("srv_teal initializing the module.") |
128 | ||
129 | 18x |
output$identifier <- renderText( |
130 | 18x |
paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32)) |
131 |
) |
|
132 | ||
133 | 18x |
teal.widgets::verbatim_popup_srv( |
134 | 18x |
"sessionInfo", |
135 | 18x |
verbatim_content = utils::capture.output(utils::sessionInfo()), |
136 | 18x |
title = "SessionInfo" |
137 |
) |
|
138 | ||
139 |
# `JavaScript` code |
|
140 | 18x |
run_js_files(files = "init.js") |
141 | ||
142 |
# set timezone in shiny app |
|
143 |
# timezone is set in the early beginning so it will be available also |
|
144 |
# for `DDL` and all shiny modules |
|
145 | 18x |
get_client_timezone(session$ns) |
146 | 18x |
observeEvent( |
147 | 18x |
eventExpr = input$timezone, |
148 | 18x |
once = TRUE, |
149 | 18x |
handlerExpr = { |
150 | ! |
session$userData$timezone <- input$timezone |
151 | ! |
logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.") |
152 |
} |
|
153 |
) |
|
154 | ||
155 | 18x |
reporter <- teal.reporter::Reporter$new() |
156 | 18x |
if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) { |
157 | ! |
modules <- append_module(modules, reporter_previewer_module()) |
158 |
} |
|
159 | ||
160 | 18x |
env <- environment() |
161 | 18x |
datasets_reactive <- eventReactive(teal_data_rv(), { |
162 | 4x |
env$progress <- shiny::Progress$new(session) |
163 | 4x |
env$progress$set(0.25, message = "Setting data") |
164 | ||
165 |
# Create list of `FilteredData` objects that reflects structure of `modules`. |
|
166 | 4x |
modules_datasets(teal_data_rv(), modules, filter, teal_data_to_filtered_data(teal_data_rv())) |
167 |
}) |
|
168 | ||
169 |
# Replace splash / welcome screen once data is loaded ---- |
|
170 |
# ignoreNULL to not trigger at the beginning when data is NULL |
|
171 |
# just handle it once because data obtained through delayed loading should |
|
172 |
# usually not change afterwards |
|
173 |
# if restored from bookmarked state, `filter` is ignored |
|
174 | ||
175 | 18x |
observeEvent(datasets_reactive(), once = TRUE, { |
176 | ! |
logger::log_trace("srv_teal@5 setting main ui after data was pulled") |
177 | ! |
on.exit(env$progress$close()) |
178 | ! |
env$progress$set(0.5, message = "Setting up main UI") |
179 | ! |
datasets <- datasets_reactive() |
180 | ||
181 |
# main_ui_container contains splash screen first and we remove it and replace it by the real UI |
|
182 | ! |
removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container"))) |
183 | ! |
insertUI( |
184 | ! |
selector = paste0("#", session$ns("main_ui_container")), |
185 | ! |
where = "beforeEnd", |
186 |
# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
|
187 |
# just the first item of the tagList) |
|
188 | ! |
ui = div(ui_tabs_with_filters( |
189 | ! |
session$ns("main_ui"), |
190 | ! |
modules = modules, |
191 | ! |
datasets = datasets, |
192 | ! |
filter = filter |
193 |
)), |
|
194 |
# needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not |
|
195 |
# have any effect as they are ignored when not present |
|
196 | ! |
immediate = TRUE |
197 |
) |
|
198 | ||
199 |
# must make sure that this is only executed once as modules assume their observers are only |
|
200 |
# registered once (calling server functions twice would trigger observers twice each time) |
|
201 | ! |
srv_tabs_with_filters( |
202 | ! |
id = "main_ui", |
203 | ! |
datasets = datasets, |
204 | ! |
modules = modules, |
205 | ! |
reporter = reporter, |
206 | ! |
filter = filter |
207 |
) |
|
208 |
}) |
|
209 |
}) |
|
210 |
} |
1 |
#' Create a UI of nested tabs of `teal_modules` |
|
2 |
#' |
|
3 |
#' @section `ui_nested_tabs`: |
|
4 |
#' Each `teal_modules` is translated to a `tabsetPanel` and each |
|
5 |
#' of its children is another tab-module called recursively. The UI of a |
|
6 |
#' `teal_module` is obtained by calling its UI function. |
|
7 |
#' |
|
8 |
#' The `datasets` argument is required to resolve the `teal` arguments in an |
|
9 |
#' isolated context (with respect to reactivity). |
|
10 |
#' |
|
11 |
#' @section `srv_nested_tabs`: |
|
12 |
#' This module recursively calls all elements of `modules` and returns currently active one. |
|
13 |
#' - `teal_module` returns self as a active module. |
|
14 |
#' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`. |
|
15 |
#' |
|
16 |
#' @name module_nested_tabs |
|
17 |
#' |
|
18 |
#' @inheritParams module_tabs_with_filters |
|
19 |
#' |
|
20 |
#' @param depth (`integer(1)`) |
|
21 |
#' number which helps to determine depth of the modules nesting. |
|
22 |
#' @param is_module_specific (`logical(1)`) |
|
23 |
#' flag determining if the filter panel is global or module-specific. |
|
24 |
#' When set to `TRUE`, a filter panel is called inside of each module tab. |
|
25 |
#' |
|
26 |
#' @return |
|
27 |
#' Depending on the class of `modules`, `ui_nested_tabs` returns: |
|
28 |
#' - `teal_module`: instantiated UI of the module. |
|
29 |
#' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively |
|
30 |
#' calling this function on it. |
|
31 |
#' |
|
32 |
#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab. |
|
33 |
#' |
|
34 |
#' @keywords internal |
|
35 |
NULL |
|
36 | ||
37 |
#' @rdname module_nested_tabs |
|
38 |
ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { |
|
39 | ! |
checkmate::assert_multi_class(modules, c("teal_modules", "teal_module")) |
40 | ! |
checkmate::assert_count(depth) |
41 | ! |
UseMethod("ui_nested_tabs", modules) |
42 |
} |
|
43 | ||
44 |
#' @rdname module_nested_tabs |
|
45 |
#' @export |
|
46 |
ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { |
|
47 | ! |
stop("Modules class not supported: ", paste(class(modules), collapse = " ")) |
48 |
} |
|
49 | ||
50 |
#' @rdname module_nested_tabs |
|
51 |
#' @export |
|
52 |
ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { |
|
53 | ! |
checkmate::assert_list(datasets, types = c("list", "FilteredData")) |
54 | ! |
ns <- NS(id) |
55 | ! |
do.call( |
56 | ! |
tabsetPanel, |
57 | ! |
c( |
58 |
# by giving an id, we can reactively respond to tab changes |
|
59 | ! |
list( |
60 | ! |
id = ns("active_tab"), |
61 | ! |
type = if (modules$label == "root") "pills" else "tabs" |
62 |
), |
|
63 | ! |
lapply( |
64 | ! |
names(modules$children), |
65 | ! |
function(module_id) { |
66 | ! |
module_label <- modules$children[[module_id]]$label |
67 | ! |
tabPanel( |
68 | ! |
title = module_label, |
69 | ! |
value = module_id, # when clicked this tab value changes input$<tabset panel id> |
70 | ! |
ui_nested_tabs( |
71 | ! |
id = ns(module_id), |
72 | ! |
modules = modules$children[[module_id]], |
73 | ! |
datasets = datasets[[module_label]], |
74 | ! |
depth = depth + 1L, |
75 | ! |
is_module_specific = is_module_specific |
76 |
) |
|
77 |
) |
|
78 |
} |
|
79 |
) |
|
80 |
) |
|
81 |
) |
|
82 |
} |
|
83 | ||
84 |
#' @rdname module_nested_tabs |
|
85 |
#' @export |
|
86 |
ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { |
|
87 | ! |
checkmate::assert_class(datasets, classes = "FilteredData") |
88 | ! |
ns <- NS(id) |
89 | ||
90 | ! |
args <- c(list(id = ns("module")), modules$ui_args) |
91 | ||
92 | ! |
teal_ui <- tags$div( |
93 | ! |
id = id, |
94 | ! |
class = "teal_module", |
95 | ! |
uiOutput(ns("data_reactive"), inline = TRUE), |
96 | ! |
tagList( |
97 | ! |
if (depth >= 2L) div(style = "mt-6"), |
98 | ! |
do.call(modules$ui, args) |
99 |
) |
|
100 |
) |
|
101 | ||
102 | ! |
if (!is.null(modules$datanames) && is_module_specific) { |
103 | ! |
fluidRow( |
104 | ! |
column(width = 9, teal_ui, class = "teal_primary_col"), |
105 | ! |
column( |
106 | ! |
width = 3, |
107 | ! |
datasets$ui_filter_panel(ns("module_filter_panel")), |
108 | ! |
class = "teal_secondary_col" |
109 |
) |
|
110 |
) |
|
111 |
} else { |
|
112 | ! |
teal_ui |
113 |
} |
|
114 |
} |
|
115 | ||
116 |
#' @rdname module_nested_tabs |
|
117 |
srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE, |
|
118 |
reporter = teal.reporter::Reporter$new()) { |
|
119 | 50x |
checkmate::assert_multi_class(modules, c("teal_modules", "teal_module")) |
120 | 50x |
checkmate::assert_class(reporter, "Reporter") |
121 | 49x |
UseMethod("srv_nested_tabs", modules) |
122 |
} |
|
123 | ||
124 |
#' @rdname module_nested_tabs |
|
125 |
#' @export |
|
126 |
srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE, |
|
127 |
reporter = teal.reporter::Reporter$new()) { |
|
128 | ! |
stop("Modules class not supported: ", paste(class(modules), collapse = " ")) |
129 |
} |
|
130 | ||
131 |
#' @rdname module_nested_tabs |
|
132 |
#' @export |
|
133 |
srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE, |
|
134 |
reporter = teal.reporter::Reporter$new()) { |
|
135 | 22x |
checkmate::assert_list(datasets, types = c("list", "FilteredData")) |
136 | ||
137 | 22x |
moduleServer(id = id, module = function(input, output, session) { |
138 | 22x |
logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.") |
139 | ||
140 | 22x |
labels <- vapply(modules$children, `[[`, character(1), "label") |
141 | 22x |
modules_reactive <- sapply( |
142 | 22x |
names(modules$children), |
143 | 22x |
function(module_id) { |
144 | 33x |
srv_nested_tabs( |
145 | 33x |
id = module_id, |
146 | 33x |
datasets = datasets[[labels[module_id]]], |
147 | 33x |
modules = modules$children[[module_id]], |
148 | 33x |
is_module_specific = is_module_specific, |
149 | 33x |
reporter = reporter |
150 |
) |
|
151 |
}, |
|
152 | 22x |
simplify = FALSE |
153 |
) |
|
154 | ||
155 |
# when not ready input$active_tab would return NULL - this would fail next reactive |
|
156 | 22x |
input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE) |
157 | 22x |
get_active_module <- reactive({ |
158 | 12x |
if (length(modules$children) == 1L) { |
159 |
# single tab is active by default |
|
160 | 1x |
modules_reactive[[1]]() |
161 |
} else { |
|
162 |
# switch to active tab |
|
163 | 11x |
modules_reactive[[input_validated()]]() |
164 |
} |
|
165 |
}) |
|
166 | ||
167 | 22x |
get_active_module |
168 |
}) |
|
169 |
} |
|
170 | ||
171 |
#' @rdname module_nested_tabs |
|
172 |
#' @export |
|
173 |
srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE, |
|
174 |
reporter = teal.reporter::Reporter$new()) { |
|
175 | 27x |
checkmate::assert_class(datasets, "FilteredData") |
176 | 27x |
logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.") |
177 | ||
178 | 27x |
moduleServer(id = id, module = function(input, output, session) { |
179 | 27x |
if (!is.null(modules$datanames) && is_module_specific) { |
180 | ! |
datasets$srv_filter_panel("module_filter_panel") |
181 |
} |
|
182 | ||
183 |
# Create two triggers to limit reactivity between filter-panel and modules. |
|
184 |
# We want to recalculate only visible modules |
|
185 |
# - trigger the data when the tab is selected |
|
186 |
# - trigger module to be called when the tab is selected for the first time |
|
187 | 27x |
trigger_data <- reactiveVal(1L) |
188 | 27x |
trigger_module <- reactiveVal(NULL) |
189 | 27x |
output$data_reactive <- renderUI({ |
190 | 17x |
lapply(datasets$datanames(), function(x) { |
191 | 21x |
datasets$get_data(x, filtered = TRUE) |
192 |
}) |
|
193 | 17x |
isolate(trigger_data(trigger_data() + 1)) |
194 | 17x |
isolate(trigger_module(TRUE)) |
195 | ||
196 | 17x |
NULL |
197 |
}) |
|
198 | ||
199 |
# collect arguments to run teal_module |
|
200 | 27x |
args <- c(list(id = "module"), modules$server_args) |
201 | 27x |
if (is_arg_used(modules$server, "reporter")) { |
202 | ! |
args <- c(args, list(reporter = reporter)) |
203 |
} |
|
204 | ||
205 | 27x |
if (is_arg_used(modules$server, "datasets")) { |
206 | 1x |
args <- c(args, datasets = datasets) |
207 |
} |
|
208 | ||
209 | 27x |
if (is_arg_used(modules$server, "data")) { |
210 | 7x |
data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets)) |
211 | 7x |
args <- c(args, data = list(data)) |
212 |
} |
|
213 | ||
214 | 27x |
if (is_arg_used(modules$server, "filter_panel_api")) { |
215 | 2x |
filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets) |
216 | 2x |
args <- c(args, filter_panel_api = filter_panel_api) |
217 |
} |
|
218 | ||
219 |
# observe the trigger_module above to induce the module once the renderUI is triggered |
|
220 | 27x |
observeEvent( |
221 | 27x |
ignoreNULL = TRUE, |
222 | 27x |
once = TRUE, |
223 | 27x |
eventExpr = trigger_module(), |
224 | 27x |
handlerExpr = { |
225 | 17x |
module_output <- if (is_arg_used(modules$server, "id")) { |
226 | 17x |
do.call(modules$server, args) |
227 |
} else { |
|
228 | ! |
do.call(callModule, c(args, list(module = modules$server))) |
229 |
} |
|
230 |
} |
|
231 |
) |
|
232 | ||
233 | 27x |
reactive(modules) |
234 |
}) |
|
235 |
} |
|
236 | ||
237 |
#' Convert `FilteredData` to reactive list of datasets of the `teal_data` type. |
|
238 |
#' |
|
239 |
#' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module. |
|
240 |
#' Please note that if a module needs a dataset which has a parent, then the parent will also be returned. |
|
241 |
#' A hash per `dataset` is calculated internally and returned in the code. |
|
242 |
#' |
|
243 |
#' @param module (`teal_module`) module where needed filters are taken from |
|
244 |
#' @param datasets (`FilteredData`) object where needed data are taken from |
|
245 |
#' |
|
246 |
#' @return A `teal_data` object. |
|
247 |
#' |
|
248 |
#' @keywords internal |
|
249 |
.datasets_to_data <- function(module, datasets) { |
|
250 | 4x |
checkmate::assert_class(module, "teal_module") |
251 | 4x |
checkmate::assert_class(datasets, "FilteredData") |
252 | ||
253 | 4x |
datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) { |
254 | 1x |
datasets$datanames() |
255 |
} else { |
|
256 | 3x |
include_parent_datanames( |
257 | 3x |
module$datanames, |
258 | 3x |
datasets$get_join_keys() |
259 |
) |
|
260 |
} |
|
261 | ||
262 |
# list of reactive filtered data |
|
263 | 4x |
data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE) |
264 | ||
265 | 4x |
hashes <- calculate_hashes(datanames, datasets) |
266 | ||
267 | 4x |
code <- c( |
268 | 4x |
get_rcode_str_install(), |
269 | 4x |
get_rcode_libraries(), |
270 | 4x |
get_datasets_code(datanames, datasets, hashes) |
271 |
) |
|
272 | ||
273 | ||
274 | 4x |
data <- do.call( |
275 | 4x |
teal.data::teal_data, |
276 | 4x |
args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames])) |
277 |
) |
|
278 | ||
279 | 4x |
data@verified <- attr(datasets, "verification_status") |
280 | 4x |
data |
281 |
} |
|
282 | ||
283 |
#' Get the hash of a dataset |
|
284 |
#' |
|
285 |
#' @param datanames (`character`) names of datasets |
|
286 |
#' @param datasets (`FilteredData`) object holding the data |
|
287 |
#' |
|
288 |
#' @return A list of hashes per dataset. |
|
289 |
#' @keywords internal |
|
290 |
#' |
|
291 |
calculate_hashes <- function(datanames, datasets) { |
|
292 | 7x |
sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE) |
293 |
} |
1 |
#' Add right filter panel into each of the top-level `teal_modules` UIs |
|
2 |
#' |
|
3 |
#' The [ui_nested_tabs] function returns a nested tabbed UI corresponding |
|
4 |
#' to the nested modules. |
|
5 |
#' This function adds the right filter panel to each main tab. |
|
6 |
#' |
|
7 |
#' The right filter panel's filter choices affect the `datasets` object. Therefore, |
|
8 |
#' all modules using the same `datasets` share the same filters. |
|
9 |
#' |
|
10 |
#' This works with nested modules of depth greater than 2, though the filter |
|
11 |
#' panel is inserted at the right of the modules at depth 1 and not at the leaves. |
|
12 |
#' |
|
13 |
#' @name module_tabs_with_filters |
|
14 |
#' |
|
15 |
#' @inheritParams module_teal |
|
16 |
#' |
|
17 |
#' @param datasets (named `list` of `FilteredData`) |
|
18 |
#' object to store filter state and filtered datasets, shared across modules. For more |
|
19 |
#' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure |
|
20 |
#' of the `modules` argument and list names must correspond to the labels in `modules`. |
|
21 |
#' When filter is not module-specific then list contains the same object in all elements. |
|
22 |
#' @param reporter (`Reporter`) object from `teal.reporter` |
|
23 |
#' |
|
24 |
#' @return |
|
25 |
#' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules. |
|
26 |
#' |
|
27 |
#' @keywords internal |
|
28 |
#' |
|
29 |
NULL |
|
30 | ||
31 |
#' @rdname module_tabs_with_filters |
|
32 |
ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) { |
|
33 | ! |
checkmate::assert_class(modules, "teal_modules") |
34 | ! |
checkmate::assert_list(datasets, types = c("list", "FilteredData")) |
35 | ! |
checkmate::assert_class(filter, "teal_slices") |
36 | ||
37 | ! |
ns <- NS(id) |
38 | ! |
is_module_specific <- isTRUE(attr(filter, "module_specific")) |
39 | ||
40 | ! |
teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific) |
41 | ! |
filter_panel_btns <- tags$li( |
42 | ! |
class = "flex-grow", |
43 | ! |
tags$button( |
44 | ! |
class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger |
45 | ! |
href = "javascript:void(0)", |
46 | ! |
onclick = "toggleFilterPanel();", # see sidebar.js |
47 | ! |
title = "Toggle filter panels", |
48 | ! |
icon("fas fa-bars") |
49 |
), |
|
50 | ! |
filter_manager_modal_ui(ns("filter_manager")) |
51 |
) |
|
52 | ! |
teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns) |
53 | ||
54 | ! |
if (!is_module_specific) { |
55 |
# need to rearrange html so that filter panel is within tabset |
|
56 | ! |
tabset_bar <- teal_ui$children[[1]] |
57 | ! |
teal_modules <- teal_ui$children[[2]] |
58 | ! |
filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel")) |
59 | ! |
list( |
60 | ! |
tabset_bar, |
61 | ! |
tags$hr(class = "my-2"), |
62 | ! |
fluidRow( |
63 | ! |
column(width = 9, teal_modules, class = "teal_primary_col"), |
64 | ! |
column(width = 3, filter_ui, class = "teal_secondary_col") |
65 |
) |
|
66 |
) |
|
67 |
} else { |
|
68 | ! |
teal_ui |
69 |
} |
|
70 |
} |
|
71 | ||
72 |
#' @rdname module_tabs_with_filters |
|
73 |
srv_tabs_with_filters <- function(id, |
|
74 |
datasets, |
|
75 |
modules, |
|
76 |
reporter = teal.reporter::Reporter$new(), |
|
77 |
filter = teal_slices()) { |
|
78 | 5x |
checkmate::assert_class(modules, "teal_modules") |
79 | 5x |
checkmate::assert_list(datasets, types = c("list", "FilteredData")) |
80 | 5x |
checkmate::assert_class(reporter, "Reporter") |
81 | 3x |
checkmate::assert_class(filter, "teal_slices") |
82 | ||
83 | 3x |
moduleServer(id, function(input, output, session) { |
84 | 3x |
logger::log_trace("srv_tabs_with_filters initializing the module.") |
85 | ||
86 | 3x |
is_module_specific <- isTRUE(attr(filter, "module_specific")) |
87 | 3x |
manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter) |
88 | ||
89 | 3x |
active_module <- srv_nested_tabs( |
90 | 3x |
id = "root", |
91 | 3x |
datasets = datasets, |
92 | 3x |
modules = modules, |
93 | 3x |
reporter = reporter, |
94 | 3x |
is_module_specific = is_module_specific |
95 |
) |
|
96 | ||
97 | 3x |
if (!is_module_specific) { |
98 | 3x |
active_datanames <- reactive({ |
99 | 6x |
if (identical(active_module()$datanames, "all")) { |
100 | ! |
singleton$datanames() |
101 |
} else { |
|
102 | 5x |
include_parent_datanames( |
103 | 5x |
active_module()$datanames, |
104 | 5x |
singleton$get_join_keys() |
105 |
) |
|
106 |
} |
|
107 |
}) |
|
108 | 3x |
singleton <- unlist(datasets)[[1]] |
109 | 3x |
singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames) |
110 | ||
111 | 3x |
observeEvent( |
112 | 3x |
eventExpr = active_datanames(), |
113 | 3x |
handlerExpr = { |
114 | 4x |
script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) { |
115 |
# hide the filter panel and disable the burger button |
|
116 | ! |
"handleNoActiveDatasets();" |
117 |
} else { |
|
118 |
# show the filter panel and enable the burger button |
|
119 | 4x |
"handleActiveDatasetsPresent();" |
120 |
} |
|
121 | 4x |
shinyjs::runjs(script) |
122 |
}, |
|
123 | 3x |
ignoreNULL = FALSE |
124 |
) |
|
125 |
} |
|
126 | ||
127 | 3x |
showNotification("Data loaded - App fully started up") |
128 | 3x |
logger::log_trace("srv_tabs_with_filters initialized the module") |
129 | ||
130 | 3x |
active_module |
131 |
}) |
|
132 |
} |
1 |
# This file adds a splash screen for delayed data loading on top of teal |
|
2 | ||
3 |
#' Add splash screen to `teal` application |
|
4 |
#' |
|
5 |
#' @description `r lifecycle::badge("stable")` |
|
6 |
#' |
|
7 |
#' Displays custom splash screen during initial delayed data loading. |
|
8 |
#' |
|
9 |
#' @details |
|
10 |
#' This module pauses app initialization pending delayed data loading. |
|
11 |
#' This is necessary because the filter panel and modules depend on the data to initialize. |
|
12 |
#' |
|
13 |
#' `teal_with_splash` follows the `shiny` module convention. |
|
14 |
#' [`init()`] is a wrapper around this that assumes that `teal` it is |
|
15 |
#' the top-level module and cannot be embedded. |
|
16 |
#' |
|
17 |
#' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module. |
|
18 |
#' but rather use `init` to create a standalone application. |
|
19 |
#' |
|
20 |
#' @seealso [init()] |
|
21 |
#' |
|
22 |
#' @param id (`character(1)`) |
|
23 |
#' module id |
|
24 |
#' @inheritParams init |
|
25 |
#' @param modules (`teal_modules`) object containing the output modules which |
|
26 |
#' will be displayed in the `teal` application. See [modules()] and [module()] for |
|
27 |
#' more details. |
|
28 |
#' @inheritParams shiny::moduleServer |
|
29 |
#' @return |
|
30 |
#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not. |
|
31 |
#' @name module_teal_with_splash |
|
32 |
#' @examples |
|
33 |
#' teal_modules <- modules(example_module()) |
|
34 |
#' # Shiny app with modular integration of teal |
|
35 |
#' ui <- fluidPage( |
|
36 |
#' ui_teal_with_splash(id = "app1", data = teal_data()) |
|
37 |
#' ) |
|
38 |
#' |
|
39 |
#' server <- function(input, output, session) { |
|
40 |
#' srv_teal_with_splash( |
|
41 |
#' id = "app1", |
|
42 |
#' data = teal_data(iris = iris), |
|
43 |
#' modules = teal_modules |
|
44 |
#' ) |
|
45 |
#' } |
|
46 |
#' |
|
47 |
#' if (interactive()) { |
|
48 |
#' shinyApp(ui, server) |
|
49 |
#' } |
|
50 |
#' |
|
51 |
NULL |
|
52 | ||
53 |
#' @export |
|
54 |
#' @rdname module_teal_with_splash |
|
55 |
ui_teal_with_splash <- function(id, |
|
56 |
data, |
|
57 |
title = build_app_title(), |
|
58 |
header = tags$p(), |
|
59 |
footer = tags$p()) { |
|
60 | 7x |
checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
61 | 7x |
checkmate::assert_multi_class(data, c("teal_data", "teal_data_module")) |
62 | 7x |
checkmate::assert( |
63 | 7x |
.var.name = "title", |
64 | 7x |
checkmate::check_string(title), |
65 | 7x |
checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html")) |
66 |
) |
|
67 | 7x |
checkmate::assert( |
68 | 7x |
.var.name = "header", |
69 | 7x |
checkmate::check_string(header), |
70 | 7x |
checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html")) |
71 |
) |
|
72 | 7x |
checkmate::assert( |
73 | 7x |
.var.name = "footer", |
74 | 7x |
checkmate::check_string(footer), |
75 | 7x |
checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html")) |
76 |
) |
|
77 | ||
78 | 7x |
ns <- NS(id) |
79 | ||
80 |
# Startup splash screen for delayed loading |
|
81 |
# We use delayed loading in all cases, even when the data does not need to be fetched. |
|
82 |
# This has the benefit that when filtering the data takes a lot of time initially, the |
|
83 |
# Shiny app does not time out. |
|
84 | 7x |
splash_ui <- if (inherits(data, "teal_data_module")) { |
85 | 1x |
data$ui(ns("teal_data_module")) |
86 | 7x |
} else if (inherits(data, "teal_data")) { |
87 | 6x |
div() |
88 |
} |
|
89 | 7x |
ui_teal( |
90 | 7x |
id = ns("teal"), |
91 | 7x |
splash_ui = div(splash_ui, uiOutput(ns("error"))), |
92 | 7x |
title = title, |
93 | 7x |
header = header, |
94 | 7x |
footer = footer |
95 |
) |
|
96 |
} |
|
97 | ||
98 |
#' @export |
|
99 |
#' @rdname module_teal_with_splash |
|
100 |
srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) { |
|
101 | 15x |
checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
102 | 15x |
checkmate::assert_multi_class(data, c("teal_data", "teal_data_module")) |
103 | 15x |
checkmate::assert_class(modules, "teal_modules") |
104 | 15x |
checkmate::assert_class(filter, "teal_slices") |
105 | ||
106 | 15x |
moduleServer(id, function(input, output, session) { |
107 | 15x |
logger::log_trace("srv_teal_with_splash initializing module with data.") |
108 | ||
109 | 15x |
if (getOption("teal.show_js_log", default = FALSE)) { |
110 | ! |
shinyjs::showLog() |
111 |
} |
|
112 | ||
113 |
# teal_data_rv contains teal_data object |
|
114 |
# either passed to teal::init or returned from teal_data_module |
|
115 | 15x |
teal_data_rv <- if (inherits(data, "teal_data_module")) { |
116 | 10x |
data <- data$server(id = "teal_data_module") |
117 | 10x |
if (!is.reactive(data)) { |
118 | 1x |
stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE) |
119 |
} |
|
120 | 9x |
data |
121 | 15x |
} else if (inherits(data, "teal_data")) { |
122 | 5x |
reactiveVal(data) |
123 |
} |
|
124 | ||
125 | 14x |
teal_data_rv_validate <- reactive({ |
126 |
# custom module can return error |
|
127 | 11x |
data <- tryCatch(teal_data_rv(), error = function(e) e) |
128 | ||
129 |
# there is an empty reactive cycle on init! |
|
130 | 11x |
if (inherits(data, "shiny.silent.error") && identical(data$message, "")) { |
131 | ! |
return(NULL) |
132 |
} |
|
133 | ||
134 |
# to handle qenv.error |
|
135 | 11x |
if (inherits(data, "qenv.error")) { |
136 | 2x |
validate( |
137 | 2x |
need( |
138 | 2x |
FALSE, |
139 | 2x |
paste( |
140 | 2x |
"Error when executing `teal_data_module` passed to `data`:\n ", |
141 | 2x |
paste(data$message, collapse = "\n"), |
142 | 2x |
"\n Check your inputs or contact app developer if error persists." |
143 |
) |
|
144 |
) |
|
145 |
) |
|
146 |
} |
|
147 | ||
148 |
# to handle module non-qenv errors |
|
149 | 9x |
if (inherits(data, "error")) { |
150 | 1x |
validate( |
151 | 1x |
need( |
152 | 1x |
FALSE, |
153 | 1x |
paste( |
154 | 1x |
"Error when executing `teal_data_module` passed to `data`:\n ", |
155 | 1x |
paste(data$message, collpase = "\n"), |
156 | 1x |
"\n Check your inputs or contact app developer if error persists." |
157 |
) |
|
158 |
) |
|
159 |
) |
|
160 |
} |
|
161 | ||
162 | 8x |
validate( |
163 | 8x |
need( |
164 | 8x |
inherits(data, "teal_data"), |
165 | 8x |
paste( |
166 | 8x |
"Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned", |
167 | 8x |
toString(sQuote(class(data))), |
168 | 8x |
"instead.", |
169 | 8x |
"\n Check your inputs or contact app developer if error persists." |
170 |
) |
|
171 |
) |
|
172 |
) |
|
173 | ||
174 | 5x |
if (!length(teal.data::datanames(data))) { |
175 | 1x |
warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.") |
176 |
} |
|
177 | ||
178 | 5x |
is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data)) |
179 | 5x |
if (!isTRUE(is_modules_ok)) { |
180 | 1x |
validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok))) |
181 |
} |
|
182 | ||
183 | 4x |
is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data)) |
184 | 4x |
if (!isTRUE(is_filter_ok)) { |
185 | 1x |
showNotification( |
186 | 1x |
"Some filters were not applied because of incompatibility with data. Contact app developer.", |
187 | 1x |
type = "warning", |
188 | 1x |
duration = 10 |
189 |
) |
|
190 | 1x |
warning(is_filter_ok) |
191 |
} |
|
192 | ||
193 | 4x |
teal_data_rv() |
194 |
}) |
|
195 | ||
196 | 14x |
output$error <- renderUI({ |
197 | ! |
teal_data_rv_validate() |
198 | ! |
NULL |
199 |
}) |
|
200 | ||
201 | ||
202 | 14x |
res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter) |
203 | 14x |
logger::log_trace("srv_teal_with_splash initialized module with data.") |
204 | ||
205 | 14x |
res |
206 |
}) |
|
207 |
} |
1 |
#' Get client timezone |
|
2 |
#' |
|
3 |
#' User timezone in the browser may be different to the one on the server. |
|
4 |
#' This script can be run to register a `shiny` input which contains information about the timezone in the browser. |
|
5 |
#' |
|
6 |
#' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server. |
|
7 |
#' For `shiny` modules this will allow for proper name spacing of the registered input. |
|
8 |
#' |
|
9 |
#' @return (`shiny`) input variable accessible with `input$tz` which is a (`character`) |
|
10 |
#' string containing the timezone of the browser/client. |
|
11 |
#' |
|
12 |
#' @keywords internal |
|
13 |
#' |
|
14 |
get_client_timezone <- function(ns) { |
|
15 | 18x |
script <- sprintf( |
16 | 18x |
"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)", |
17 | 18x |
ns("timezone") |
18 |
) |
|
19 | 18x |
shinyjs::runjs(script) # function does not return anything |
20 | 18x |
invisible(NULL) |
21 |
} |
|
22 | ||
23 |
#' Resolve the expected bootstrap theme |
|
24 |
#' @noRd |
|
25 |
#' @keywords internal |
|
26 |
get_teal_bs_theme <- function() { |
|
27 | 11x |
bs_theme <- getOption("teal.bs_theme") |
28 | 11x |
if (is.null(bs_theme)) { |
29 | 8x |
NULL |
30 | 3x |
} else if (!inherits(bs_theme, "bs_theme")) { |
31 | 2x |
warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.") |
32 | 2x |
NULL |
33 |
} else { |
|
34 | 1x |
bs_theme |
35 |
} |
|
36 |
} |
|
37 | ||
38 |
#' Return parentnames along with datanames. |
|
39 |
#' @noRd |
|
40 |
#' @keywords internal |
|
41 |
include_parent_datanames <- function(dataname, join_keys) { |
|
42 | 15x |
parents <- character(0) |
43 | 15x |
for (i in dataname) { |
44 | 22x |
while (length(i) > 0) { |
45 | 24x |
parent_i <- teal.data::parent(join_keys, i) |
46 | 24x |
parents <- c(parent_i, parents) |
47 | 24x |
i <- parent_i |
48 |
} |
|
49 |
} |
|
50 | ||
51 | 15x |
unique(c(parents, dataname)) |
52 |
} |
|
53 | ||
54 |
#' Create a `FilteredData` |
|
55 |
#' |
|
56 |
#' Create a `FilteredData` object from a `teal_data` object. |
|
57 |
#' |
|
58 |
#' @param x (`teal_data`) object |
|
59 |
#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)` |
|
60 |
#' @return A `FilteredData` object. |
|
61 |
#' @keywords internal |
|
62 |
teal_data_to_filtered_data <- function(x, datanames = teal_data_datanames(x)) { |
|
63 | 18x |
checkmate::assert_class(x, "teal_data") |
64 | 18x |
checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE) |
65 | ||
66 | 18x |
ans <- teal.slice::init_filtered_data( |
67 | 18x |
x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE), |
68 | 18x |
join_keys = teal.data::join_keys(x) |
69 |
) |
|
70 |
# Piggy-back pre-processing code for datasets of interest so that filtering code can be appended later. |
|
71 | 18x |
attr(ans, "preprocessing_code") <- teal.data::get_code(x, datanames = datanames, check_names = FALSE) |
72 | 18x |
attr(ans, "verification_status") <- x@verified |
73 | 18x |
ans |
74 |
} |
|
75 | ||
76 |
#' Template function for `TealReportCard` creation and customization |
|
77 |
#' |
|
78 |
#' This function generates a report card with a title, |
|
79 |
#' an optional description, and the option to append the filter state list. |
|
80 |
#' |
|
81 |
#' @param title (`character(1)`) title of the card (unless overwritten by label) |
|
82 |
#' @param label (`character(1)`) label provided by the user when adding the card |
|
83 |
#' @param description (`character(1)`) optional additional description |
|
84 |
#' @param with_filter (`logical(1)`) flag indicating to add filter state |
|
85 |
#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation |
|
86 |
#' of the filter state in the report |
|
87 |
#' |
|
88 |
#' @return (`TealReportCard`) populated with a title, description and filter state. |
|
89 |
#' |
|
90 |
#' @export |
|
91 |
report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) { |
|
92 | 2x |
checkmate::assert_string(title) |
93 | 2x |
checkmate::assert_string(label) |
94 | 2x |
checkmate::assert_string(description, null.ok = TRUE) |
95 | 2x |
checkmate::assert_flag(with_filter) |
96 | 2x |
checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI") |
97 | ||
98 | 2x |
card <- teal::TealReportCard$new() |
99 | 2x |
title <- if (label == "") title else label |
100 | 2x |
card$set_name(title) |
101 | 2x |
card$append_text(title, "header2") |
102 | 1x |
if (!is.null(description)) card$append_text(description, "header3") |
103 | 1x |
if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
104 | 2x |
card |
105 |
} |
|
106 | ||
107 | ||
108 |
#' Check `datanames` in modules |
|
109 |
#' |
|
110 |
#' This function ensures specified `datanames` in modules match those in the data object, |
|
111 |
#' returning error messages or `TRUE` for successful validation. |
|
112 |
#' |
|
113 |
#' @param modules (`teal_modules`) object |
|
114 |
#' @param datanames (`character`) names of datasets available in the `data` object |
|
115 |
#' |
|
116 |
#' @return A `character(1)` containing error message or `TRUE` if validation passes. |
|
117 |
#' @keywords internal |
|
118 |
check_modules_datanames <- function(modules, datanames) { |
|
119 | 12x |
checkmate::assert_class(modules, "teal_modules") |
120 | 12x |
checkmate::assert_character(datanames) |
121 | ||
122 | 12x |
recursive_check_datanames <- function(modules, datanames) { |
123 |
# check teal_modules against datanames |
|
124 | 26x |
if (inherits(modules, "teal_modules")) { |
125 | 12x |
sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames)) |
126 |
} else { |
|
127 | 14x |
extra_datanames <- setdiff(modules$datanames, c("all", datanames)) |
128 | 14x |
if (length(extra_datanames)) { |
129 | 2x |
sprintf( |
130 | 2x |
"- Module '%s' uses datanames not available in 'data': (%s) not in (%s)", |
131 | 2x |
modules$label, |
132 | 2x |
toString(dQuote(extra_datanames, q = FALSE)), |
133 | 2x |
toString(dQuote(datanames, q = FALSE)) |
134 |
) |
|
135 |
} |
|
136 |
} |
|
137 |
} |
|
138 | 12x |
check_datanames <- unlist(recursive_check_datanames(modules, datanames)) |
139 | 12x |
if (length(check_datanames)) { |
140 | 2x |
paste(check_datanames, collapse = "\n") |
141 |
} else { |
|
142 | 10x |
TRUE |
143 |
} |
|
144 |
} |
|
145 | ||
146 |
#' Check `datanames` in filters |
|
147 |
#' |
|
148 |
#' This function checks whether `datanames` in filters correspond to those in `data`, |
|
149 |
#' returning character vector with error messages or `TRUE` if all checks pass. |
|
150 |
#' |
|
151 |
#' @param filters (`teal_slices`) object |
|
152 |
#' @param datanames (`character`) names of datasets available in the `data` object |
|
153 |
#' |
|
154 |
#' @return A `character(1)` containing error message or TRUE if validation passes. |
|
155 |
#' @keywords internal |
|
156 |
check_filter_datanames <- function(filters, datanames) { |
|
157 | 10x |
checkmate::assert_class(filters, "teal_slices") |
158 | 10x |
checkmate::assert_character(datanames) |
159 | ||
160 |
# check teal_slices against datanames |
|
161 | 10x |
out <- unlist(sapply( |
162 | 10x |
filters, function(filter) { |
163 | 3x |
dataname <- shiny::isolate(filter$dataname) |
164 | 3x |
if (!dataname %in% datanames) { |
165 | 2x |
sprintf( |
166 | 2x |
"- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)", |
167 | 2x |
shiny::isolate(filter$id), |
168 | 2x |
dQuote(dataname, q = FALSE), |
169 | 2x |
toString(dQuote(datanames, q = FALSE)) |
170 |
) |
|
171 |
} |
|
172 |
} |
|
173 |
)) |
|
174 | ||
175 | ||
176 | 10x |
if (length(out)) { |
177 | 2x |
paste(out, collapse = "\n") |
178 |
} else { |
|
179 | 8x |
TRUE |
180 |
} |
|
181 |
} |
|
182 | ||
183 | ||
184 |
#' Create filterable data for modules |
|
185 |
#' |
|
186 |
#' Converts input data to a `FilteredData` object(s) to allow filtering before passing data to individual modules. |
|
187 |
#' |
|
188 |
#' @param data (`teal_data`) |
|
189 |
#' @param modules (`teal_modules`) object |
|
190 |
#' @param filters (`teal_slices`) object |
|
191 |
#' @param filtered_data_singleton A result of `teal_data_to_filtered_data` applied to `data`. |
|
192 |
#' @return Returns list of same shape as `modules`, containing `FilteredData` at every leaf. |
|
193 |
#' If module specific, each leaf contains different instance, otherwise every leaf contains `filtered_data_singleton`. |
|
194 |
#' @keywords internal |
|
195 |
modules_datasets <- function(data, modules, filters, filtered_data_singleton = teal_data_to_filtered_data(data)) { |
|
196 | 15x |
checkmate::assert_class(data, "teal_data") |
197 | 15x |
checkmate::assert_multi_class(modules, c("teal_modules", "teal_module")) |
198 | 15x |
checkmate::assert_class(filters, "modules_teal_slices") |
199 | 15x |
checkmate::assert_r6(filtered_data_singleton, "FilteredData") |
200 | ||
201 | 15x |
if (!isTRUE(attr(filters, "module_specific"))) { |
202 |
# subset global filters |
|
203 | 3x |
slices <- shiny::isolate({ |
204 | 3x |
Filter(function(x) x$id %in% attr(filters, "mapping")$global_filters, filters) |
205 |
}) |
|
206 | 3x |
filtered_data_singleton$set_filter_state(slices) |
207 | 3x |
return(modules_structure(modules, filtered_data_singleton)) |
208 |
} |
|
209 | ||
210 | 12x |
if (inherits(modules, "teal_module")) { |
211 |
# 1. get datanames |
|
212 | 7x |
datanames <- |
213 | 7x |
if (is.null(modules$datanames) || identical(modules$datanames, "all")) { |
214 | 4x |
include_parent_datanames( |
215 | 4x |
teal_data_datanames(data), |
216 | 4x |
teal.data::join_keys(data) |
217 |
) |
|
218 |
} else { |
|
219 | 3x |
include_parent_datanames( |
220 | 3x |
modules$datanames, |
221 | 3x |
teal.data::join_keys(data) |
222 |
) |
|
223 |
} |
|
224 |
# 2. subset filters (global + dedicated) |
|
225 | 7x |
slices <- shiny::isolate({ |
226 | 7x |
Filter(x = filters, f = function(x) { |
227 | 20x |
x$dataname %in% datanames && |
228 | 20x |
(x$id %in% attr(filters, "mapping")$global_filters || |
229 | 20x |
x$id %in% unique(unlist(attr(filters, "mapping")[modules$label]))) # nolint: indentation_linter. |
230 |
}) |
|
231 |
}) |
|
232 |
# 2a. subset include/exclude varnames |
|
233 | 7x |
slices$include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames] |
234 | 7x |
slices$exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames] |
235 | ||
236 |
# 3. instantiate FilteredData |
|
237 | 7x |
filtered_data <- teal_data_to_filtered_data(data, datanames) |
238 |
# 4. set state |
|
239 | 7x |
filtered_data$set_filter_state(slices) |
240 |
# 5. return |
|
241 | 7x |
return(filtered_data) |
242 | 5x |
} else if (inherits(modules, "teal_modules")) { |
243 | 5x |
ans <- lapply( |
244 | 5x |
modules$children, |
245 | 5x |
modules_datasets, |
246 | 5x |
data = data, |
247 | 5x |
filters = filters, |
248 | 5x |
filtered_data_singleton = filtered_data_singleton |
249 |
) |
|
250 | 5x |
names(ans) <- vapply(modules$children, `[[`, character(1), "label") |
251 | ||
252 | 5x |
return(ans) |
253 |
} |
|
254 | ||
255 | ! |
stop("something is not right") |
256 |
} |
|
257 | ||
258 |
# Returns nested list of same shape as `modules` with `value` at every leaf. |
|
259 |
modules_structure <- function(modules, value = TRUE) { |
|
260 | 13x |
if (inherits(modules, "teal_module")) { |
261 | 8x |
return(value) |
262 |
} else { |
|
263 | 5x |
stats::setNames( |
264 | 5x |
lapply(modules$children, modules_structure, value), |
265 | 5x |
vapply(modules$children, `[[`, character(1), "label") |
266 |
) |
|
267 |
} |
|
268 |
} |
|
269 | ||
270 |
#' Wrapper on `teal.data::datanames` |
|
271 |
#' |
|
272 |
#' Special function used in internals of `teal` to return names of datasets even if `datanames` |
|
273 |
#' has not been set. |
|
274 |
#' @param data (`teal_data`) |
|
275 |
#' @return `character` |
|
276 |
#' @keywords internal |
|
277 |
teal_data_datanames <- function(data) { |
|
278 | 53x |
checkmate::assert_class(data, "teal_data") |
279 | 53x |
if (length(teal.data::datanames(data))) { |
280 | 47x |
teal.data::datanames(data) |
281 |
} else { |
|
282 | 6x |
ls(teal.code::get_env(data), all.names = TRUE) |
283 |
} |
|
284 |
} |
|
285 | ||
286 |
#' Function for validating the title parameter of `teal::init` |
|
287 |
#' |
|
288 |
#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag. |
|
289 |
#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title. |
|
290 |
#' @keywords internal |
|
291 |
validate_app_title_tag <- function(shiny_tag) { |
|
292 | 14x |
checkmate::assert_class(shiny_tag, "shiny.tag") |
293 | 14x |
checkmate::assert_true(shiny_tag$name == "head") |
294 | 13x |
child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name") |
295 | 13x |
checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags") |
296 | 11x |
rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel |
297 | 11x |
checkmate::assert_subset( |
298 | 11x |
rel_attr, |
299 | 11x |
c("icon", "shortcut icon"), |
300 | 11x |
.var.name = "Link tag's rel attribute", |
301 | 11x |
empty.ok = FALSE |
302 |
) |
|
303 |
} |
|
304 | ||
305 |
#' Build app title with favicon |
|
306 |
#' |
|
307 |
#' A helper function to create the browser title along with a logo. |
|
308 |
#' |
|
309 |
#' @param title (`character`) The browser title for the `teal` app. |
|
310 |
#' @param favicon (`character`) The path for the icon for the title. |
|
311 |
#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/` |
|
312 |
#' |
|
313 |
#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app. |
|
314 |
#' @export |
|
315 |
build_app_title <- function( |
|
316 |
title = "teal app", |
|
317 |
favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") { |
|
318 | 11x |
checkmate::assert_string(title, null.ok = TRUE) |
319 | 11x |
checkmate::assert_string(favicon, null.ok = TRUE) |
320 | 11x |
tags$head( |
321 | 11x |
tags$title(title), |
322 | 11x |
tags$link( |
323 | 11x |
rel = "icon", |
324 | 11x |
href = favicon, |
325 | 11x |
sizes = "any" |
326 |
) |
|
327 |
) |
|
328 |
} |
|
329 | ||
330 |
#' Application ID |
|
331 |
#' |
|
332 |
#' Creates App ID used to match filter snapshots to application. |
|
333 |
#' |
|
334 |
#' Calculate app ID that will be used to stamp filter state snapshots. |
|
335 |
#' App ID is a hash of the app's data and modules. |
|
336 |
#' See "transferring snapshots" section in ?snapshot. |
|
337 |
#' |
|
338 |
#' @param data (`teal_data` or `teal_data_module`) as accepted by `init` |
|
339 |
#' @param modules (`teal_modules`) object as accepted by `init` |
|
340 |
#' |
|
341 |
#' @return A single character string. |
|
342 |
#' |
|
343 |
#' @keywords internal |
|
344 |
create_app_id <- function(data, modules) { |
|
345 | 19x |
checkmate::assert_multi_class(data, c("teal_data", "teal_data_module")) |
346 | 18x |
checkmate::assert_class(modules, "teal_modules") |
347 | ||
348 | 17x |
data <- if (inherits(data, "teal_data")) { |
349 | 15x |
as.list(data@env) |
350 | 17x |
} else if (inherits(data, "teal_data_module")) { |
351 | 2x |
deparse1(body(data$server)) |
352 |
} |
|
353 | 17x |
modules <- lapply(modules, defunction) |
354 | ||
355 | 17x |
rlang::hash(list(data = data, modules = modules)) |
356 |
} |
|
357 | ||
358 |
#' Go through list and extract bodies of encountered functions as string, recursively. |
|
359 |
#' @keywords internal |
|
360 |
#' @noRd |
|
361 |
defunction <- function(x) { |
|
362 | 186x |
if (is.list(x)) { |
363 | 40x |
lapply(x, defunction) |
364 | 146x |
} else if (is.function(x)) { |
365 | 44x |
deparse1(body(x)) |
366 |
} else { |
|
367 | 102x |
x |
368 |
} |
|
369 |
} |
1 |
#' Store and restore `teal_slices` object |
|
2 |
#' |
|
3 |
#' Functions that write a `teal_slices` object to a file in the `JSON` format, |
|
4 |
#' and also restore the object from disk. |
|
5 |
#' |
|
6 |
#' Date and date time objects are stored in the following formats: |
|
7 |
#' |
|
8 |
#' - `Date` class is converted to the `"ISO8601"` standard (`YYYY-MM-DD`). |
|
9 |
#' - `POSIX*t` classes are converted to character by using |
|
10 |
#' `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD HH:MM:SS UTC`, where |
|
11 |
#' `UTC` is the `Coordinated Universal Time` timezone short-code). |
|
12 |
#' |
|
13 |
#' This format is assumed during `slices_restore`. All `POSIX*t` objects in |
|
14 |
#' `selected` or `choices` fields of `teal_slice` objects are always printed in |
|
15 |
#' `UTC` timezone as well. |
|
16 |
#' |
|
17 |
#' @param tss (`teal_slices`) object to be stored. |
|
18 |
#' @param file (`character(1)`) file path where `teal_slices` object will be |
|
19 |
#' saved and restored. The file extension should be `".json"`. |
|
20 |
#' |
|
21 |
#' @return `slices_store` returns `NULL`, invisibly. |
|
22 |
#' |
|
23 |
#' @seealso [teal_slices()] |
|
24 |
#' |
|
25 |
#' @keywords internal |
|
26 |
#' |
|
27 |
slices_store <- function(tss, file) { |
|
28 | 9x |
checkmate::assert_class(tss, "teal_slices") |
29 | 9x |
checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json") |
30 | ||
31 | 9x |
cat(format(tss, trim_lines = FALSE), "\n", file = file) |
32 |
} |
|
33 | ||
34 |
#' @rdname slices_store |
|
35 |
#' @return `slices_restore` returns a `teal_slices` object restored from the file. |
|
36 |
#' @keywords internal |
|
37 |
slices_restore <- function(file) { |
|
38 | 9x |
checkmate::assert_file_exists(file, access = "r", extension = "json") |
39 | ||
40 | 9x |
tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE) |
41 | 9x |
tss_json$slices <- |
42 | 9x |
lapply(tss_json$slices, function(slice) { |
43 | 9x |
for (field in c("selected", "choices")) { |
44 | 18x |
if (!is.null(slice[[field]])) { |
45 | 12x |
if (length(slice[[field]]) > 0) { |
46 | 9x |
date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}" |
47 | 9x |
time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$") |
48 | ||
49 | 9x |
slice[[field]] <- |
50 | 9x |
if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) { |
51 | 3x |
as.Date(slice[[field]]) |
52 | 9x |
} else if (all(grepl(time_stamp_regex, slice[[field]]))) { |
53 | 3x |
as.POSIXct(slice[[field]], tz = "UTC") |
54 |
} else { |
|
55 | 3x |
slice[[field]] |
56 |
} |
|
57 |
} else { |
|
58 | 3x |
slice[[field]] <- character(0) |
59 |
} |
|
60 |
} |
|
61 |
} |
|
62 | 9x |
slice |
63 |
}) |
|
64 | ||
65 | 9x |
tss_elements <- lapply(tss_json$slices, as.teal_slice) |
66 | ||
67 | 9x |
do.call(teal_slices, c(tss_elements, tss_json$attributes)) |
68 |
} |
1 |
#' Validate that dataset has a minimum number of observations |
|
2 |
#' |
|
3 |
#' `r lifecycle::badge("stable")` |
|
4 |
#' |
|
5 |
#' This function is a wrapper for `shiny::validate`. |
|
6 |
#' |
|
7 |
#' @param x (`data.frame`) |
|
8 |
#' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`. |
|
9 |
#' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`. |
|
10 |
#' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`. |
|
11 |
#' @param msg (`character(1)`) Additional message to display alongside the default message. |
|
12 |
#' |
|
13 |
#' @export |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' library(teal) |
|
17 |
#' ui <- fluidPage( |
|
18 |
#' sliderInput("len", "Max Length of Sepal", |
|
19 |
#' min = 4.3, max = 7.9, value = 5 |
|
20 |
#' ), |
|
21 |
#' plotOutput("plot") |
|
22 |
#' ) |
|
23 |
#' |
|
24 |
#' server <- function(input, output) { |
|
25 |
#' output$plot <- renderPlot({ |
|
26 |
#' iris_df <- iris[iris$Sepal.Length <= input$len, ] |
|
27 |
#' validate_has_data( |
|
28 |
#' iris_df, |
|
29 |
#' min_nrow = 10, |
|
30 |
#' complete = FALSE, |
|
31 |
#' msg = "Please adjust Max Length of Sepal" |
|
32 |
#' ) |
|
33 |
#' |
|
34 |
#' hist(iris_df$Sepal.Length, breaks = 5) |
|
35 |
#' }) |
|
36 |
#' } |
|
37 |
#' if (interactive()) { |
|
38 |
#' shinyApp(ui, server) |
|
39 |
#' } |
|
40 |
#' |
|
41 |
validate_has_data <- function(x, |
|
42 |
min_nrow = NULL, |
|
43 |
complete = FALSE, |
|
44 |
allow_inf = TRUE, |
|
45 |
msg = NULL) { |
|
46 | 17x |
checkmate::assert_string(msg, null.ok = TRUE) |
47 | 15x |
checkmate::assert_data_frame(x) |
48 | 15x |
if (!is.null(min_nrow)) { |
49 | 15x |
if (complete) { |
50 | 5x |
complete_index <- stats::complete.cases(x) |
51 | 5x |
validate(need( |
52 | 5x |
sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow, |
53 | 5x |
paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n") |
54 |
)) |
|
55 |
} else { |
|
56 | 10x |
validate(need( |
57 | 10x |
nrow(x) >= min_nrow, |
58 | 10x |
paste( |
59 | 10x |
c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg), |
60 | 10x |
collapse = "\n" |
61 |
) |
|
62 |
)) |
|
63 |
} |
|
64 | ||
65 | 10x |
if (!allow_inf) { |
66 | 6x |
validate(need( |
67 | 6x |
all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))), |
68 | 6x |
"Dataframe contains Inf values which is not allowed." |
69 |
)) |
|
70 |
} |
|
71 |
} |
|
72 |
} |
|
73 | ||
74 |
#' Validate that dataset has unique rows for key variables |
|
75 |
#' |
|
76 |
#' `r lifecycle::badge("stable")` |
|
77 |
#' |
|
78 |
#' This function is a wrapper for `shiny::validate`. |
|
79 |
#' |
|
80 |
#' @param x (`data.frame`) |
|
81 |
#' @param key (`character`) Vector of ID variables from `x` that identify unique records. |
|
82 |
#' |
|
83 |
#' @export |
|
84 |
#' |
|
85 |
#' @examples |
|
86 |
#' iris$id <- rep(1:50, times = 3) |
|
87 |
#' ui <- fluidPage( |
|
88 |
#' selectInput( |
|
89 |
#' inputId = "species", |
|
90 |
#' label = "Select species", |
|
91 |
#' choices = c("setosa", "versicolor", "virginica"), |
|
92 |
#' selected = "setosa", |
|
93 |
#' multiple = TRUE |
|
94 |
#' ), |
|
95 |
#' plotOutput("plot") |
|
96 |
#' ) |
|
97 |
#' server <- function(input, output) { |
|
98 |
#' output$plot <- renderPlot({ |
|
99 |
#' iris_f <- iris[iris$Species %in% input$species, ] |
|
100 |
#' validate_one_row_per_id(iris_f, key = c("id")) |
|
101 |
#' |
|
102 |
#' hist(iris_f$Sepal.Length, breaks = 5) |
|
103 |
#' }) |
|
104 |
#' } |
|
105 |
#' if (interactive()) { |
|
106 |
#' shinyApp(ui, server) |
|
107 |
#' } |
|
108 |
#' |
|
109 |
validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) { |
|
110 | ! |
validate(need(!any(duplicated(x[key])), paste("Found more than one row per id."))) |
111 |
} |
|
112 | ||
113 |
#' Validates that vector includes all expected values |
|
114 |
#' |
|
115 |
#' `r lifecycle::badge("stable")` |
|
116 |
#' |
|
117 |
#' This function is a wrapper for `shiny::validate`. |
|
118 |
#' |
|
119 |
#' @param x Vector of values to test. |
|
120 |
#' @param choices Vector to test against. |
|
121 |
#' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`. |
|
122 |
#' |
|
123 |
#' @export |
|
124 |
#' |
|
125 |
#' @examples |
|
126 |
#' ui <- fluidPage( |
|
127 |
#' selectInput( |
|
128 |
#' "species", |
|
129 |
#' "Select species", |
|
130 |
#' choices = c("setosa", "versicolor", "virginica", "unknown species"), |
|
131 |
#' selected = "setosa", |
|
132 |
#' multiple = FALSE |
|
133 |
#' ), |
|
134 |
#' verbatimTextOutput("summary") |
|
135 |
#' ) |
|
136 |
#' |
|
137 |
#' server <- function(input, output) { |
|
138 |
#' output$summary <- renderPrint({ |
|
139 |
#' validate_in(input$species, iris$Species, "Species does not exist.") |
|
140 |
#' nrow(iris[iris$Species == input$species, ]) |
|
141 |
#' }) |
|
142 |
#' } |
|
143 |
#' if (interactive()) { |
|
144 |
#' shinyApp(ui, server) |
|
145 |
#' } |
|
146 |
#' |
|
147 |
validate_in <- function(x, choices, msg) { |
|
148 | ! |
validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg)) |
149 |
} |
|
150 | ||
151 |
#' Validates that vector has length greater than 0 |
|
152 |
#' |
|
153 |
#' `r lifecycle::badge("stable")` |
|
154 |
#' |
|
155 |
#' This function is a wrapper for `shiny::validate`. |
|
156 |
#' |
|
157 |
#' @param x vector |
|
158 |
#' @param msg message to display |
|
159 |
#' |
|
160 |
#' @export |
|
161 |
#' |
|
162 |
#' @examples |
|
163 |
#' data <- data.frame( |
|
164 |
#' id = c(1:10, 11:20, 1:10), |
|
165 |
#' strata = rep(c("A", "B"), each = 15) |
|
166 |
#' ) |
|
167 |
#' ui <- fluidPage( |
|
168 |
#' selectInput("ref1", "Select strata1 to compare", |
|
169 |
#' choices = c("A", "B", "C"), selected = "A" |
|
170 |
#' ), |
|
171 |
#' selectInput("ref2", "Select strata2 to compare", |
|
172 |
#' choices = c("A", "B", "C"), selected = "B" |
|
173 |
#' ), |
|
174 |
#' verbatimTextOutput("arm_summary") |
|
175 |
#' ) |
|
176 |
#' |
|
177 |
#' server <- function(input, output) { |
|
178 |
#' output$arm_summary <- renderText({ |
|
179 |
#' sample_1 <- data$id[data$strata == input$ref1] |
|
180 |
#' sample_2 <- data$id[data$strata == input$ref2] |
|
181 |
#' |
|
182 |
#' validate_has_elements(sample_1, "No subjects in strata1.") |
|
183 |
#' validate_has_elements(sample_2, "No subjects in strata2.") |
|
184 |
#' |
|
185 |
#' paste0( |
|
186 |
#' "Number of samples in: strata1=", length(sample_1), |
|
187 |
#' " comparions strata2=", length(sample_2) |