1 |
#' Convert content into a `flextable` |
|
2 |
#' |
|
3 |
#' Converts supported table formats into a `flextable` for enhanced formatting and presentation. |
|
4 |
#' |
|
5 |
#' Function merges cells with `colspan` > 1, |
|
6 |
#' aligns columns to the center and row names to the left, |
|
7 |
#' indents the row names by 10 times indentation. |
|
8 |
#' |
|
9 |
#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df` |
|
10 |
#' |
|
11 |
#' @return `flextable`. |
|
12 |
#' |
|
13 |
#' @keywords internal |
|
14 |
to_flextable <- function(content) { |
|
15 | 86x |
if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) { |
16 | 42x |
ft <- rtables.officer::tt_to_flextable(content) |
17 | 44x |
} else if (inherits(content, "listing_df")) { |
18 | 1x |
mf <- rlistings::matrix_form(content) |
19 | 1x |
nr_header <- attr(mf, "nrow_header") |
20 | 1x |
df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE]) |
21 | 1x |
header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE]) |
22 | ||
23 | 1x |
ft <- rtables::df_to_tt(df) |
24 | 1x |
if (length(mf$main_title) != 0) { |
25 | ! |
rtables::main_title(ft) <- mf$main_title |
26 |
} |
|
27 | 1x |
rtables::subtitles(ft) <- mf$subtitles |
28 | 1x |
rtables::main_footer(ft) <- mf$main_footer |
29 | 1x |
rtables::prov_footer(ft) <- mf$prov_footer |
30 | 1x |
rtables::header_section_div(ft) <- mf$header_section_div |
31 | 1x |
ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1)) |
32 | 43x |
} else if (inherits(content, "data.frame")) { |
33 | 42x |
ft <- if (nrow(content) == 0) { |
34 | ! |
flextable::flextable(content) |
35 |
} else { |
|
36 | 42x |
rtables.officer::tt_to_flextable( |
37 | 42x |
rtables::df_to_tt(content) |
38 |
) |
|
39 |
} |
|
40 |
} else { |
|
41 | 1x |
stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table")) |
42 |
} |
|
43 | ||
44 | 85x |
ft |
45 |
} |
|
46 | ||
47 |
#' Divide text block into smaller blocks |
|
48 |
#' |
|
49 |
#' Split a text block into smaller blocks with a specified number of lines. |
|
50 |
#' |
|
51 |
#' A single character string containing a text block of multiple lines (separated by `\n`) |
|
52 |
#' is split into multiple strings with n or less lines each. |
|
53 |
#' |
|
54 |
#' @param x (`character`) string containing the input block of text |
|
55 |
#' @param n (`integer`) number of lines per block |
|
56 |
#' |
|
57 |
#' @return |
|
58 |
#' List of character strings with up to `n` lines in each element. |
|
59 |
#' |
|
60 |
#' @keywords internal |
|
61 |
split_text_block <- function(x, n) { |
|
62 | 2x |
checkmate::assert_string(x) |
63 | 2x |
checkmate::assert_integerish(n, lower = 1L, len = 1L) |
64 | ||
65 | 2x |
lines <- strsplit(x, "\n")[[1]] |
66 | ||
67 | 2x |
if (length(lines) <= n) { |
68 | 1x |
return(list(x)) |
69 |
} |
|
70 | ||
71 | 1x |
nblocks <- ceiling(length(lines) / n) |
72 | 1x |
ind <- rep(1:nblocks, each = n)[seq_along(lines)] |
73 | 1x |
unname(lapply(split(lines, ind), paste, collapse = "\n")) |
74 |
} |
|
75 | ||
76 |
#' Retrieve text details for global_knitr options |
|
77 |
#' This function returns a character string describing the default settings for the global_knitr options. |
|
78 |
#' @noRd |
|
79 |
#' @keywords internal |
|
80 |
global_knitr_details <- function() { |
|
81 | 1x |
paste0( |
82 | 1x |
c( |
83 | 1x |
" To access the default values for the `global_knitr` parameter,", |
84 | 1x |
" use `getOption('teal.reporter.global_knitr')`. These defaults include:", |
85 | 1x |
" - `echo = TRUE`", |
86 | 1x |
" - `tidy.opts = list(width.cutoff = 60)`", |
87 | 1x |
" - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise" |
88 |
), |
|
89 | 1x |
collapse = "\n" |
90 |
) |
|
91 |
} |
|
92 | ||
93 |
#' @export |
|
94 |
#' @keywords internal |
|
95 |
format.code_chunk <- function(x, ...) { |
|
96 | 90x |
language <- attr(x, "lang", exact = TRUE) |
97 | 90x |
params <- attr(x, "params", exact = TRUE) |
98 | 90x |
if (language %in% names(knitr::knit_engines$get())) { |
99 | 89x |
sprintf( |
100 | 89x |
"```{%s}\n%s\n```", |
101 | 89x |
toString(c(language, paste(names(params), params, sep = "="))), |
102 | 89x |
NextMethod() |
103 |
) |
|
104 |
} else { |
|
105 | 1x |
sprintf("```%s\n%s\n```", language, NextMethod()) |
106 |
} |
|
107 |
} |
|
108 | ||
109 |
#' Teal action button that is disabled while busy |
|
110 |
#' |
|
111 |
#' @inheritParams bslib::input_task_button |
|
112 |
#' @param id (`character(1)`) the id of the button. |
|
113 |
#' @param label (`character(1)`) the label of the button. |
|
114 |
#' @param icon (`character(1)` or `NULL`) the name of the Bootstrap icon to be |
|
115 |
#' displayed on the button. |
|
116 |
#' @param additional_class (`character(1)` or `NULL`) additional CSS class to be |
|
117 |
#' added to the button. |
|
118 |
#' |
|
119 |
#' @return A `shiny` action button that is disabled while busy. |
|
120 |
#' @keywords internal |
|
121 |
.action_button_busy <- function(id, |
|
122 |
label, |
|
123 |
icon = NULL, |
|
124 |
type = "primary", |
|
125 |
outline = FALSE, |
|
126 |
additional_class = NULL) { |
|
127 | ! |
checkmate::assert_string(type) |
128 | ! |
checkmate::assert_string(additional_class, null.ok = TRUE) |
129 | ! |
shiny::tagList( |
130 | ! |
shinyjs::useShinyjs(), |
131 | ! |
.custom_css_dependency("outline_button.css"), |
132 | ! |
.custom_js_dependency("busy-disable.js", name = "teal-reporter-busy-disable"), |
133 | ! |
shiny::tags$button( |
134 | ! |
id = id, |
135 | ! |
class = c( |
136 | ! |
"teal-reporter action-button teal-reporter-busy-disable", |
137 | ! |
sprintf("btn btn-%1$s %1$s", trimws(type)), |
138 | ! |
if (isTRUE(outline)) "outline-button", |
139 | ! |
additional_class |
140 |
), |
|
141 | ! |
role = "button", |
142 | ! |
style = "text-decoration: none;", |
143 | ! |
if (!is.null(icon)) { |
144 | ! |
margin_style <- ifelse(is.null(label), "margin: 0 10px 0 10px;", "") |
145 | ! |
shiny::tags$span( |
146 | ! |
style = margin_style, |
147 | ! |
bsicons::bs_icon(icon, class = sprintf("text-%s", type)) |
148 |
) |
|
149 |
}, |
|
150 | ! |
label |
151 |
) |
|
152 |
) |
|
153 |
} |
|
154 | ||
155 |
#' @keywords internal |
|
156 |
.custom_js_dependency <- function(script, name = sprintf("teal-reporter-%s", script)) { |
|
157 | 2x |
htmltools::htmlDependency( |
158 | 2x |
name = name, |
159 | 2x |
version = utils::packageVersion("teal.reporter"), |
160 | 2x |
package = "teal.reporter", |
161 | 2x |
src = "js", |
162 | 2x |
script = script |
163 |
) |
|
164 |
} |
|
165 | ||
166 |
#' @keywords internal |
|
167 |
.custom_css_dependency <- function(stylesheet = "custom.css", name = sprintf("teal-reporter-%s", stylesheet)) { |
|
168 | 22x |
checkmate::assert_string(stylesheet) |
169 | 22x |
htmltools::htmlDependency( |
170 | 22x |
name = name, |
171 | 22x |
version = utils::packageVersion("teal.reporter"), |
172 | 22x |
package = "teal.reporter", |
173 | 22x |
src = "css", |
174 | 22x |
stylesheet = stylesheet |
175 |
) |
|
176 |
} |
|
177 | ||
178 |
#' @keywords internal |
|
179 |
.accordion_toggle_js_dependency <- function() { # nolint object_length_linter. |
|
180 | 2x |
.custom_js_dependency("accordion-toggle.js", name = "teal-reporter-accordion-toggle") |
181 |
} |
|
182 | ||
183 |
#' @noRd |
|
184 |
dummy <- function() { |
|
185 | 1x |
R6::R6Class # Used to trick R CMD check for avoiding NOTE about R6 |
186 | 1x |
jsonlite::fromJSON # Used to trick R CMD check for not detecting jsonlite usage |
187 |
} |
1 |
#' Mark strings for quotation in `yaml` serialization |
|
2 |
#' |
|
3 |
#' This function is designed for use with the `yaml` package to explicitly, |
|
4 |
#' It adds an attribute to character strings, indicating that they should be serialized with double quotes. |
|
5 |
#' |
|
6 |
#' @param x (`character`) |
|
7 |
#' @keywords internal |
|
8 |
#' @examples |
|
9 |
#' library(yaml) |
|
10 |
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") |
|
11 |
#' yaml <- list( |
|
12 |
#' author = yaml_quoted("NEST"), |
|
13 |
#' title = yaml_quoted("Report"), |
|
14 |
#' date = yaml_quoted("07/04/2019"), |
|
15 |
#' output = list(pdf_document = list(keep_tex = TRUE)) |
|
16 |
#' ) |
|
17 |
#' as.yaml(yaml) |
|
18 |
yaml_quoted <- function(x) { |
|
19 | 2x |
attr(x, "quoted") <- TRUE |
20 | 2x |
x |
21 |
} |
|
22 | ||
23 |
#' Create `markdown` header from `yaml` string |
|
24 |
#' |
|
25 |
#' This function wraps a `yaml`-formatted string in Markdown header delimiters. |
|
26 |
#' |
|
27 |
#' @param x (`character`) `yaml` formatted string. |
|
28 |
#' @keywords internal |
|
29 |
#' @examples |
|
30 |
#' library(yaml) |
|
31 |
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") |
|
32 |
#' yaml <- list( |
|
33 |
#' author = yaml_quoted("NEST"), |
|
34 |
#' title = yaml_quoted("Report"), |
|
35 |
#' date = yaml_quoted("07/04/2019"), |
|
36 |
#' output = list(pdf_document = list(keep_tex = TRUE)) |
|
37 |
#' ) |
|
38 |
#' md_header <- getFromNamespace("md_header", "teal.reporter") |
|
39 |
#' md_header(as.yaml(yaml)) |
|
40 |
md_header <- function(x) { |
|
41 | 21x |
paste0("---\n", x, "---\n") |
42 |
} |
|
43 | ||
44 |
#' Convert `yaml` representation of a boolean strings to logical Values |
|
45 |
#' |
|
46 |
#' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`. |
|
47 |
#' |
|
48 |
#' @param input (`character(1)`) |
|
49 |
#' @param name (`charcter(1)`) |
|
50 |
#' @param pos_logi (`character`) vector of `yaml` values which should be treated as `TRUE`. |
|
51 |
#' @param neg_logi (`character`) vector of `yaml` values which should be treated as `FALSE`. |
|
52 |
#' @param silent (`logical(1)`) if to suppress the messages and warnings. |
|
53 |
#' @return `input` argument or the appropriate `logical` value. |
|
54 |
#' @keywords internal |
|
55 |
#' @examples |
|
56 |
#' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter") |
|
57 |
#' conv_str_logi("TRUE") |
|
58 |
#' conv_str_logi("True") |
|
59 |
#' |
|
60 |
#' conv_str_logi("off") |
|
61 |
#' conv_str_logi("n") |
|
62 |
#' |
|
63 |
#' conv_str_logi("sth") |
|
64 |
conv_str_logi <- function(input, |
|
65 |
name = "", |
|
66 |
pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"), |
|
67 |
neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"), |
|
68 |
silent = TRUE) { |
|
69 | 18x |
checkmate::assert_string(input) |
70 | 17x |
checkmate::assert_string(name) |
71 | 17x |
checkmate::assert_character(pos_logi) |
72 | 17x |
checkmate::assert_character(neg_logi) |
73 | 17x |
checkmate::assert_flag(silent) |
74 | ||
75 | 17x |
all_logi <- c(pos_logi, neg_logi) |
76 | 17x |
if (input %in% all_logi) { |
77 | 15x |
if (isFALSE(silent)) { |
78 | ! |
message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input)) |
79 |
} |
|
80 | 15x |
input %in% pos_logi |
81 |
} else { |
|
82 | 2x |
input |
83 |
} |
|
84 |
} |
|
85 | ||
86 |
#' Get document output types from the `rmarkdown` package |
|
87 |
#' |
|
88 |
#' @description |
|
89 |
#' |
|
90 |
#' Retrieves vector of available document output types from the `rmarkdown` package, |
|
91 |
#' such as `pdf_document`, `html_document`, etc. |
|
92 |
#' |
|
93 |
#' @return `character` vector. |
|
94 |
#' @export |
|
95 |
#' @examples |
|
96 |
#' rmd_outputs() |
|
97 |
rmd_outputs <- function() { |
|
98 | 25x |
rmarkdown_namespace <- asNamespace("rmarkdown") |
99 | 25x |
ls(rmarkdown_namespace)[grep("_document|_presentation", ls(rmarkdown_namespace))] |
100 |
} |
|
101 | ||
102 |
#' Get document output arguments from the `rmarkdown` package |
|
103 |
#' |
|
104 |
#' @description |
|
105 |
#' |
|
106 |
#' Retrieves the arguments for a specified document output type from the `rmarkdown` package. |
|
107 |
#' |
|
108 |
#' @param output_name (`character`) `rmarkdown` output name. |
|
109 |
#' @param default_values (`logical(1)`) if to return a default values for each argument. |
|
110 |
#' @export |
|
111 |
#' @examples |
|
112 |
#' rmd_output_arguments("pdf_document") |
|
113 |
#' rmd_output_arguments("pdf_document", TRUE) |
|
114 |
rmd_output_arguments <- function(output_name, default_values = FALSE) { |
|
115 | 24x |
checkmate::assert_string(output_name) |
116 | 24x |
checkmate::assert_subset(output_name, rmd_outputs()) |
117 | ||
118 | 23x |
rmarkdown_namespace <- asNamespace("rmarkdown") |
119 | 23x |
if (default_values) { |
120 | 21x |
formals(rmarkdown_namespace[[output_name]]) |
121 |
} else { |
|
122 | 2x |
names(formals(rmarkdown_namespace[[output_name]])) |
123 |
} |
|
124 |
} |
|
125 | ||
126 |
#' Parse a named list to `yaml` header for an `Rmd` file |
|
127 |
#' |
|
128 |
#' @description |
|
129 |
#' |
|
130 |
#' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments |
|
131 |
#' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers. |
|
132 |
#' |
|
133 |
#' @details |
|
134 |
#' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document. |
|
135 |
#' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`, |
|
136 |
#' `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`. |
|
137 |
#' Additionally, it handles `output` field types and arguments as defined in the `rmarkdown` package. |
|
138 |
#' |
|
139 |
#' @note Only non-nested lists are automatically parsed. |
|
140 |
#' Nested lists require direct processing with `yaml::as.yaml`. |
|
141 |
#' |
|
142 |
#' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header. |
|
143 |
#' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`. |
|
144 |
#' @param convert_logi (`logical(1)`) convert a character values to logical, |
|
145 |
#' if they are recognized as quoted `yaml` logical values , default `TRUE`. |
|
146 |
#' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`. |
|
147 |
#' @param silent (`logical(1)`) suppress messages and warnings, default `FALSE`. |
|
148 |
#' @return `character` with `rmd_yaml_header` class, |
|
149 |
#' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`. |
|
150 |
#' @export |
|
151 |
#' @examples |
|
152 |
#' # nested so using yaml::as.yaml directly |
|
153 |
#' as_yaml_auto( |
|
154 |
#' list(author = "", output = list(pdf_document = list(toc = TRUE))) |
|
155 |
#' ) |
|
156 |
#' |
|
157 |
#' # auto parsing for a flat list, like shiny input |
|
158 |
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE) |
|
159 |
#' as_yaml_auto(input) |
|
160 |
#' |
|
161 |
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE")) |
|
162 |
#' |
|
163 |
#' as_yaml_auto(list( |
|
164 |
#' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE, |
|
165 |
#' wrong = 2 |
|
166 |
#' )) |
|
167 |
#' |
|
168 |
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2), |
|
169 |
#' silent = TRUE |
|
170 |
#' ) |
|
171 |
#' |
|
172 |
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True") |
|
173 |
#' as_yaml_auto(input) |
|
174 |
#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE) |
|
175 |
#' as_yaml_auto(input, silent = TRUE) |
|
176 |
#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE) |
|
177 |
#' |
|
178 |
#' as_yaml_auto( |
|
179 |
#' list( |
|
180 |
#' author = "", output = "pdf_document", |
|
181 |
#' output = "html_document", toc = TRUE, keep_tex = TRUE |
|
182 |
#' ), |
|
183 |
#' multi_output = TRUE |
|
184 |
#' ) |
|
185 |
#' as_yaml_auto( |
|
186 |
#' list( |
|
187 |
#' author = "", output = "pdf_document", |
|
188 |
#' output = "html_document", toc = "True", keep_tex = TRUE |
|
189 |
#' ), |
|
190 |
#' multi_output = TRUE |
|
191 |
#' ) |
|
192 |
as_yaml_auto <- function(input_list, |
|
193 |
as_header = TRUE, |
|
194 |
convert_logi = TRUE, |
|
195 |
multi_output = FALSE, |
|
196 |
silent = FALSE) { |
|
197 | 25x |
checkmate::assert_logical(as_header) |
198 | 25x |
checkmate::assert_logical(convert_logi) |
199 | 25x |
checkmate::assert_logical(silent) |
200 | 25x |
checkmate::assert_logical(multi_output) |
201 | ||
202 | 25x |
if (multi_output) { |
203 | 1x |
checkmate::assert_list(input_list, names = "named") |
204 |
} else { |
|
205 | 24x |
checkmate::assert_list(input_list, names = "unique") |
206 |
} |
|
207 | ||
208 | 22x |
is_nested <- function(x) any(unlist(lapply(x, is.list))) |
209 | 22x |
if (is_nested(input_list)) { |
210 | 2x |
result <- input_list |
211 |
} else { |
|
212 | 20x |
result <- list() |
213 | 20x |
input_nams <- names(input_list) |
214 | ||
215 |
# top fields |
|
216 | 20x |
top_fields <- c( |
217 | 20x |
"author", "date", "title", "subtitle", "abstract", |
218 | 20x |
"keywords", "subject", "description", "category", "lang" |
219 |
) |
|
220 | 20x |
for (itop in top_fields) { |
221 | 200x |
if (itop %in% input_nams) { |
222 | 27x |
result[[itop]] <- switch(itop, |
223 | 27x |
date = as.character(input_list[[itop]]), |
224 | 27x |
input_list[[itop]] |
225 |
) |
|
226 |
} |
|
227 |
} |
|
228 | ||
229 |
# output field |
|
230 | 20x |
doc_types <- unlist(input_list[input_nams == "output"]) |
231 | 20x |
if (length(doc_types)) { |
232 | 18x |
for (dtype in doc_types) { |
233 | 19x |
doc_type_args <- rmd_output_arguments(dtype, TRUE) |
234 | 19x |
doc_type_args_nams <- names(doc_type_args) |
235 | 19x |
any_output_arg <- any(input_nams %in% doc_type_args_nams) |
236 | ||
237 | 19x |
not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output")) |
238 | 19x |
if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) { |
239 | 1x |
warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", "))) |
240 |
} |
|
241 | ||
242 | 19x |
if (any_output_arg) { |
243 | 11x |
doc_list <- list() |
244 | 11x |
doc_list[[dtype]] <- list() |
245 | 11x |
for (e in intersect(input_nams, doc_type_args_nams)) { |
246 | 17x |
if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) { |
247 | 1x |
pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on") |
248 | 1x |
neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off") |
249 | 1x |
all_logi <- c(pos_logi, neg_logi) |
250 | 1x |
if (input_list[[e]] %in% all_logi && convert_logi) { |
251 | 1x |
input_list[[e]] <- conv_str_logi(input_list[[e]], e, |
252 | 1x |
pos_logi = pos_logi, |
253 | 1x |
neg_logi = neg_logi, silent = silent |
254 |
) |
|
255 |
} |
|
256 |
} |
|
257 | ||
258 | 17x |
doc_list[[dtype]][[e]] <- input_list[[e]] |
259 |
} |
|
260 | 11x |
result[["output"]] <- append(result[["output"]], doc_list) |
261 |
} else { |
|
262 | 8x |
result[["output"]] <- append(result[["output"]], input_list[["output"]]) |
263 |
} |
|
264 |
} |
|
265 |
} |
|
266 |
} |
|
267 | ||
268 | 22x |
result <- yaml::as.yaml(result) |
269 | 22x |
if (as_header) { |
270 | 21x |
result <- md_header(result) |
271 |
} |
|
272 | 22x |
structure(result, class = "rmd_yaml_header") |
273 |
} |
|
274 | ||
275 |
#' Print method for the `yaml_header` class |
|
276 |
#' |
|
277 |
#' @param x (`rmd_yaml_header`) class object. |
|
278 |
#' @param ... optional text. |
|
279 |
#' @return `NULL`. |
|
280 |
#' @exportS3Method |
|
281 |
#' @examples |
|
282 |
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE) |
|
283 |
#' out <- as_yaml_auto(input) |
|
284 |
#' out |
|
285 |
#' print(out) |
|
286 |
print.rmd_yaml_header <- function(x, ...) { |
|
287 | ! |
cat(x, ...) |
288 |
} |
|
289 | ||
290 |
#' Extract field from `yaml` text |
|
291 |
#' |
|
292 |
#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list; |
|
293 |
#' otherwise, the field itself. |
|
294 |
#' |
|
295 |
#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text. |
|
296 |
#' @param field_name (`character`) the name of the field to extract. |
|
297 |
#' |
|
298 |
#' @return If the field is a list, it returns the names of elements in the list; otherwise, |
|
299 |
#' it returns the extracted field. |
|
300 |
#' |
|
301 |
#' @keywords internal |
|
302 |
get_yaml_field <- function(yaml_text, field_name) { |
|
303 | 1x |
checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character")) |
304 | 1x |
checkmate::assert_string(field_name) |
305 | ||
306 | 1x |
yaml_obj <- yaml::yaml.load(yaml_text) |
307 | ||
308 | 1x |
result <- yaml_obj[[field_name]] |
309 | 1x |
if (is.list(result)) { |
310 | 1x |
result <- names(result) |
311 |
} |
|
312 | 1x |
result |
313 |
} |
1 |
ui_card_editor <- function(id, value, cached_html) { |
|
2 | ! |
ns <- shiny::NS(id) |
3 | ! |
shiny::tagList( |
4 | ! |
shiny::tags$div( |
5 | ! |
id = ns("blocks"), |
6 | ! |
lapply(names(value), function(block_name) { |
7 | ! |
ui_editor_block( |
8 | ! |
shiny::NS(ns("blocks"), block_name), |
9 | ! |
value = value[[block_name]], |
10 | ! |
cached_html = cached_html[[block_name]] |
11 |
) |
|
12 |
}) |
|
13 |
), |
|
14 | ! |
shiny::actionButton(ns("add_block"), label = "Add text block", icon = shiny::icon("plus")) |
15 |
) |
|
16 |
} |
|
17 | ||
18 |
srv_card_editor <- function(id, card_r) { |
|
19 | 7x |
shiny::moduleServer(id, function(input, output, session) { |
20 | 7x |
blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot |
21 | 7x |
blocks_queue_rv <- shiny::reactiveVal() |
22 | ||
23 | 7x |
shiny::observeEvent(card_r(), { # Reset on card change |
24 | ! |
for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL |
25 | 3x |
blocks_queue_rv(NULL) # Force retriggering |
26 | 3x |
blocks_queue_rv(names(card_r())) |
27 |
}) |
|
28 | ||
29 | 7x |
shiny::observeEvent(blocks_queue_rv(), { |
30 | 4x |
lapply(blocks_queue_rv(), function(block_name) { |
31 | 6x |
new_block_id <- shiny::NS("blocks", block_name) |
32 | 6x |
block_content <- card_r()[[block_name]] %||% "" # Initialize as empty string |
33 | 6x |
blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content) |
34 | ||
35 | 6x |
if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered |
36 | 1x |
new_block_ui <- ui_editor_block( |
37 | 1x |
session$ns(new_block_id), |
38 | 1x |
value = block_content, |
39 | 1x |
cached_html = NULL |
40 |
) |
|
41 | 1x |
shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui) |
42 |
} |
|
43 |
}) |
|
44 |
}) |
|
45 | ||
46 | 7x |
shiny::observeEvent(input$add_block, { |
47 | 1x |
new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1) |
48 | 1x |
blocks_queue_rv(new_name) |
49 |
}) |
|
50 | ||
51 | 7x |
blocks_inputs_rvs |
52 |
}) |
|
53 |
} |
1 |
#' Reset report button module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' Provides a button that triggers resetting the report content. |
|
6 |
#' |
|
7 |
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`. |
|
8 |
#' |
|
9 |
#' @name reset_report_button |
|
10 |
#' |
|
11 |
#' @param id (`character(1)`) `shiny` module instance id. |
|
12 |
#' @param label (`character(1)`) label of the button. By default `NULL`. |
|
13 |
#' @param reporter (`Reporter`) instance. |
|
14 |
#' @return `NULL`. |
|
15 |
NULL |
|
16 | ||
17 |
#' @rdname reset_report_button |
|
18 |
#' @export |
|
19 |
reset_report_button_ui <- function(id, label = NULL) { |
|
20 | ! |
checkmate::assert_string(label, null.ok = TRUE) |
21 | ! |
.action_button_busy( |
22 | ! |
shiny::NS(id, "reset_reporter"), |
23 | ! |
label = label, |
24 | ! |
icon = "x-lg", |
25 | ! |
type = "danger", |
26 | ! |
outline = TRUE |
27 |
) |
|
28 |
} |
|
29 | ||
30 |
#' @rdname reset_report_button |
|
31 |
#' @export |
|
32 |
reset_report_button_srv <- function(id, reporter) { |
|
33 | 12x |
checkmate::assert_class(reporter, "Reporter") |
34 | ||
35 | 12x |
shiny::moduleServer(id, function(input, output, session) { |
36 | 12x |
shiny::setBookmarkExclude(c("reset_reporter")) |
37 | ||
38 | 12x |
shiny::observeEvent(reporter$get_cards(), { |
39 | 7x |
shinyjs::toggleClass( |
40 | 7x |
id = "reset_reporter", condition = length(reporter$get_cards()) == 0, class = "disabled" |
41 |
) |
|
42 |
}) |
|
43 | ||
44 | 12x |
shiny::observeEvent(input$reset_reporter, { |
45 | 2x |
shiny::tags$div( |
46 | 2x |
class = "teal-reporter reporter-modal", |
47 | 2x |
.custom_css_dependency(), |
48 | 2x |
shiny::showModal( |
49 | 2x |
shiny::modalDialog( |
50 | 2x |
easyClose = TRUE, |
51 | 2x |
shiny::tags$h3("Reset the Report"), |
52 | 2x |
shiny::tags$hr(), |
53 | 2x |
shiny::tags$strong( |
54 | 2x |
shiny::tags$p( |
55 | 2x |
"Are you sure you want to reset the report? (This will remove ALL previously added cards)." |
56 |
) |
|
57 |
), |
|
58 | 2x |
footer = shiny::tagList( |
59 | 2x |
shiny::tags$button( |
60 | 2x |
type = "button", |
61 | 2x |
class = "btn btn-outline-secondary", |
62 | 2x |
`data-bs-dismiss` = "modal", |
63 | 2x |
NULL, |
64 | 2x |
"Dismiss" |
65 |
), |
|
66 | 2x |
shiny::actionButton(session$ns("reset_reporter_ok"), "Reset", class = "btn btn-primary") |
67 |
) |
|
68 |
) |
|
69 |
) |
|
70 |
) |
|
71 |
}) |
|
72 | ||
73 | 12x |
shiny::observeEvent(reporter$get_cards(), { |
74 | 7x |
if (length(reporter$get_cards())) { |
75 | 5x |
shinyjs::enable("reset_reporter") |
76 |
} else { |
|
77 | 2x |
shinyjs::disable("reset_reporter") |
78 |
} |
|
79 |
}) |
|
80 | ||
81 | 12x |
shiny::observeEvent(input$reset_reporter_ok, { |
82 | 2x |
reporter$reset() |
83 | 2x |
shiny::removeModal() |
84 |
}) |
|
85 |
}) |
|
86 |
} |
1 |
#' Download report button module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' Provides a button that triggers downloading a report. |
|
6 |
#' |
|
7 |
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`. |
|
8 |
#' |
|
9 |
#' @details `r global_knitr_details()` |
|
10 |
#' |
|
11 |
#' @name download_report_button |
|
12 |
#' |
|
13 |
#' @param id (`character(1)`) this `shiny` module's id. |
|
14 |
#' @param label (`character(1)`) label before the icon. By default `NULL`. |
|
15 |
#' @param reporter (`Reporter`) instance. |
|
16 |
#' @param label (`character(1)`) label of the button. By default it is empty. |
|
17 |
#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) |
|
18 |
#' for customizing the rendering process. |
|
19 |
#' @inheritParams reporter_download_inputs |
|
20 |
#' |
|
21 |
#' @return `NULL`. |
|
22 |
NULL |
|
23 | ||
24 |
#' @rdname download_report_button |
|
25 |
#' @export |
|
26 |
download_report_button_ui <- function(id, label = NULL) { |
|
27 | ! |
checkmate::assert_string(label, null.ok = TRUE) |
28 | ! |
.action_button_busy( |
29 | ! |
shiny::NS(id, "download_button"), |
30 | ! |
label = label, |
31 | ! |
icon = "download", |
32 | ! |
outline = TRUE |
33 |
) |
|
34 |
} |
|
35 | ||
36 |
#' @rdname download_report_button |
|
37 |
#' @export |
|
38 |
download_report_button_srv <- function(id, |
|
39 |
reporter, |
|
40 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
41 |
rmd_output = getOption("teal.reporter.rmd_output"), |
|
42 |
rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")) { |
|
43 | 20x |
checkmate::assert_class(reporter, "Reporter") |
44 | 20x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
45 | 20x |
checkmate::assert_subset( |
46 | 20x |
rmd_output, |
47 | 20x |
c( |
48 | 20x |
"html_document", "pdf_document", |
49 | 20x |
"powerpoint_presentation", "word_document" |
50 |
), |
|
51 | 20x |
empty.ok = FALSE |
52 |
) |
|
53 | 20x |
checkmate::assert_list(rmd_yaml_args, names = "named") |
54 | 20x |
checkmate::assert_names( |
55 | 20x |
names(rmd_yaml_args), |
56 | 20x |
subset.of = c("author", "title", "date", "output", "toc"), |
57 | 20x |
must.include = "output" |
58 |
) |
|
59 | 18x |
checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) |
60 | ||
61 | 17x |
shiny::moduleServer(id, function(input, output, session) { |
62 | 17x |
shiny::setBookmarkExclude(c("download_button")) |
63 | ||
64 | 17x |
ns <- session$ns |
65 | ||
66 | 17x |
download_modal <- function() { |
67 | 1x |
nr_cards <- length(reporter$get_cards()) |
68 | 1x |
downb <- shiny::downloadButton( |
69 | 1x |
outputId = ns("download_data"), |
70 | 1x |
label = "Download", |
71 | 1x |
class = c( |
72 | 1x |
"btn", "teal-reporter", "download-ok", "btn-primary", "shiny-download-link", |
73 | 1x |
if (nr_cards == 0) "disabled" |
74 |
), |
|
75 | 1x |
icon = shiny::icon("download") |
76 |
) |
|
77 | ||
78 | 1x |
shiny::tags$div( |
79 | 1x |
class = "teal-reporter reporter-modal", |
80 | 1x |
.custom_css_dependency(), |
81 | 1x |
shiny::modalDialog( |
82 | 1x |
easyClose = TRUE, |
83 | 1x |
shiny::tags$h3("Download the Report"), |
84 | 1x |
shiny::tags$hr(), |
85 | 1x |
if (length(reporter$get_cards()) == 0) { |
86 | ! |
shiny::tags$div( |
87 | ! |
shiny::tags$p( |
88 | ! |
class = "text-danger", |
89 | ! |
shiny::tags$strong("No Cards Added") |
90 |
), |
|
91 | ! |
shiny::tags$br() |
92 |
) |
|
93 |
} else { |
|
94 | 1x |
shiny::tags$div( |
95 | 1x |
shiny::tags$p( |
96 | 1x |
class = "text-success", |
97 | 1x |
shiny::tags$strong(paste("Number of cards: ", nr_cards)) |
98 |
), |
|
99 | 1x |
shiny::tags$br() |
100 |
) |
|
101 |
}, |
|
102 | 1x |
reporter_download_inputs( |
103 | 1x |
rmd_yaml_args = rmd_yaml_args, |
104 | 1x |
rmd_output = rmd_output, |
105 | 1x |
showrcode = any_rcode_block(reporter), |
106 | 1x |
session = session |
107 |
), |
|
108 | 1x |
footer = shiny::tagList( |
109 | 1x |
shiny::tags$button( |
110 | 1x |
type = "button", |
111 | 1x |
class = "btn btn-outline-secondary", |
112 | 1x |
`data-bs-dismiss` = "modal", |
113 | 1x |
NULL, |
114 | 1x |
"Dismiss" |
115 |
), |
|
116 | 1x |
shiny::tags$a( |
117 | 1x |
id = ns("download_data"), |
118 | 1x |
class = "btn btn-primary shiny-download-link", |
119 | 1x |
href = "", |
120 | 1x |
target = "_blank", |
121 | 1x |
download = NA, |
122 | 1x |
shiny::icon("download"), |
123 | 1x |
"Download" |
124 |
) |
|
125 |
) |
|
126 |
) |
|
127 |
) |
|
128 |
} |
|
129 | ||
130 | 17x |
shiny::observeEvent(reporter$get_cards(), { |
131 | 9x |
shinyjs::toggleState(length(reporter$get_cards()) > 0, id = "download_button") |
132 |
}) |
|
133 | ||
134 | 17x |
shiny::observeEvent(input$download_button, shiny::showModal(download_modal())) |
135 | ||
136 | 17x |
output$download_data <- shiny::downloadHandler( |
137 | 17x |
filename = function() paste0(.report_identifier(reporter), ".zip"), |
138 | 17x |
content = function(file) { |
139 | 3x |
shiny::showNotification("Rendering and Downloading the document.") |
140 | 3x |
shinybusy::block(id = ns("download_data"), text = "", type = "dots") |
141 | 3x |
rmd_yaml_with_inputs <- lapply(names(rmd_yaml_args), function(x) input[[x]]) |
142 | 3x |
names(rmd_yaml_with_inputs) <- names(rmd_yaml_args) |
143 | ! |
if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode |
144 | 3x |
report_render_and_compress( |
145 | 3x |
reporter = reporter, |
146 | 3x |
rmd_yaml_args = rmd_yaml_with_inputs, |
147 | 3x |
global_knitr = global_knitr, |
148 | 3x |
file = file |
149 |
) |
|
150 | 3x |
shinybusy::unblock(id = ns("download_data")) |
151 |
}, |
|
152 | 17x |
contentType = "application/zip" |
153 |
) |
|
154 |
}) |
|
155 |
} |
|
156 | ||
157 |
#' Render the report |
|
158 |
#' |
|
159 |
#' Render the report and zip the created directory. |
|
160 |
#' |
|
161 |
#' @param reporter (`Reporter`) instance. |
|
162 |
#' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their values. |
|
163 |
#' @param global_knitr (`list`) a global `knitr` parameters, like echo. |
|
164 |
#' But if local parameter is set it will have priority. |
|
165 |
#' @param file (`character(1)`) where to copy created zip file. |
|
166 |
#' |
|
167 |
#' @return `file` argument, invisibly. |
|
168 |
#' |
|
169 |
#' @keywords internal |
|
170 |
report_render_and_compress <- function(reporter, rmd_yaml_args, global_knitr, file = tempfile()) { |
|
171 | 8x |
checkmate::assert_class(reporter, "Reporter") |
172 | 8x |
checkmate::assert_list(rmd_yaml_args, names = "named") |
173 | 7x |
checkmate::assert_string(file) |
174 | ||
175 | 5x |
tmp_dir <- file.path(tempdir(), .report_identifier(reporter)) |
176 | ||
177 | 5x |
cards_combined <- reporter$get_blocks() |
178 | 5x |
metadata(cards_combined) <- utils::modifyList(metadata(cards_combined), rmd_yaml_args) |
179 | ||
180 | 5x |
tryCatch( |
181 | 5x |
render( |
182 | 5x |
input = cards_combined, |
183 | 5x |
output_dir = tmp_dir, |
184 | 5x |
global_knitr = global_knitr, |
185 | 5x |
quiet = TRUE |
186 |
), |
|
187 | 5x |
warning = function(cond) message("Render document warning: ", cond), |
188 | 5x |
error = function(cond) { |
189 | ! |
message("Render document error: ", cond) |
190 | ! |
do.call("return", args = list(), envir = parent.frame(2)) |
191 |
} |
|
192 |
) |
|
193 | ||
194 | 5x |
tryCatch( |
195 | 5x |
reporter$to_jsondir(tmp_dir), |
196 | 5x |
warning = function(cond) message("Archive document warning: ", cond), |
197 | 5x |
error = function(cond) message("Archive document error: ", cond) |
198 |
) |
|
199 | ||
200 | 5x |
tryCatch( |
201 | 5x |
reporter$write_figures(tmp_dir), |
202 | 5x |
warning = function(cond) message("Save reporter images warning: ", cond), |
203 | 5x |
error = function(cond) message("Save reporter images error: ", cond) |
204 |
) |
|
205 | ||
206 | 5x |
temp_zip_file <- tempfile(fileext = ".zip") |
207 | 5x |
tryCatch( |
208 | 5x |
zip::zipr(temp_zip_file, tmp_dir), |
209 | 5x |
warning = function(cond) message("Zipping folder warning: ", cond), |
210 | 5x |
error = function(cond) message("Zipping folder error: ", cond) |
211 |
) |
|
212 | ||
213 | 5x |
tryCatch( |
214 |
{ |
|
215 | 5x |
file.copy(temp_zip_file, file) |
216 | 5x |
unlink(tmp_dir, recursive = TRUE) |
217 |
}, |
|
218 | 5x |
warning = function(cond) message("Copying file warning: ", cond), |
219 | 5x |
error = function(cond) message("Copying file error: ", cond) |
220 |
) |
|
221 | 5x |
invisible(file) |
222 |
} |
|
223 | ||
224 |
#' Get the custom list of UI inputs |
|
225 |
#' |
|
226 |
#' @param rmd_output (`character`) vector with `rmarkdown` output types, |
|
227 |
#' by default all possible `pdf_document`, `html_document`, `powerpoint_presentation`, and `word_document`. |
|
228 |
#' If vector is named then those names will appear in the `UI`. |
|
229 |
#' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their default values. |
|
230 |
#' This `list` will result in the custom subset of UI inputs for the download reporter functionality. |
|
231 |
#' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`. |
|
232 |
#' The `list` must include at least `"output"` field. |
|
233 |
#' The default value for `"output"` has to be in the `rmd_output` argument. |
|
234 |
#' |
|
235 |
#' @keywords internal |
|
236 |
reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) { |
|
237 | 1x |
shiny::tagList( |
238 | 1x |
lapply(names(rmd_yaml_args), function(e) { |
239 | 5x |
switch(e, |
240 | 1x |
author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author), |
241 | 1x |
title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title), |
242 | 1x |
date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date), |
243 | 1x |
output = shiny::tags$div( |
244 | 1x |
shinyWidgets::pickerInput( |
245 | 1x |
inputId = session$ns("output"), |
246 | 1x |
label = "Choose a document type: ", |
247 | 1x |
choices = rmd_output, |
248 | 1x |
selected = rmd_yaml_args$output |
249 |
) |
|
250 |
), |
|
251 | 1x |
toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc) |
252 |
) |
|
253 |
}), |
|
254 | 1x |
if (showrcode) { |
255 | ! |
shiny::checkboxInput( |
256 | ! |
session$ns("showrcode"), |
257 | ! |
label = "Include R Code", |
258 | ! |
value = FALSE |
259 |
) |
|
260 |
} |
|
261 |
) |
|
262 |
} |
|
263 | ||
264 |
#' @noRd |
|
265 |
#' @keywords internal |
|
266 |
any_rcode_block <- function(reporter) { |
|
267 | 3x |
any(vapply(reporter$get_blocks(), inherits, logical(1), what = "code_chunk")) |
268 |
} |
|
269 | ||
270 |
.report_identifier <- function(reporter) { |
|
271 | 8x |
id <- paste0("_", reporter$get_id()) %||% "" |
272 | 8x |
timestamp <- format(Sys.time(), "_%y%m%d%H%M%S") |
273 | 8x |
sprintf("reporter%s%s", id, timestamp) |
274 |
} |
1 |
#' Add card button module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' Provides a button to add views/cards to a report. |
|
6 |
#' |
|
7 |
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`. |
|
8 |
#' |
|
9 |
#' @details |
|
10 |
#' The `card_fun` function is designed to create a new `ReportCard` instance and optionally customize it: |
|
11 |
#' - The `teal_card` parameter allows for specifying a custom or default `ReportCard` instance. |
|
12 |
#' - Use the `comment` parameter to add a comment to the card via `card$append_text()` - if `card_fun` does not |
|
13 |
#' have the `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the |
|
14 |
#' card. |
|
15 |
#' - The `label` parameter enables customization of the card's name and its content through `card$append_text()`- |
|
16 |
#' if `card_fun` does not have the `label` parameter, then card name will be set to the name passed in |
|
17 |
#' `Add Card UI` module, but no text will be added to the content of the `teal_card`. |
|
18 |
#' |
|
19 |
#' This module supports using a subclass of [`ReportCard`] for added flexibility. |
|
20 |
#' A subclass instance should be passed as the default value of |
|
21 |
#' the `teal_card` argument in the `card_fun` function. |
|
22 |
#' See below: |
|
23 |
#' ```{r} |
|
24 |
#' CustomReportCard <- R6::R6Class( |
|
25 |
#' classname = "CustomReportCard", |
|
26 |
#' inherit = teal.reporter::ReportCard |
|
27 |
#' ) |
|
28 |
#' |
|
29 |
#' custom_function <- function(card = CustomReportCard$new()) { |
|
30 |
#' card |
|
31 |
#' } |
|
32 |
#' ``` |
|
33 |
#' @name add_card_button |
|
34 |
#' |
|
35 |
#' @param id (`character(1)`) this `shiny` module's id. |
|
36 |
#' @param reporter (`Reporter`) instance. |
|
37 |
#' @param label (`character(1)`) label of the button. By default it is empty. |
|
38 |
#' @param card_fun (`function`) which returns a [`ReportCard`] instance. See `Details`. |
|
39 |
#' @param card_title (`character(1)`) default value for the card title input field. By default it is empty. |
|
40 |
#' |
|
41 |
#' @return `NULL`. |
|
42 |
NULL |
|
43 | ||
44 |
#' @rdname add_card_button |
|
45 |
#' @export |
|
46 |
add_card_button_ui <- function(id, label = NULL) { |
|
47 | ! |
checkmate::assert_string(label, null.ok = TRUE) |
48 | ! |
.action_button_busy( |
49 | ! |
shiny::NS(id, "add_report_card_button"), |
50 | ! |
icon = "plus-lg", |
51 | ! |
label = label, |
52 | ! |
type = "primary", |
53 | ! |
outline = TRUE |
54 |
) |
|
55 |
} |
|
56 | ||
57 |
#' @rdname add_card_button |
|
58 |
#' @export |
|
59 |
add_card_button_srv <- function(id, reporter, card_fun, card_title = "") { |
|
60 | 17x |
checkmate::assert_function(card_fun) |
61 | 17x |
checkmate::assert_class(reporter, "Reporter") |
62 | 17x |
checkmate::assert_string(card_title) |
63 | 17x |
checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE) |
64 | ||
65 | 17x |
shiny::moduleServer(id, function(input, output, session) { |
66 | 17x |
shiny::setBookmarkExclude(c( |
67 | 17x |
"add_report_card_button", "download_button", "reset_reporter", |
68 | 17x |
"add_card_ok", "download_data", "reset_reporter_ok", |
69 | 17x |
"label", "comment" |
70 |
)) |
|
71 | ||
72 | 17x |
ns <- session$ns |
73 | ||
74 | 17x |
title_r <- shiny::reactiveVal(card_title) |
75 | 17x |
shiny::observeEvent(input$label, title_r(input$label)) |
76 | ||
77 | 17x |
add_modal <- function() { |
78 | 14x |
shiny::div( |
79 | 14x |
class = "teal-reporter reporter-modal", |
80 | 14x |
.custom_css_dependency(), |
81 | 14x |
shiny::modalDialog( |
82 | 14x |
easyClose = TRUE, |
83 | 14x |
shiny::tags$h3("Add a Card to the Report"), |
84 | 14x |
shiny::tags$hr(), |
85 | 14x |
shiny::textInput( |
86 | 14x |
ns("label"), |
87 | 14x |
"Card Title", |
88 | 14x |
value = shiny::isolate(title_r()), |
89 | 14x |
placeholder = "Add the card title here", |
90 | 14x |
width = "100%" |
91 |
), |
|
92 | 14x |
shiny::textAreaInput( |
93 | 14x |
ns("comment"), |
94 | 14x |
"Comment", |
95 | 14x |
value = "", |
96 | 14x |
placeholder = "Add a comment here...", |
97 | 14x |
width = "100%" |
98 |
), |
|
99 | 14x |
shiny::tags$script( |
100 | 14x |
shiny::HTML( |
101 | 14x |
sprintf("shinyjs.autoFocusModal('%s');", ns("label")), # See extendShinyJs.js |
102 | 14x |
sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("label"), ns("add_card_ok")) # See extendShinyJs.js |
103 |
) |
|
104 |
), |
|
105 | 14x |
footer = shiny::div( |
106 | 14x |
shiny::tags$button( |
107 | 14x |
type = "button", |
108 | 14x |
class = "btn btn-outline-secondary", |
109 | 14x |
`data-bs-dismiss` = "modal", |
110 | 14x |
NULL, |
111 | 14x |
"Dismiss" |
112 |
), |
|
113 | 14x |
shiny::tags$button( |
114 | 14x |
id = ns("add_card_ok"), |
115 | 14x |
type = "button", |
116 | 14x |
class = "btn btn-primary action-button", |
117 | 14x |
NULL, |
118 | 14x |
"Add Card" |
119 |
) |
|
120 |
) |
|
121 |
) |
|
122 |
) |
|
123 |
} |
|
124 | ||
125 | 17x |
shiny::observeEvent(input$add_report_card_button, { |
126 | 14x |
shiny::showModal(add_modal()) |
127 |
}) |
|
128 | ||
129 |
# the add card button is disabled when clicked to prevent multi-clicks |
|
130 |
# please check the ui part for more information |
|
131 | 17x |
shiny::observeEvent(input$add_card_ok, { |
132 | 14x |
card_fun_args_nams <- names(formals(card_fun)) |
133 | 14x |
has_card_arg <- "card" %in% card_fun_args_nams |
134 | 14x |
has_comment_arg <- "comment" %in% card_fun_args_nams |
135 | 14x |
has_label_arg <- "label" %in% card_fun_args_nams |
136 | ||
137 | 14x |
arg_list <- list() |
138 | ||
139 | 14x |
if (has_comment_arg) { |
140 | 4x |
arg_list <- c(arg_list, list(comment = input$comment)) |
141 |
} |
|
142 | 14x |
if (has_label_arg) { |
143 | ! |
arg_list <- c(arg_list, list(label = title_r())) |
144 |
} |
|
145 | ||
146 | 14x |
shinyjs::disable("add_card_ok") |
147 | ||
148 | 14x |
if (has_card_arg) { |
149 |
# The default_card is defined here because formals() returns a pairedlist object |
|
150 |
# of formal parameter names and their default values. The values are missing |
|
151 |
# if not defined and the missing check does not work if supplied formals(card_fun)[[1]] |
|
152 | 11x |
default_card <- formals(card_fun)$card |
153 | 11x |
card <- `if`( |
154 | 11x |
missing(default_card), |
155 | 11x |
ReportCard$new(), |
156 | 11x |
eval(default_card, envir = environment(card_fun)) |
157 |
) |
|
158 | 11x |
arg_list <- c(arg_list, list(card = card)) |
159 |
} |
|
160 | ||
161 | 14x |
card <- try(do.call(card_fun, arg_list)) |
162 | ||
163 | 14x |
if (inherits(card, "try-error")) { |
164 | 3x |
msg <- paste0( |
165 | 3x |
"The card could not be added to the report. ", |
166 | 3x |
"Have the outputs for the report been created yet? If not please try again when they ", |
167 | 3x |
"are ready. Otherwise contact your application developer" |
168 |
) |
|
169 | 3x |
warning(msg) |
170 | 3x |
shiny::showNotification( |
171 | 3x |
msg, |
172 | 3x |
type = "error" |
173 |
) |
|
174 | 3x |
shinyjs::enable("add_card_ok") |
175 |
} else { |
|
176 | 11x |
checkmate::assert_multi_class(card, c("ReportCard", "teal_card")) |
177 | 11x |
if (inherits(card, "ReportCard")) { |
178 | 1x |
if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { |
179 | 1x |
card$append_text("Comment", "header3") |
180 | 1x |
card$append_text(input$comment) |
181 |
} |
|
182 | ||
183 | 1x |
if (!has_label_arg && length(title_r()) == 1 && title_r() != "") { |
184 | ! |
card$set_name(title_r()) |
185 |
} |
|
186 | 10x |
} else if (inherits(card, "teal_card")) { |
187 | 10x |
if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { |
188 | 1x |
card <- c(card, "### Comment", input$comment) |
189 |
} |
|
190 | 10x |
if (!has_label_arg && length(title_r()) == 1 && title_r() != "") { |
191 | 2x |
metadata(card, "title") <- title_r() |
192 |
} |
|
193 |
} |
|
194 | ||
195 | 11x |
reporter$append_cards(list(card)) |
196 | 11x |
shiny::showNotification(sprintf("The card added successfully."), type = "message") |
197 | 11x |
shiny::removeModal() |
198 |
} |
|
199 |
}) |
|
200 |
}) |
|
201 |
} |
1 |
#' @title `teal_card`: An `S3` class for managing `teal` reports |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' The `teal_card` `S3` class provides functionality to store, manage, edit, and adjust report contents. |
|
6 |
#' It enables users to create, manipulate, and serialize report-related data efficiently. |
|
7 |
#' |
|
8 |
#' The `teal_card()` function serves two purposes: |
|
9 |
#' 1. When called with a `teal_report` object, it acts as a getter and returns the card slot. |
|
10 |
#' 2. When called with other arguments, it creates a new `teal_card` object from those arguments. |
|
11 |
#' |
|
12 |
#' @return An `S3` `list` of class `teal_card`. |
|
13 |
#' @param ... Elements from which `teal_card` will be combined. |
|
14 |
#' |
|
15 |
#' @details The `teal_card` class supports `c()` and `x[i]` methods for combining and subsetting elements. |
|
16 |
#' However, these methods only function correctly when the first element is a `teal_card`. |
|
17 |
#' |
|
18 |
#' @seealso [code_chunk()], [render()], [toHTML()] |
|
19 |
#' |
|
20 |
#' @examples |
|
21 |
#' # create an empty card |
|
22 |
#' report <- teal_card() |
|
23 |
#' |
|
24 |
#' # Create a card with content |
|
25 |
#' report <- teal_card( |
|
26 |
#' "## Headline", |
|
27 |
#' "This is `iris` table", |
|
28 |
#' code_chunk("print(iris)", lang = "R"), |
|
29 |
#' iris |
|
30 |
#' ) |
|
31 |
#' |
|
32 |
#' # Add elements to the report |
|
33 |
#' report <- c( |
|
34 |
#' report, |
|
35 |
#' list("## mtcars Table"), |
|
36 |
#' code_chunk("print(mtcars)", lang = "R"), |
|
37 |
#' mtcars |
|
38 |
#' ) |
|
39 |
#' |
|
40 |
#' # Subset the report to keep only the first two elements |
|
41 |
#' report[1:2] |
|
42 |
#' |
|
43 |
#' # Replace element |
|
44 |
#' report[[1]] <- "## Iris Table" |
|
45 |
#' |
|
46 |
#' # Append element |
|
47 |
#' report <- append(report, teal_card("# Awesome Report"), after = 0) |
|
48 |
#' tools::toHTML(report) |
|
49 |
#' |
|
50 |
#' if (interactive()) { |
|
51 |
#' render(report, output_format = rmarkdown::pdf_document()) |
|
52 |
#' } |
|
53 |
#' |
|
54 |
#' @aliases teal_card |
|
55 |
#' @name teal_card |
|
56 |
#' |
|
57 |
#' @export |
|
58 |
teal_card <- function(...) { |
|
59 | 846x |
UseMethod("teal_card") |
60 |
} |
|
61 | ||
62 |
#' @export |
|
63 |
#' @keywords internal |
|
64 |
teal_card.default <- function(...) { |
|
65 | 658x |
x <- lapply(list(...), .convert_teal_card_input) |
66 | ||
67 | 658x |
if (length(x) > 0) { |
68 | 384x |
names(x) <- vapply( |
69 | 384x |
sample.int(.Machine$integer.max, size = length(x)), |
70 | 384x |
function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8), |
71 | 384x |
character(1) |
72 |
) |
|
73 |
} |
|
74 | 658x |
structure(x, class = "teal_card") |
75 |
} |
|
76 | ||
77 |
#' @export |
|
78 |
#' @keywords internal |
|
79 |
teal_card.teal_card <- function(...) { |
|
80 | 95x |
dots <- list(...) |
81 | 95x |
c(dots[[1]], dots[-1]) |
82 |
} |
|
83 | ||
84 |
#' @export |
|
85 |
#' @keywords internal |
|
86 |
teal_card.teal_report <- function(...) { |
|
87 | 90x |
dots <- list(...) |
88 | 90x |
dots[[1]] <- dots[[1]]@teal_card |
89 | 90x |
do.call(teal_card, args = dots) |
90 |
} |
|
91 | ||
92 |
#' @export |
|
93 |
#' @keywords internal |
|
94 |
teal_card.qenv <- function(...) { |
|
95 | 3x |
dots <- list(...) |
96 | 3x |
dots[[1]] <- .code_to_card(dots[[1]]@code) |
97 | 3x |
do.call(teal_card, args = dots) |
98 |
} |
|
99 | ||
100 |
#' @rdname teal_card |
|
101 |
#' @param value (`teal_card`) object to set in the `teal_report`. |
|
102 |
#' @export |
|
103 |
`teal_card<-` <- function(x, value) { |
|
104 | 47x |
x <- methods::as(x, "teal_report") |
105 | 47x |
checkmate::assert_class(x, "teal_report") |
106 | 47x |
x@teal_card <- as.teal_card(value) |
107 | 47x |
x |
108 |
} |
|
109 | ||
110 |
#' @export |
|
111 |
`[[<-.teal_card` <- function(x, index, value) { |
|
112 | 8x |
new_card <- as.teal_card(value) |
113 | 8x |
value <- new_card[[1]] |
114 | 8x |
new_x <- NextMethod() |
115 | 8x |
if (checkmate::test_integerish(index)) { |
116 | 2x |
names(new_x)[[index]] <- names(new_card)[[1]] |
117 |
} |
|
118 | 8x |
new_x |
119 |
} |
|
120 | ||
121 |
#' Create or coerce to a teal_card |
|
122 |
#' |
|
123 |
#' This function ensures that input is converted to a teal_card object. |
|
124 |
#' It accepts various input types and converts them appropriately. |
|
125 |
#' |
|
126 |
#' @param x Object to convert to teal_card |
|
127 |
#' @param verbose (`logical`) If `TRUE`, will print a warning when appending `teal_card` objects that share elements. |
|
128 |
#' @return A teal_card object |
|
129 |
#' @rdname teal_card |
|
130 |
#' @export |
|
131 |
as.teal_card <- function(x) { # nolint: object_name. |
|
132 | 864x |
if (inherits(x, "teal_card")) { |
133 | 541x |
if (length(x) && !checkmate::test_names(names(x), type = "unique")) { # Fix names if not unique or missing |
134 | 59x |
names(x) <- substr( |
135 | 59x |
vapply(seq_len(length(x)), function(ix) rlang::hash(list(ix, Sys.time(), x[[ix]])), character(1L)), |
136 | 59x |
1, |
137 | 59x |
8 |
138 |
) |
|
139 |
} |
|
140 | 541x |
return(x) |
141 |
} |
|
142 | 323x |
if (identical(class(x), "list")) { |
143 | 102x |
return(do.call(teal_card, unname(x))) |
144 |
} |
|
145 | 221x |
teal_card(x) |
146 |
} |
|
147 | ||
148 |
#' @rdname teal_card |
|
149 |
#' @export |
|
150 |
c.teal_card <- function(..., verbose = TRUE) { |
|
151 | 330x |
dots <- list(...) |
152 | 330x |
structure( |
153 | 330x |
Reduce( |
154 | 330x |
f = function(u, v) { |
155 | 743x |
v <- as.teal_card(v) |
156 | 743x |
if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u |
157 | 3x |
if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v` |
158 | 2x |
v |
159 |
} else { |
|
160 | 1x |
if (verbose) { |
161 | 1x |
warning( |
162 | 1x |
"Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n", |
163 | 1x |
"Restoring original content and adding only new items to the end of the card." |
164 |
) |
|
165 |
} |
|
166 | 1x |
utils::modifyList(u, v) |
167 |
} |
|
168 |
} else { |
|
169 | 740x |
attrs <- utils::modifyList(attributes(u) %||% list(), attributes(v)) |
170 | 740x |
attrs$names <- union(names(u), names(v)) |
171 | 740x |
attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %||% list(), metadata(v)) |
172 | 740x |
result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass |
173 | 740x |
attributes(result) <- attrs |
174 | 740x |
result |
175 |
} |
|
176 |
}, |
|
177 | 330x |
x = dots, |
178 | 330x |
init = list() |
179 |
), |
|
180 | 330x |
class = "teal_card" |
181 |
) |
|
182 |
} |
|
183 | ||
184 |
#' @param i index specifying elements to extract or replace |
|
185 |
#' @rdname teal_card |
|
186 |
#' @export |
|
187 |
`[.teal_card` <- function(x, i) { |
|
188 | 5x |
out <- NextMethod() |
189 | 5x |
class(out) <- "teal_card" |
190 | 5x |
attr(out, "metadata") <- metadata(x) |
191 | 5x |
out |
192 |
} |
|
193 | ||
194 |
#' Access metadata from a `teal_card` or `ReportCard` |
|
195 |
#' |
|
196 |
#' This function retrieves metadata from a `teal_card` or `ReportCard` object. |
|
197 |
#' When `which` is `NULL`, it returns all metadata fields as a list. |
|
198 |
#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata. |
|
199 |
#' @param which (`character` or `NULL`) The name of the metadata field to extract. |
|
200 |
#' @return A list of metadata fields or a specific field if `which` is provided. |
|
201 |
#' @export |
|
202 |
metadata <- function(object, which = NULL) { |
|
203 | 1197x |
checkmate::assert_string(which, null.ok = TRUE) |
204 | 1197x |
UseMethod("metadata", object) |
205 |
} |
|
206 | ||
207 |
#' @rdname metadata |
|
208 |
#' @export |
|
209 |
metadata.teal_card <- function(object, which = NULL) { |
|
210 | 1193x |
metadata <- attr(object, which = "metadata", exact = TRUE) |
211 | 1193x |
result <- metadata %||% list() |
212 | 1193x |
if (is.null(which)) { |
213 | 1102x |
return(result) |
214 |
} |
|
215 | 91x |
result[[which]] |
216 |
} |
|
217 | ||
218 |
#' @rdname metadata |
|
219 |
#' @export |
|
220 |
metadata.ReportCard <- function(object, which = NULL) { |
|
221 | 4x |
result <- list(title = object$get_name()) |
222 | 4x |
if (is.null(which)) { |
223 | 1x |
return(result) |
224 |
} |
|
225 | 3x |
result[[which]] |
226 |
} |
|
227 | ||
228 |
#' Set metadata for a `teal_card` or `ReportCard` |
|
229 |
#' |
|
230 |
#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object. |
|
231 |
#' It can be used to add new metadata or update existing fields. |
|
232 |
#' @param object (`teal_card` or `ReportCard`) The object to modify. |
|
233 |
#' @param which (`character`) The name of the metadata field to set. |
|
234 |
#' @param value The value to assign to the specified metadata field. |
|
235 |
#' @return The modified object with updated metadata. |
|
236 |
#' @export |
|
237 |
`metadata<-` <- function(object, which = NULL, value) { |
|
238 | 283x |
checkmate::assert_string(which, null.ok = TRUE) |
239 | 283x |
UseMethod("metadata<-", object) |
240 |
} |
|
241 | ||
242 |
#' @rdname metadata-set |
|
243 |
#' @export |
|
244 |
`metadata<-.teal_card` <- function(object, which = NULL, value) { |
|
245 | 266x |
if (missing(which)) { |
246 | 194x |
checkmate::assert_list(value, names = "named") |
247 | 194x |
attr(object, which = "metadata") <- value |
248 | 194x |
return(object) |
249 |
} |
|
250 | 72x |
attr(object, which = "metadata") <- utils::modifyList( |
251 | 72x |
metadata(object), structure(list(value), names = which) |
252 |
) |
|
253 | 72x |
object |
254 |
} |
|
255 | ||
256 |
#' @rdname metadata-set |
|
257 |
#' @details |
|
258 |
#' The `ReportCard` class only supports the `title` field in metadata. |
|
259 |
#' @export |
|
260 |
`metadata<-.ReportCard` <- function(object, which, value) { |
|
261 | 17x |
if (missing(which)) { |
262 | 3x |
if (!is.null(value[["title"]])) { |
263 | 2x |
object$set_name(value[["title"]]) |
264 |
} |
|
265 | 3x |
if (length(value) >= 2 || length(value) == 1 && is.null(value[["title"]])) { |
266 | 2x |
warning("ReportCard class only supports `title` in metadata.") |
267 |
} |
|
268 | 3x |
return(object) |
269 |
} |
|
270 | ||
271 | 14x |
if (isFALSE(identical(which, "title"))) { |
272 | 1x |
warning("ReportCard class only supports `title` in metadata.") |
273 |
} else { |
|
274 | 13x |
object$set_name(value) |
275 |
} |
|
276 | 14x |
object |
277 |
} |
|
278 | ||
279 |
#' Generate a code chunk |
|
280 |
#' |
|
281 |
#' @description |
|
282 |
#' This function creates a `code_chunk` object that represents code to be displayed |
|
283 |
#' in a report. It stores the code of any language (see `lang` argument) and any |
|
284 |
#' specified chunk options (e.g., `echo`, `eval`). |
|
285 |
#' |
|
286 |
#' @details |
|
287 |
#' **Important Notes:** |
|
288 |
#' - The code is **not evaluated**; it is only stored as text with formatting attributes. |
|
289 |
#' - When converted to output, `code_chunk` produces markdown code block syntax |
|
290 |
#' (` ```{lang} ... ``` `) or HTML `<pre><code>...</code></pre>` blocks. |
|
291 |
#' - The document is **not rendered** using `rmarkdown::render`. The `code_chunk` is part |
|
292 |
#' of the `teal_card` API for building reproducible documents that are produced as-is. |
|
293 |
#' |
|
294 |
#' **Typical Workflow:** |
|
295 |
#' 1. Create a `code_chunk` object with your code and options |
|
296 |
#' 2. Add it to a `teal_card` using `teal_card()` or `c()` |
|
297 |
#' 3. The card produces the formatted code block in the final document output |
|
298 |
#' |
|
299 |
#' @param code (`character`) The code to be displayed in the code chunk. |
|
300 |
#' @param ... Additional named parameters to be included as chunk options. These control |
|
301 |
#' how the chunk behaves when rendered (e.g., `echo = TRUE`, `eval = FALSE`, |
|
302 |
#' `message = FALSE`). See [`knitr` options](https://yihui.org/knitr/options/) for |
|
303 |
#' available options. |
|
304 |
#' @param lang (`character(1)`) The language of the code chunk. Defaults to `"R"`. |
|
305 |
#' See [`knitr::knit_engines`] for supported languages (e.g., "python", "bash"). |
|
306 |
#' |
|
307 |
#' @return An object of class `code_chunk` |
|
308 |
#' @seealso |
|
309 |
#' - [teal_card()] for creating report cards that can contain `code_chunk` objects |
|
310 |
#' |
|
311 |
#' @examples |
|
312 |
#' # Basic code chunk with options |
|
313 |
#' code_chunk("x <- 1:10", echo = TRUE, message = FALSE) |
|
314 |
#' |
|
315 |
#' # Python code chunk |
|
316 |
#' code_chunk("import pandas as pd", lang = "python", eval = FALSE) |
|
317 |
#' |
|
318 |
#' # Code chunk with multiple knitr options |
|
319 |
#' code_chunk( |
|
320 |
#' "plot(mtcars$mpg, mtcars$hp)", |
|
321 |
#' echo = TRUE, |
|
322 |
#' eval = TRUE, |
|
323 |
#' fig.width = 7, |
|
324 |
#' fig.height = 5, |
|
325 |
#' warning = FALSE |
|
326 |
#' ) |
|
327 |
#' |
|
328 |
#' @export |
|
329 |
code_chunk <- function(code, ..., lang = "R") { |
|
330 | 127x |
checkmate::assert_character(code) |
331 | 127x |
checkmate::assert_string(lang) |
332 | 127x |
params <- list(...) |
333 | 127x |
checkmate::assert_list(params, names = "named", .var.name = "...") |
334 | 127x |
structure( |
335 | 127x |
paste(code, collapse = "\n"), |
336 | 127x |
params = params, |
337 | 127x |
lang = lang, |
338 | 127x |
class = "code_chunk" |
339 |
) |
|
340 |
} |
|
341 | ||
342 | ||
343 |
#' Builds `teal_card` from code and outputs in `qenv` object |
|
344 |
#' |
|
345 |
#' Builds a `teal_card` from the code and outputs of a `teal_data` |
|
346 |
#' object, preserving the order of code execution and output display. |
|
347 |
#' |
|
348 |
#' @inheritParams eval_code-teal_report |
|
349 |
#' @param x (`list`) object from `qenv@code`. |
|
350 |
#' @return A `teal_card` built from the code and outputs in a `qenv` object. |
|
351 |
#' @keywords internal |
|
352 |
.code_to_card <- function(x, code_block_opts = list()) { |
|
353 | 32x |
elems <- Reduce( |
354 | 32x |
function(items, code_elem) { |
355 | 64x |
this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts)) |
356 | 64x |
this_outs <- Filter( # intentionally remove warnings,messages from the generated report |
357 | 64x |
function(x) !inherits(x[[1]], "condition"), |
358 | 64x |
lapply( |
359 | 64x |
attr(code_elem, "outputs"), |
360 | 64x |
function(x) structure(list(x), class = c("chunk_output")) |
361 |
) |
|
362 |
) |
|
363 | 64x |
c(items, list(this_chunk), this_outs) |
364 |
}, |
|
365 | 32x |
init = list(), |
366 | 32x |
x = x |
367 |
) |
|
368 | 32x |
do.call(teal_card, args = elems) |
369 |
} |
|
370 | ||
371 |
#' Internal helper for `teal_card`` input conversion |
|
372 |
#' |
|
373 |
#' Converts input values to a format compatible with `teal_card`. |
|
374 |
#' This function is used internally to handle common inputs, such as `ggplot` objects, |
|
375 |
#' ensuring they are appropriately converted to an "evaluable output" blocks that can |
|
376 |
#' be saved to `RDS` file efficiently. |
|
377 |
#' |
|
378 |
#' This function performs the following conversions: |
|
379 |
#' - `ggplot` objects are converted to `recordedplot` objects. |
|
380 |
#' |
|
381 |
#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`, |
|
382 |
#' no conversion is applied. |
|
383 |
#' |
|
384 |
#' @param x (`object`) An object to be converted. |
|
385 |
#' |
|
386 |
#' @return The processed object, possibly converted or left unchanged. |
|
387 |
#' |
|
388 |
#' @keywords internal |
|
389 |
.convert_teal_card_input <- function(x) { |
|
390 | 660x |
if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) { |
391 | 16x |
return(x) |
392 |
} |
|
393 | 644x |
if (inherits(x, "chunk_output")) { |
394 | 28x |
res <- structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output")) |
395 | 28x |
attributes(res) <- attributes(x) # keep same attributes |
396 | 28x |
res |
397 | 616x |
} else if (inherits(x, "ggplot")) { |
398 | 52x |
.ggplot_to_recordedplot(x) |
399 |
} else { |
|
400 | 564x |
x |
401 |
} |
|
402 |
} |
|
403 | ||
404 |
#' @noRd |
|
405 |
.ggplot_to_recordedplot <- function(x) { |
|
406 | 52x |
checkmate::assert_class(x, "ggplot") |
407 | 52x |
grDevices::pdf(file = NULL) |
408 | 52x |
grDevices::dev.control(displaylist = "enable") |
409 | 52x |
dev <- grDevices::dev.cur() |
410 | 52x |
on.exit(grDevices::dev.off(dev)) |
411 | 52x |
print(x) |
412 | 52x |
grDevices::recordPlot() |
413 |
} |
|
414 | ||
415 |
#' Determine default dimensions for report figures |
|
416 |
#' |
|
417 |
#' @param x An object, typically a `recordedplot` or `ggplot`, that has an |
|
418 |
#' optional attributes `dev.width` and `dev.height` that override the default |
|
419 |
#' dims set as options `teal.reporter.dev.fig.width` and |
|
420 |
#' `teal.reporter.dev.fig.height`. |
|
421 |
#' @return List with `width` and `height` elements. |
|
422 |
#' @keywords internal |
|
423 |
.determine_default_dimensions <- function(x, convert_to_inches = FALSE, dpi = 96) { |
|
424 | 73x |
checkmate::assert_flag(convert_to_inches) |
425 | 73x |
width <- attr(x, "dev.width") %||% getOption("teal.reporter.dev.fig.width", 800) |
426 | 73x |
height <- attr(x, "dev.height") %||% getOption("teal.reporter.dev.fig.height", 600) |
427 | 73x |
if (width < 150 || height < 150) { |
428 | ! |
warning("Figure dimensions too small, setting to minimum of 150x150 pixels.") |
429 | ! |
width <- max(width, 150) |
430 | ! |
height <- max(height, 150) |
431 |
} |
|
432 | ||
433 | 73x |
if (convert_to_inches) { |
434 | 16x |
width <- width / dpi |
435 | 16x |
height <- height / dpi |
436 |
} |
|
437 | 73x |
list(width = width, height = height) |
438 |
} |
1 |
#' @title `Reporter`: An `R6` class for managing reports |
|
2 |
#' @docType class |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' This `R6` class is designed to store and manage reports, |
|
6 |
#' facilitating the creation, manipulation, and serialization of report-related data. |
|
7 |
#' It supports both `ReportCard` and `teal_card` objects, allowing flexibility |
|
8 |
#' in the types of reports that can be stored and managed. |
|
9 |
#' |
|
10 |
#' @export |
|
11 |
#' |
|
12 |
Reporter <- R6::R6Class( # nolint: object_name_linter. |
|
13 |
classname = "Reporter", |
|
14 |
public = list( |
|
15 |
#' @description Initialize a `Reporter` object. |
|
16 |
#' |
|
17 |
#' @return Object of class `Reporter`, invisibly. |
|
18 |
#' @examples |
|
19 |
#' reporter <- Reporter$new() |
|
20 |
#' |
|
21 |
initialize = function() { |
|
22 | 96x |
private$cards <- shiny::reactiveValues() |
23 | 96x |
private$cached_html <- shiny::reactiveValues() |
24 | 96x |
private$open_previewer_r <- shiny::reactiveVal(NULL) |
25 | 96x |
invisible(self) |
26 |
}, |
|
27 |
#' @description Append one or more `ReportCard` or `teal_card` objects to the `Reporter`. |
|
28 |
#' |
|
29 |
#' @param cards (`ReportCard` or `teal_card`) or a list of such objects |
|
30 |
#' @return `self`, invisibly. |
|
31 |
#' @examplesIf require("ggplot2") |
|
32 |
#' library(ggplot2) |
|
33 |
#' |
|
34 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
35 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
36 |
#' metadata(card1, "title") <- "Card1" |
|
37 |
#' |
|
38 |
#' card2 <- teal_card("Document introduction") |
|
39 |
#' metadata(card2, "title") <- "Card2" |
|
40 |
#' |
|
41 |
#' reporter <- Reporter$new() |
|
42 |
#' reporter$append_cards(list(card1, card2)) |
|
43 |
append_cards = function(cards) { |
|
44 | 83x |
if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) { |
45 | 13x |
cards <- list(cards) |
46 |
} |
|
47 | ||
48 | 83x |
checkmate::assert_list(cards, types = c("ReportCard", "teal_card")) |
49 | 83x |
new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content()) |
50 | ||
51 | 83x |
if (!is.null(self$get_template())) { |
52 | 2x |
new_cards <- lapply(new_cards, self$get_template()) |
53 |
} |
|
54 | ||
55 |
# Set up unique id for each card |
|
56 | 83x |
names(new_cards) <- vapply(new_cards, function(card) { |
57 | 126x |
sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8)) |
58 | 83x |
}, character(1L)) |
59 | ||
60 | 83x |
for (card_id in names(new_cards)) { |
61 | 126x |
card <- new_cards[[card_id]] |
62 | 126x |
private$cards[[card_id]] <- card |
63 | 126x |
private$cached_html[[card_id]] <- lapply(card, tools::toHTML) |
64 |
} |
|
65 | 83x |
invisible(self) |
66 |
}, |
|
67 |
#' @description Reorders `teal_card` objects in `Reporter`. |
|
68 |
#' @param new_order `character` vector with names of `teal_card` objects to |
|
69 |
#' be set in this order. |
|
70 |
#' @description Reorders `teal_card` objects in `Reporter`. |
|
71 |
#' @return `self`, invisibly. |
|
72 |
#' @examplesIf require("ggplot2") |
|
73 |
#' library(ggplot2) |
|
74 |
#' library(rtables) |
|
75 |
#' |
|
76 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
77 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
78 |
#' metadata(card1, "title") <- "Card1" |
|
79 |
#' |
|
80 |
#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) |
|
81 |
#' table_res2 <- build_table(lyt, airquality) |
|
82 |
#' card2 <- teal_card( |
|
83 |
#' "## Header 2 text", |
|
84 |
#' "A paragraph of default text", |
|
85 |
#' table_res2 |
|
86 |
#' ) |
|
87 |
#' metadata(card2, "title") <- "Card2" |
|
88 |
#' |
|
89 |
#' reporter <- Reporter$new() |
|
90 |
#' reporter$append_cards(list(card1, card2)) |
|
91 |
#' |
|
92 |
#' names(reporter$get_cards()) |
|
93 |
#' reporter$reorder_cards(c("Card2", "Card1")) |
|
94 |
#' names(reporter$get_cards()) |
|
95 |
reorder_cards = function(new_order) { |
|
96 | 3x |
private$override_order <- new_order |
97 | 3x |
invisible(self) |
98 |
}, |
|
99 |
#' @description Sets `ReportCard` or `teal_card` content. |
|
100 |
#' @param card_id (`character(1)`) the unique id of the card to be replaced. |
|
101 |
#' @param card The new object (`ReportCard` or `teal_card`) to replace the existing one. |
|
102 |
#' @return `self`, invisibly. |
|
103 |
#' @examplesIf require("ggplot2") |
|
104 |
#' library(ggplot2) |
|
105 |
#' library(rtables) |
|
106 |
#' |
|
107 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
108 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
109 |
#' metadata(card1, "title") <- "Card1" |
|
110 |
#' |
|
111 |
#' reporter <- Reporter$new() |
|
112 |
#' reporter$append_cards(list(card1)) |
|
113 |
#' |
|
114 |
#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) |
|
115 |
#' table_res2 <- build_table(lyt, airquality) |
|
116 |
#' card2 <- teal_card( |
|
117 |
#' "## Header 2 text", |
|
118 |
#' "A paragraph of default text", |
|
119 |
#' table_res2 |
|
120 |
#' ) |
|
121 |
#' metadata(card2, "title") <- "Card2" |
|
122 |
#' |
|
123 |
#' metadata(reporter$get_cards()[[1]], "title") |
|
124 |
#' reporter$replace_card(card2, names(reporter$get_cards())[[1]]) |
|
125 |
#' metadata(reporter$get_cards()[[1]], "title") |
|
126 |
replace_card = function(card, card_id) { |
|
127 | 1x |
if (inherits(card, "ReportCard")) { |
128 | ! |
card <- card$get_content() |
129 |
} |
|
130 | 1x |
private$cards[[card_id]] <- card |
131 | 1x |
private$cached_html[[card_id]] <- lapply(card, tools::toHTML) |
132 | 1x |
invisible(self) |
133 |
}, |
|
134 |
#' @description Retrieves all `teal_card` objects contained in `Reporter`. |
|
135 |
#' @return A (`list`) of [`teal_card`] objects. |
|
136 |
#' @examplesIf require("ggplot2") |
|
137 |
#' library(ggplot2) |
|
138 |
#' library(rtables) |
|
139 |
#' |
|
140 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
141 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
142 |
#' |
|
143 |
#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) |
|
144 |
#' table_res2 <- build_table(lyt, airquality) |
|
145 |
#' card2 <- teal_card( |
|
146 |
#' "## Header 2 text", |
|
147 |
#' "A paragraph of default text", |
|
148 |
#' table_res2 |
|
149 |
#' ) |
|
150 |
#' |
|
151 |
#' reporter <- Reporter$new() |
|
152 |
#' reporter$append_cards(list(card1, card2)) |
|
153 |
#' reporter$get_cards() |
|
154 |
get_cards = function() { |
|
155 | 215x |
result <- if (shiny::isRunning()) { |
156 | ! |
shiny::reactiveValuesToList(private$cards) |
157 |
} else { |
|
158 | 215x |
shiny::isolate(shiny::reactiveValuesToList(private$cards)) |
159 |
} |
|
160 | 215x |
result <- Filter(Negate(is.null), result) # Exclude all cards that were removed |
161 |
# Ensure that cards added after reorder are returned (as well as reordered ones that were removed are excluded) |
|
162 | 215x |
result[union(intersect(private$override_order, names(result)), names(result))] |
163 |
}, |
|
164 |
#' @description Compiles and returns all content blocks from the `teal_card` |
|
165 |
#' objects in the `Reporter`. |
|
166 |
#' @param sep An optional separator to insert between each content block. |
|
167 |
#' Default is a `\n\\newpage\n` markdown. |
|
168 |
#' @return `list()` of `teal_card` |
|
169 |
#' @examplesIf require("ggplot2") |
|
170 |
#' library(ggplot2) |
|
171 |
#' library(rtables) |
|
172 |
#' |
|
173 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
174 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
175 |
#' |
|
176 |
#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) |
|
177 |
#' table_res2 <- build_table(lyt, airquality) |
|
178 |
#' card2 <- teal_card( |
|
179 |
#' "## Header 2 text", |
|
180 |
#' "A paragraph of default text", |
|
181 |
#' table_res2 |
|
182 |
#' ) |
|
183 |
#' |
|
184 |
#' reporter <- Reporter$new() |
|
185 |
#' reporter$append_cards(list(card1, card2)) |
|
186 |
#' reporter$get_blocks() |
|
187 |
get_blocks = function(sep = "\\newpage") { |
|
188 | 48x |
cards <- self$get_cards() |
189 | 48x |
blocks <- teal_card() |
190 | 48x |
for (idx in seq_along(cards)) { |
191 | 59x |
card <- unname(cards[[idx]]) # unname to avoid names conflict in c() |
192 | 59x |
title <- trimws(metadata(card, "title")) |
193 | 59x |
metadata(card)$title <- NULL |
194 | ||
195 | 59x |
card_title <- if (length(title) > 0 && nzchar(title)) { |
196 | 8x |
sprintf("# %s", title) |
197 |
} else { |
|
198 | 51x |
sprintf("# _Unnamed Card (%d)_", idx) |
199 |
} |
|
200 | 59x |
blocks <- c(blocks, as.teal_card(card_title), card) |
201 | 11x |
if (idx != length(cards) && length(sep)) blocks <- c(blocks, trimws(sep)) |
202 |
} |
|
203 | 48x |
blocks |
204 |
}, |
|
205 |
#' @description Resets the `Reporter`, removing all `teal_card` objects and metadata. |
|
206 |
#' |
|
207 |
#' @return `self`, invisibly. |
|
208 |
#' |
|
209 |
reset = function() { |
|
210 | 27x |
if (shiny::isRunning()) { |
211 | ! |
for (card_id in names(private$cards)) private$cards[[card_id]] <- NULL |
212 |
} else { |
|
213 | 27x |
private$cards <- shiny::reactiveValues() |
214 |
} |
|
215 | 27x |
private$override_order <- character(0L) |
216 | 27x |
private$metadata <- list() |
217 | 27x |
invisible(self) |
218 |
}, |
|
219 |
#' @description Removes specific `teal_card` objects from the `Reporter` by their indices. |
|
220 |
#' |
|
221 |
#' @param ids (`integer`, `character`) the indexes of cards (either name) |
|
222 |
#' @return `self`, invisibly. |
|
223 |
remove_cards = function(ids = NULL) { |
|
224 | 2x |
checkmate::assert( |
225 | 2x |
checkmate::check_null(ids), |
226 | 2x |
checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards)), |
227 | 2x |
checkmate::check_character(ids, min.len = 1, max.len = length(private$cards)) |
228 |
) |
|
229 | 2x |
for (card_id in ids) { |
230 | 2x |
private$cards[[card_id]] <- NULL |
231 |
} |
|
232 | 2x |
invisible(self) |
233 |
}, |
|
234 |
#' @description Get the metadata associated with this `Reporter`. |
|
235 |
#' |
|
236 |
#' @return `named list` of metadata to be appended. |
|
237 |
#' @examples |
|
238 |
#' reporter <- Reporter$new()$append_metadata(list(sth = "sth")) |
|
239 |
#' reporter$get_metadata() |
|
240 |
#' |
|
241 | 39x |
get_metadata = function() private$metadata, |
242 |
#' @description Appends metadata to this `Reporter`. |
|
243 |
#' |
|
244 |
#' @param meta (`named list`) of metadata to be appended. |
|
245 |
#' @return `self`, invisibly. |
|
246 |
#' @examples |
|
247 |
#' reporter <- Reporter$new()$append_metadata(list(sth = "sth")) |
|
248 |
#' reporter$get_metadata() |
|
249 |
#' |
|
250 |
append_metadata = function(meta) { |
|
251 | 31x |
checkmate::assert_list(meta, names = "unique") |
252 | 25x |
checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata))) |
253 | 23x |
private$metadata <- append(private$metadata, meta) |
254 | 23x |
invisible(self) |
255 |
}, |
|
256 |
#' @description |
|
257 |
#' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`. |
|
258 |
#' @param reporter (`Reporter`) instance to copy from. |
|
259 |
#' @return invisibly self |
|
260 |
#' @examples |
|
261 |
#' reporter <- Reporter$new() |
|
262 |
#' reporter$from_reporter(reporter) |
|
263 |
from_reporter = function(reporter) { |
|
264 | 10x |
lifecycle::deprecate_warn("0.5.0.9000", "Reporter$from_reporter()") |
265 | 10x |
checkmate::assert_class(reporter, "Reporter") |
266 | 10x |
self$reset() |
267 | 10x |
self$append_cards(reporter$get_cards()) |
268 | 10x |
self$append_metadata(reporter$get_metadata()) |
269 | 10x |
invisible(self) |
270 |
}, |
|
271 |
#' @description Convert a `Reporter` to a list and transfer any associated files to specified directory. |
|
272 |
#' @param output_dir (`character(1)`) a path to the directory where files will be copied. |
|
273 |
#' @return `named list` representing the `Reporter` instance, including version information, |
|
274 |
#' metadata, and report cards. |
|
275 |
#' @examples |
|
276 |
#' reporter <- Reporter$new() |
|
277 |
#' tmp_dir <- file.path(tempdir(), "testdir") |
|
278 |
#' dir.create(tmp_dir) |
|
279 |
#' reporter$to_list(tmp_dir) |
|
280 |
to_list = function(output_dir) { |
|
281 | 17x |
checkmate::assert_directory_exists(output_dir) |
282 | 15x |
rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list()) |
283 | 15x |
rlist[["metadata"]] <- self$get_metadata() |
284 | 15x |
cards <- self$get_cards() |
285 | 15x |
for (i in seq_along(cards)) { |
286 |
# we want to have list names being a class names to indicate the class for $from_list |
|
287 | 20x |
card <- cards[[i]] |
288 | 20x |
card_class <- class(card)[1] |
289 | 20x |
u_card <- list() |
290 | 20x |
tmp <- tempfile(fileext = ".rds") |
291 | 20x |
suppressWarnings(saveRDS(card, file = tmp)) |
292 | 20x |
tmp_base <- basename(tmp) |
293 | 20x |
file.copy(tmp, file.path(output_dir, tmp_base)) |
294 | 20x |
u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base) |
295 | 20x |
rlist$cards <- c(rlist$cards, u_card) |
296 |
} |
|
297 | 15x |
rlist |
298 |
}, |
|
299 |
#' @description Extracts and saves all figure elements from the `teal_card` objects in the |
|
300 |
#' `Reporter` to a specified directory. |
|
301 |
#' @param output_dir (`character(1)`) a path to the directory where figures will be saved. |
|
302 |
#' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures. |
|
303 |
write_figures = function(output_dir, sub_directory = "figures") { |
|
304 | 5x |
figures_dir <- file.path(output_dir, sub_directory) |
305 | 5x |
dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE) |
306 | 5x |
cards <- self$get_cards() |
307 | 5x |
for (card_id in names(cards)) { |
308 | 6x |
card <- cards[[card_id]] |
309 | 6x |
cached_html <- self$get_cached_html(card_id) |
310 | 6x |
for (element_ix in seq_along(card)) { |
311 | 19x |
card_element <- card[[element_ix]] |
312 |
if ( |
|
313 | 19x |
inherits(card_element, "chunk_output") && |
314 | 19x |
checkmate::test_multi_class( |
315 | 19x |
card_element[[1]], |
316 | 19x |
classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap") |
317 |
) |
|
318 |
) { |
|
319 | ! |
base64_image <- cached_html[[names(card)[[element_ix]]]] |
320 |
if ( # Ensure we only save valid base64 images |
|
321 | ! |
!is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") && |
322 | ! |
!is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src) |
323 |
) { |
|
324 | ! |
b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src) |
325 | ! |
writeBin( |
326 | ! |
jsonlite::base64_dec(b64), |
327 | ! |
file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix)) |
328 |
) |
|
329 |
} |
|
330 |
} |
|
331 |
} |
|
332 |
} |
|
333 |
}, |
|
334 |
#' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory. |
|
335 |
#' @param rlist (`named list`) representing a `Reporter` instance. |
|
336 |
#' @param output_dir (`character(1)`) a path to the directory from which files will be copied. |
|
337 |
#' @return `self`, invisibly. |
|
338 |
#' @note if Report has an id when converting to JSON then It will be compared to the currently available one. |
|
339 |
#' @examples |
|
340 |
#' reporter <- Reporter$new() |
|
341 |
#' tmp_dir <- file.path(tempdir(), "testdir") |
|
342 |
#' unlink(tmp_dir, recursive = TRUE) |
|
343 |
#' dir.create(tmp_dir) |
|
344 |
#' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir) |
|
345 |
from_list = function(rlist, output_dir) { |
|
346 | 8x |
id <- self$get_id() |
347 | 8x |
checkmate::assert_list(rlist) |
348 | 8x |
checkmate::assert_directory_exists(output_dir) |
349 | 8x |
stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter") |
350 | 8x |
stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id) |
351 | 7x |
if (rlist$version %in% c("1")) { |
352 | 7x |
new_cards <- list() |
353 | 7x |
cards_names <- names(rlist$cards) |
354 | 7x |
cards_names <- gsub("[.][0-9]*$", "", cards_names) |
355 | 7x |
for (iter_c in seq_along(rlist$cards)) { |
356 | 12x |
card_class <- cards_names[iter_c] |
357 | 12x |
card <- rlist$cards[[iter_c]] |
358 | 12x |
if (card_class == "teal_card") { |
359 | 12x |
new_card <- readRDS(file.path(output_dir, card$path)) |
360 | 12x |
class(new_card) <- "teal_card" |
361 | 12x |
new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards |
362 | 12x |
names(new_card) <- card$name |
363 |
} else { |
|
364 | ! |
new_card <- eval(str2lang(card_class))$new() |
365 | ! |
new_card$from_list(card, output_dir) |
366 |
} |
|
367 | 12x |
new_cards <- c(new_cards, new_card) |
368 |
} |
|
369 |
} else { |
|
370 | ! |
stop( |
371 | ! |
sprintf( |
372 | ! |
"The provided %s reporter version is not supported.", |
373 | ! |
rlist$version |
374 |
) |
|
375 |
) |
|
376 |
} |
|
377 | 7x |
self$reset() |
378 | 7x |
self$set_id(rlist$id) |
379 | 7x |
self$append_cards(new_cards) |
380 | 7x |
self$append_metadata(rlist$metadata) |
381 | 7x |
invisible(self) |
382 |
}, |
|
383 |
#' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory. |
|
384 |
#' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics. |
|
385 |
#' @return `output_dir` argument. |
|
386 |
#' @examples |
|
387 |
#' reporter <- Reporter$new() |
|
388 |
#' tmp_dir <- file.path(tempdir(), "jsondir") |
|
389 |
#' dir.create(tmp_dir) |
|
390 |
#' reporter$to_jsondir(tmp_dir) |
|
391 |
to_jsondir = function(output_dir) { |
|
392 | 13x |
checkmate::assert_directory_exists(output_dir) |
393 | 11x |
json <- self$to_list(output_dir) |
394 | 11x |
cat( |
395 | 11x |
jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), |
396 | 11x |
file = file.path(output_dir, "Report.json") |
397 |
) |
|
398 | 11x |
output_dir |
399 |
}, |
|
400 |
#' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory. |
|
401 |
#' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics. |
|
402 |
#' @return `self`, invisibly. |
|
403 |
#' @note if Report has an id when converting to JSON then It will be compared to the currently available one. |
|
404 |
#' @examples |
|
405 |
#' reporter <- Reporter$new() |
|
406 |
#' tmp_dir <- file.path(tempdir(), "jsondir") |
|
407 |
#' dir.create(tmp_dir) |
|
408 |
#' unlink(list.files(tmp_dir, recursive = TRUE)) |
|
409 |
#' reporter$to_jsondir(tmp_dir) |
|
410 |
#' reporter$from_jsondir(tmp_dir) |
|
411 |
from_jsondir = function(output_dir) { |
|
412 | 5x |
checkmate::assert_directory_exists(output_dir) |
413 | 5x |
dir_files <- list.files(output_dir) |
414 | 5x |
stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0) |
415 | 5x |
stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files)) |
416 | 5x |
json <- jsonlite::read_json(file.path(output_dir, "Report.json")) |
417 | 5x |
self$reset() |
418 | 5x |
self$from_list(json, output_dir) |
419 | 4x |
invisible(self) |
420 |
}, |
|
421 |
#' @description Set the `Reporter` id |
|
422 |
#' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list. |
|
423 |
#' The id is added to the downloaded file name. |
|
424 |
#' @param id (`character(1)`) a Report id. |
|
425 |
#' @return `self`, invisibly. |
|
426 |
set_id = function(id) { |
|
427 | 14x |
private$id <- id |
428 | 14x |
invisible(self) |
429 |
}, |
|
430 |
#' @description Get or set the reactive trigger to open the previewer modal. |
|
431 |
#' @param val value to the passed to the reactive trigger. |
|
432 |
#' @return `reactiveVal` value |
|
433 |
open_previewer = function(val) { |
|
434 | 9x |
if (missing(val)) { |
435 | 7x |
private$open_previewer_r() |
436 |
} else { |
|
437 | 2x |
private$open_previewer_r(val) |
438 |
} |
|
439 |
}, |
|
440 |
#' @description Get cached HTML for a specific `teal_card` by its id. |
|
441 |
#' @param card_id (`character(1)`) the unique id of the card. |
|
442 |
get_cached_html = function(card_id) { |
|
443 | 9x |
if (shiny::isRunning()) { |
444 | ! |
private$cached_html[[card_id]] |
445 |
} else { |
|
446 | 9x |
shiny::isolate(private$cached_html[[card_id]]) |
447 |
} |
|
448 |
}, |
|
449 |
#' @description Get the `Reporter` id |
|
450 |
#' @return `character(1)` the `Reporter` id. |
|
451 | 43x |
get_id = function() private$id, |
452 |
#' @description Set template function for `teal_card` |
|
453 |
#' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards` |
|
454 |
#' @param template (`function`) a template function. |
|
455 |
#' @return `self`, invisibly. |
|
456 |
#' @examples |
|
457 |
#' |
|
458 |
#' reporter <- teal.reporter::Reporter$new() |
|
459 |
#' template_fun <- function(document) { |
|
460 |
#' disclaimer <- teal.reporter::teal_card("Here comes disclaimer text") |
|
461 |
#' c(disclaimer, document) |
|
462 |
#' } |
|
463 |
#' reporter$set_template(template_fun) |
|
464 |
#' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text") |
|
465 |
#' metadata(doc1, "title") <- "Welcome card" |
|
466 |
#' reporter$append_cards(doc1) |
|
467 |
#' reporter$get_cards() |
|
468 |
set_template = function(template) { |
|
469 | 2x |
private$template <- template |
470 | 2x |
invisible(self) |
471 |
}, |
|
472 |
#' @description Get the `Reporter` template |
|
473 |
#' @return a template `function`. |
|
474 | 95x |
get_template = function() private$template |
475 |
), |
|
476 |
private = list( |
|
477 |
id = "", |
|
478 |
cards = NULL, # reactiveValues |
|
479 |
cached_html = NULL, # reactiveValues |
|
480 |
open_previewer_r = NULL, # reactiveVal to trigger reactive contexts |
|
481 |
override_order = character(0L), # to sort cards (reactiveValues are not sortable) |
|
482 |
metadata = list(), |
|
483 |
template = NULL, |
|
484 |
# @description The copy constructor. |
|
485 |
# |
|
486 |
# @param name the name of the field |
|
487 |
# @param value the value of the field |
|
488 |
# @return the new value of the field |
|
489 |
# |
|
490 |
deep_clone = function(name, value) { |
|
491 | 31x |
shiny::isolate({ |
492 | 31x |
if (name == "cards") { |
493 | 1x |
new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) { |
494 | 1x |
if (R6::is.R6(card)) card$clone(deep = TRUE) else card |
495 |
}) |
|
496 | 1x |
do.call(shiny::reactiveValues, new_cards) |
497 |
} else { |
|
498 | 30x |
value |
499 |
} |
|
500 |
}) |
|
501 |
} |
|
502 |
), |
|
503 |
lock_objects = TRUE, |
|
504 |
lock_class = TRUE |
|
505 |
) |
1 |
#' Concatenate `teal_report` objects |
|
2 |
#' |
|
3 |
#' @param ... (`teal_report`) objects to concatenate |
|
4 |
#' @param verbose (`logical`) If `TRUE`, will print a warning when appending `teal_report` objects that |
|
5 |
#' share elements of their `teal_card` objects. |
|
6 |
#' |
|
7 |
#' @return A [`teal_report`] object with combined [`teal_card`] elements. |
|
8 |
#' |
|
9 |
#' @export |
|
10 |
#' @method c teal_report |
|
11 |
c.teal_report <- function(..., verbose = TRUE) { |
|
12 | 53x |
result <- NextMethod() |
13 | 53x |
l <- Filter(function(x) inherits(x, "teal_report"), list(...)) |
14 | 53x |
if (length(l) > 1) { |
15 | 4x |
teal_card(result) <- do.call(c, c(lapply(l, teal_card), verbose = verbose)) |
16 |
} |
|
17 | 53x |
result |
18 |
} |
1 |
ui_previewer_card_actions <- function(id) { |
|
2 | 1x |
ns <- shiny::NS(id) |
3 | 1x |
shiny::tagList( |
4 | 1x |
shiny::actionLink( |
5 | 1x |
inputId = ns("toggle_code_action"), |
6 | 1x |
class = "btn btn-outline-secondary btn-sm float-end p-3 card-code-toggle", |
7 | 1x |
style = "background-color: white !important; z-index: 10 !important; position: relative !important;", |
8 | 1x |
label = NULL, |
9 | 1x |
title = "Toggle code chunks", |
10 | 1x |
icon = shiny::icon("code") |
11 |
), |
|
12 | 1x |
shiny::actionLink( |
13 | 1x |
inputId = ns("edit_action"), |
14 | 1x |
class = "btn btn-primary btn-sm float-end p-3", |
15 | 1x |
label = NULL, |
16 | 1x |
title = "Edit card", |
17 | 1x |
icon = shiny::icon("edit") |
18 |
), |
|
19 | 1x |
shiny::actionLink( |
20 | 1x |
inputId = ns("remove_action"), |
21 | 1x |
class = "btn btn-danger btn-sm float-end p-3", |
22 | 1x |
label = NULL, |
23 | 1x |
icon = shiny::icon("trash-alt"), |
24 |
) |
|
25 |
) |
|
26 |
} |
|
27 | ||
28 |
srv_previewer_card_actions <- function(id, card_r, card_id, reporter) { |
|
29 | 6x |
shiny::moduleServer(id, function(input, output, session) { |
30 | 6x |
new_card_rv <- shiny::reactiveVal() |
31 | ||
32 | 6x |
shiny::observeEvent( |
33 | 6x |
ignoreInit = TRUE, |
34 | 6x |
input$edit_action, |
35 |
{ |
|
36 | 1x |
template_card <- card_r() |
37 | 1x |
new_card_rv(template_card) |
38 | 1x |
title <- metadata(template_card, "title") |
39 | 1x |
if (is.null(title) || isFALSE(nzchar(title))) { |
40 | 1x |
title <- shiny::tags$span(class = "text-muted", "(Empty title)") |
41 |
} |
|
42 | ||
43 | 1x |
shiny::showModal( |
44 | 1x |
shiny::modalDialog( |
45 | 1x |
title = shiny::tags$span( |
46 | 1x |
class = "edit_title_container", |
47 | 1x |
"Editing Card:", |
48 | 1x |
shiny::tags$span(id = session$ns("static_title"), title), |
49 | 1x |
shiny::actionButton( |
50 | 1x |
session$ns("edit_title"), |
51 | 1x |
label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"), |
52 | 1x |
class = "fs-6", |
53 | 1x |
title = "Edit title" |
54 |
), |
|
55 | 1x |
shinyjs::hidden( |
56 | 1x |
shiny::textInput( |
57 | 1x |
session$ns("new_title"), |
58 | 1x |
label = NULL, value = metadata(template_card, "title") |
59 |
) |
|
60 |
) |
|
61 |
), |
|
62 | 1x |
size = "l", |
63 | 1x |
easyClose = TRUE, |
64 | 1x |
shiny::tagList( |
65 | 1x |
ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)), |
66 | 1x |
shiny::uiOutput(session$ns("add_text_element_button_ui")) |
67 |
), |
|
68 | 1x |
footer = shiny::tagList( |
69 | 1x |
shiny::actionButton(session$ns("edit_save"), label = "Save"), |
70 | 1x |
shiny::modalButton("Close") |
71 |
) |
|
72 |
) |
|
73 |
) |
|
74 |
} |
|
75 |
) |
|
76 | ||
77 | 6x |
block_input_names_rvs <- srv_card_editor("editor", new_card_rv) |
78 | ||
79 | 6x |
shiny::observeEvent(input$edit_title, { |
80 | ! |
shinyjs::hide("edit_title") |
81 | ! |
shinyjs::hide("static_title") |
82 | ! |
shinyjs::show("new_title") |
83 | ! |
shinyjs::js$jumpToFocus(session$ns("new_title")) |
84 |
}) |
|
85 | ||
86 |
# Handle |
|
87 | 6x |
shiny::observeEvent(input$edit_save, { |
88 | 1x |
new_card <- shiny::req(new_card_rv()) |
89 | 1x |
input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs)) |
90 | 1x |
for (name in names(input_r)) { |
91 | 2x |
new_card[[name]] <- shiny::isolate(input_r[[name]]()) |
92 |
} |
|
93 | 1x |
if (isFALSE(is.null(input$new_title))) { |
94 | ! |
metadata(new_card, "title") <- input$new_title |
95 |
} |
|
96 | 1x |
if (isFALSE(identical(new_card, card_r()))) { |
97 | 1x |
tryCatch( |
98 |
{ |
|
99 | 1x |
reporter$replace_card(card = new_card, card_id = card_id) |
100 | 1x |
new_card_rv(NULL) |
101 | 1x |
reporter$open_previewer(Sys.time()) |
102 | 1x |
shiny::showNotification("Card was successfully updated.", type = "message") |
103 |
}, |
|
104 | 1x |
error = function(err) { |
105 | ! |
shiny::showNotification( |
106 | ! |
sprintf( |
107 | ! |
"A card with the name '%s' already exists. Please use a different name.", |
108 | ! |
metadata(new_card, "title") |
109 |
), |
|
110 | ! |
type = "error", |
111 | ! |
duration = 5 |
112 |
) |
|
113 | ! |
shinyjs::enable("edit_save") |
114 |
} |
|
115 |
) |
|
116 |
} else { |
|
117 | ! |
new_card_rv(NULL) |
118 | ! |
reporter$open_previewer(Sys.time()) |
119 |
} |
|
120 |
}) |
|
121 | ||
122 | 6x |
shiny::observeEvent(input$toggle_code_action, { |
123 | ! |
shinyjs::runjs(sprintf("toggleRCodeAccordions('%s');", card_id)) |
124 |
}) |
|
125 | ||
126 |
# Handle remove button |
|
127 | 6x |
shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id)) |
128 |
}) |
|
129 |
} |
1 |
setOldClass("teal_card") |
|
2 | ||
3 |
#' Reproducible report |
|
4 |
#' |
|
5 |
#' Reproducible report container class. Inherits code tracking behavior from [`teal.data::teal_data-class`]. |
|
6 |
#' |
|
7 |
#' This class provides an isolated environment in which to store and process data with all code being recorded. |
|
8 |
#' The environment, code, data set names, and data joining keys are stored in their respective slots. |
|
9 |
#' These slots should never be accessed directly, use the provided get/set functions. |
|
10 |
#' |
|
11 |
#' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots. |
|
12 |
#' If errors are raised, a `qenv.error` object is returned. |
|
13 |
#' |
|
14 |
#' @name teal_report-class |
|
15 |
#' @rdname teal_report-class |
|
16 |
#' |
|
17 |
#' @slot .xData (`environment`) environment containing data sets and possibly |
|
18 |
#' auxiliary variables. |
|
19 |
#' Access variables with [get()], [`$`] or [`[[`]. |
|
20 |
#' No setter provided. Evaluate code to add variables into `@.xData`. |
|
21 |
#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `qenv`. |
|
22 |
#' Access with [teal.code::get_code()]. |
|
23 |
#' No setter provided. Evaluate code to append code to the slot. |
|
24 |
#' @slot join_keys (`join_keys`) object specifying joining keys for data sets in |
|
25 |
#' `@.xData`. |
|
26 |
#' Access or modify with [teal.data::join_keys()]. |
|
27 |
#' @slot verified (`logical(1)`) flag signifying that code in `@code` has been |
|
28 |
#' proven to yield contents of `@.xData`. |
|
29 |
#' Used internally. See [`teal.data::verify()`] for more details. |
|
30 |
#' @slot card (`teal_card`) |
|
31 |
#' @inheritSection teal.data::`teal_data-class` Code |
|
32 |
#' @importFrom teal.data teal_data |
|
33 |
#' @keywords internal |
|
34 |
setClass( |
|
35 |
Class = "teal_report", |
|
36 |
contains = "teal_data", |
|
37 |
slots = c(teal_card = "teal_card") |
|
38 |
) |
|
39 | ||
40 |
#' It initializes the `teal_report` class |
|
41 |
#' |
|
42 |
#' Accepts .xData as a list and converts it to an environment before initializing |
|
43 |
#' parent constructor (`teal_data`). |
|
44 |
#' @noRd |
|
45 |
setMethod( |
|
46 |
"initialize", |
|
47 |
"teal_report", |
|
48 |
function(.Object, teal_card = NULL, ...) { # nolint: object_name. |
|
49 | 50x |
args <- list(...) |
50 | ! |
if (is.null(teal_card)) teal_card <- teal_card() |
51 | 50x |
checkmate::assert_class(teal_card, "teal_card") |
52 | 49x |
checkmate::assert_list(args, names = "named") |
53 | 49x |
methods::callNextMethod( |
54 | 49x |
.Object, |
55 | 49x |
teal_card = teal_card, |
56 |
... |
|
57 |
) |
|
58 |
} |
|
59 |
) |
|
60 | ||
61 |
#' Comprehensive data integration function for `teal` applications |
|
62 |
#' |
|
63 |
#' @description |
|
64 |
#' `r lifecycle::badge("stable")` |
|
65 |
#' |
|
66 |
#' Initializes a reportable data for `teal` application. |
|
67 |
#' |
|
68 |
#' @inheritParams teal.data::teal_data |
|
69 |
#' @param teal_card (`teal_card`) object containing the report content. |
|
70 |
#' @return A `teal_report` object. |
|
71 |
#' |
|
72 |
#' @seealso [`teal.data::teal_data`] |
|
73 |
#' |
|
74 |
#' @export |
|
75 |
#' |
|
76 |
#' @examples |
|
77 |
#' # Initialize teal_report with existing h2 header |
|
78 |
#' report <- teal_report(teal_card = teal_card("## Analysis Report")) |
|
79 |
#' |
|
80 |
#' # Use within() to execute code and add code-chunk |
|
81 |
#' report <- within(report, { |
|
82 |
#' data <- iris |
|
83 |
#' summary_stats <- summary(data) |
|
84 |
#' }) |
|
85 |
#' |
|
86 |
#' # Access objects created within the report |
|
87 |
#' report$data |
|
88 |
#' report$summary_stats |
|
89 |
#' |
|
90 |
#' # within() automatically captures code and outputs |
|
91 |
#' report <- within(report, { |
|
92 |
#' head(iris) |
|
93 |
#' }) |
|
94 |
#' |
|
95 |
#' # Add arbitrary markdown content to the card |
|
96 |
#' teal_card(report) <- c( |
|
97 |
#' teal_card(report), |
|
98 |
#' teal_card("### Conclusion", "The analysis is complete.") |
|
99 |
#' ) |
|
100 |
#' |
|
101 |
#' # View the generated card with code chunks |
|
102 |
#' teal_card(report) |
|
103 |
#' |
|
104 |
#' # View report in HTML format |
|
105 |
#' tools::toHTML(report) |
|
106 |
#' |
|
107 |
#' if (interactive()) { |
|
108 |
#' # Render the report to various formats |
|
109 |
#' render(report, output_format = rmarkdown::html_document()) |
|
110 |
#' render(report, output_format = rmarkdown::pdf_document()) |
|
111 |
#' } |
|
112 |
#' |
|
113 |
teal_report <- function(..., |
|
114 |
teal_card = NULL, |
|
115 |
code = character(0), |
|
116 |
join_keys = teal.data::join_keys()) { |
|
117 | 42x |
if (is.null(teal_card)) teal_card <- teal_card() |
118 | 50x |
methods::new( |
119 | 50x |
"teal_report", |
120 | 50x |
.xData = list2env(list(...)), |
121 | 50x |
teal_card = teal_card, |
122 | 50x |
join_keys = join_keys, |
123 | 50x |
code = code |
124 |
) |
|
125 |
} |
|
126 | ||
127 |
#' Internal function to convert `qenv` or `teal_data` to `teal_report` |
|
128 |
#' @noRd |
|
129 |
coerce.teal_report <- function(from, to) { # nolint: object_name. |
|
130 | 7x |
if (inherits(from, "teal_report")) { |
131 | ! |
return(from) |
132 |
} |
|
133 | 7x |
new_x <- teal_report() |
134 | 7x |
for (slot_name in methods::slotNames(from)) { |
135 | 24x |
methods::slot(new_x, slot_name) <- methods::slot(from, slot_name) |
136 |
} |
|
137 | 7x |
teal_card(new_x) <- .code_to_card(from@code) |
138 | 7x |
new_x |
139 |
} |
|
140 | ||
141 |
methods::setAs("qenv", "teal_report", coerce.teal_report) |
|
142 |
methods::setAs("teal_data", "teal_report", coerce.teal_report) |
|
143 | ||
144 |
#' @rdname teal_report |
|
145 |
#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`. |
|
146 |
#' @export |
|
147 |
as.teal_report <- function(x) { # nolint: object_name. |
|
148 | 8x |
checkmate::assert_class(x, "qenv") |
149 | 8x |
methods::as(x, "teal_report") |
150 |
} |
1 |
#' @title `ReportCard`: An `R6` class for building report elements |
|
2 |
#' @docType class |
|
3 |
#' |
|
4 |
#' @description |
|
5 |
#' `r lifecycle::badge("deprecated")` |
|
6 |
#' |
|
7 |
#' This `R6` class that supports creating a report card containing text, plot, table and |
|
8 |
#' metadata blocks that can be appended and rendered to form a report output from a `shiny` app. |
|
9 |
#' |
|
10 |
#' @section Lifecycle: |
|
11 |
#' This class is deprecated. Use `teal_report` class instead for new implementations. |
|
12 |
#' See `vignette("teal-report-class", "teal.reporter")` for more information. |
|
13 |
#' |
|
14 |
#' @export |
|
15 |
#' |
|
16 |
ReportCard <- R6::R6Class( # nolint: object_name_linter. |
|
17 |
classname = "ReportCard", |
|
18 |
public = list( |
|
19 |
#' @description Initialize a `ReportCard` object. |
|
20 |
#' |
|
21 |
#' @return Object of class `ReportCard`, invisibly. |
|
22 |
#' @examples |
|
23 |
#' card <- ReportCard$new() |
|
24 |
#' |
|
25 |
initialize = function() { |
|
26 | 54x |
lifecycle::deprecate_warn( |
27 | 54x |
when = "0.5.1", |
28 | 54x |
what = "ReportCard$new()", |
29 | 54x |
with = "teal_card()", |
30 | 54x |
details = "Use teal_report class instead. See vignette('teal-report-class', 'teal.reporter') for more information." # nolint: line_length_linter. |
31 |
) |
|
32 | 54x |
private$content <- teal_card() |
33 | 54x |
invisible(self) |
34 |
}, |
|
35 |
#' @description Appends a table to this `ReportCard`. |
|
36 |
#' |
|
37 |
#' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) |
|
38 |
#' that can be coerced into a table. |
|
39 |
#' @return `self`, invisibly. |
|
40 |
#' @examples |
|
41 |
#' card <- ReportCard$new()$append_table(iris) |
|
42 |
#' |
|
43 | 8x |
append_table = function(table) self$append_content(table), |
44 |
#' @description Appends a html content to this `ReportCard`. |
|
45 |
#' |
|
46 |
#' @param content An object that can be rendered as a HTML content. |
|
47 |
#' @return `self`, invisibly. |
|
48 |
#' @examples |
|
49 |
#' card <- ReportCard$new()$append_html(shiny::div("HTML Content")) |
|
50 |
#' |
|
51 | ! |
append_html = function(content) self$append_content(content), |
52 |
#' @description Appends a plot to this `ReportCard`. |
|
53 |
#' |
|
54 |
#' @param plot (`ggplot` or `grob` or `trellis`) plot object. |
|
55 |
#' @param dim (`numeric(2)`) width and height in pixels. |
|
56 |
#' @return `self`, invisibly. |
|
57 |
#' @examplesIf require("ggplot2") |
|
58 |
#' library(ggplot2) |
|
59 |
#' |
|
60 |
#' card <- ReportCard$new()$append_plot( |
|
61 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
62 |
#' ) |
|
63 |
#' |
|
64 |
append_plot = function(plot, dim = NULL) { |
|
65 | 21x |
checkmate::assert_numeric(dim, len = 2, any.missing = FALSE, null.ok = TRUE) |
66 | 21x |
if (!is.null(dim)) { |
67 | 1x |
if (!inherits(plot, "chunk_output")) { |
68 | 1x |
plot <- structure(list(plot), class = c("chunk_output")) |
69 |
} |
|
70 | 1x |
attr(plot, "dev.width") <- dim[1] |
71 | 1x |
attr(plot, "dev.height") <- dim[2] |
72 |
} |
|
73 | 21x |
self$append_content(plot) |
74 |
}, |
|
75 |
#' @description Appends a text paragraph to this `ReportCard`. |
|
76 |
#' |
|
77 |
#' @param text (`character`) The text content to add. |
|
78 |
#' @param style (`character(1)`) the style of the paragraph. |
|
79 |
#' @return `self`, invisibly. |
|
80 |
#' @examples |
|
81 |
#' card <- ReportCard$new()$append_text("A paragraph of default text") |
|
82 |
#' |
|
83 |
append_text = function(text, style = c("default", "header2", "header3", "verbatim")) { |
|
84 | 45x |
styled <- switch(match.arg(style), |
85 | 45x |
"default" = text, |
86 | 45x |
"verbatim" = sprintf("\n```\n%s\n```\n", text), |
87 | 45x |
"header2" = paste0("## ", text), |
88 | 45x |
"header3" = paste0("### ", text), |
89 | 45x |
text |
90 |
) |
|
91 | 45x |
self$append_content(styled) |
92 |
}, |
|
93 |
#' @description Appends an `R` code chunk to `ReportCard`. |
|
94 |
#' |
|
95 |
#' @param text (`character`) The `R` code to include. |
|
96 |
#' @param ... Additional `rmarkdown` parameters for formatting the `R` code chunk. |
|
97 |
#' @return `self`, invisibly. |
|
98 |
#' @examples |
|
99 |
#' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE) |
|
100 |
#' |
|
101 |
append_rcode = function(text, ...) { |
|
102 | 4x |
self$append_content(code_chunk(code = text, ...)) |
103 |
}, |
|
104 |
#' @description Appends a generic content to this `ReportCard`. |
|
105 |
#' |
|
106 |
#' @param content (Object.) |
|
107 |
#' @return `self`, invisibly. |
|
108 |
#' @examples |
|
109 |
#' card <- ReportCard$new()$append_content(code_chunk("foo <- 2")) |
|
110 |
#' |
|
111 |
append_content = function(content) { |
|
112 | 78x |
private$content <- c(private$content, content) |
113 | 78x |
invisible(self) |
114 |
}, |
|
115 |
#' @description Get all content blocks from this `ReportCard`. |
|
116 |
#' |
|
117 |
#' @return `teal_card()` containing appended elements. |
|
118 |
#' @examples |
|
119 |
#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2") |
|
120 |
#' |
|
121 |
#' card$get_content() |
|
122 |
#' |
|
123 |
#' |
|
124 | 34x |
get_content = function() private$content, |
125 |
#' @description Clears all content and metadata from `ReportCard`. |
|
126 |
#' |
|
127 |
#' @return `self`, invisibly. |
|
128 |
#' |
|
129 |
reset = function() { |
|
130 | ! |
private$content <- teal_card() |
131 | ! |
invisible(self) |
132 |
}, |
|
133 |
#' @description Get the metadata associated with `ReportCard`. |
|
134 |
#' |
|
135 |
#' @return `named list` list of elements. |
|
136 |
#' @examples |
|
137 |
#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2") |
|
138 |
#' |
|
139 |
#' card$get_metadata() |
|
140 |
#' |
|
141 |
get_metadata = function() { |
|
142 | 4x |
metadata(private$content) |
143 |
}, |
|
144 |
#' @description Appends metadata to this `ReportCard`. |
|
145 |
#' |
|
146 |
#' @param key (`character(1)`) string specifying the metadata key. |
|
147 |
#' @param value value associated with the metadata key. |
|
148 |
#' @return `self`, invisibly. |
|
149 |
#' @examplesIf require("ggplot2") |
|
150 |
#' library(ggplot2) |
|
151 |
#' |
|
152 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
153 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
154 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
155 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
156 |
#' card$get_content() |
|
157 |
#' card$get_metadata() |
|
158 |
#' |
|
159 |
append_metadata = function(key, value) { |
|
160 | 16x |
checkmate::assert_character(key, min.len = 0, max.len = 1) |
161 | 13x |
checkmate::assert_false(key %in% names(metadata(private$content))) |
162 | 12x |
metadata(private$content, key) <- value |
163 | 11x |
invisible(self) |
164 |
}, |
|
165 |
#' @description Get the name of the `ReportCard`. |
|
166 |
#' |
|
167 |
#' @return `character` a card name. |
|
168 |
#' @examples |
|
169 |
#' ReportCard$new()$set_name("NAME")$get_name() |
|
170 |
get_name = function() { |
|
171 | 9x |
metadata(private$content, "title") %||% character(0L) |
172 |
}, |
|
173 |
#' @description Set the name of the `ReportCard`. |
|
174 |
#' |
|
175 |
#' @param name (`character(1)`) a card name. |
|
176 |
#' @return `self`, invisibly. |
|
177 |
#' @examples |
|
178 |
#' ReportCard$new()$set_name("NAME")$get_name() |
|
179 |
set_name = function(name) { |
|
180 | 17x |
metadata(private$content, "title") <- name |
181 | 17x |
invisible(self) |
182 |
}, |
|
183 |
#' @description Set content block names for compatibility with newer `teal_card` |
|
184 |
#' @param new_names (`character`) vector of new names. |
|
185 |
set_content_names = function(new_names) { |
|
186 | ! |
names(private$content) <- new_names |
187 |
}, |
|
188 |
#' @description Convert the `ReportCard` to a list, including content and metadata. |
|
189 |
#' @param output_dir (`character`) with a path to the directory where files will be copied. |
|
190 |
#' @return (`named list`) a `ReportCard` representation. |
|
191 |
#' @examplesIf require("ggplot2") |
|
192 |
#' library(ggplot2) |
|
193 |
#' |
|
194 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
195 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
196 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
197 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
198 |
#' card$get_content() |
|
199 |
#' |
|
200 |
#' card$to_list(tempdir()) |
|
201 |
#' |
|
202 |
to_list = function(output_dir = lifecycle::deprecated()) { |
|
203 | ! |
if (lifecycle::is_present(output_dir)) { |
204 | ! |
lifecycle::deprecate_soft("0.5.0.9000", "ReportCard$to_list(output_dir)") |
205 |
} |
|
206 | ! |
private$content |
207 |
}, |
|
208 |
#' @description Reconstructs the `ReportCard` from a list representation. |
|
209 |
#' @param card (`named list`) a `ReportCard` representation. |
|
210 |
#' @param output_dir (`character`) with a path to the directory where a file will be copied. |
|
211 |
#' @return `self`, invisibly. |
|
212 |
#' @examplesIf require("ggplot2") |
|
213 |
#' library(ggplot2) |
|
214 |
#' |
|
215 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
216 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
217 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
218 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
219 |
#' card$get_content() |
|
220 |
#' |
|
221 |
#' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir()) |
|
222 |
#' |
|
223 |
from_list = function(card, output_dir = lifecycle::deprecated()) { |
|
224 | ! |
if (lifecycle::is_present(output_dir)) { |
225 | ! |
lifecycle::deprecate_soft("0.5.0.9000", "ReportCard$to_list(output_dir)") |
226 |
} |
|
227 | ! |
self$reset() |
228 | ! |
private$content <- card |
229 | ! |
invisible(self) |
230 |
} |
|
231 |
), |
|
232 |
private = list( |
|
233 |
content = list(), |
|
234 |
name = character(0L), |
|
235 |
id = character(0L), |
|
236 |
# @description The copy constructor. |
|
237 |
# |
|
238 |
# @param name the name of the field |
|
239 |
# @param value the value of the field |
|
240 |
# @return the new value of the field |
|
241 |
# |
|
242 |
deep_clone = function(name, value) { |
|
243 | 42x |
if (name == "content") { |
244 | 2x |
content <- Reduce( |
245 | 2x |
f = function(result, this) { |
246 | 4x |
if (inherits(this, "R6")) { |
247 | ! |
this <- this$clone(deep = TRUE) |
248 |
} |
|
249 | 4x |
c(result, this) |
250 |
}, |
|
251 | 2x |
init = teal_card(), |
252 | 2x |
x = value |
253 |
) |
|
254 | ||
255 | 2x |
metadata(content) <- metadata(value) |
256 | 2x |
content |
257 |
} else { |
|
258 | 40x |
value |
259 |
} |
|
260 |
} |
|
261 |
), |
|
262 |
lock_objects = TRUE, |
|
263 |
lock_class = TRUE |
|
264 |
) |
|
265 | ||
266 |
#' @export |
|
267 |
length.ReportCard <- function(x) { |
|
268 | 1x |
length(x$get_content()) |
269 |
} |
1 |
#' @importFrom tools toHTML |
|
2 |
NULL |
|
3 | ||
4 |
#' Convert report objects to HTML |
|
5 |
#' |
|
6 |
#' @description |
|
7 |
#' `r lifecycle::badge("experimental")` |
|
8 |
#' |
|
9 |
#' The `toHTML` S3 generic method converts various report objects into HTML representations. |
|
10 |
#' This is the primary method for rendering report content for display in web browsers, |
|
11 |
#' IDE Viewer, or for inclusion in Shiny applications. |
|
12 |
#' |
|
13 |
#' @param x The object to convert to HTML. Supported types include: |
|
14 |
#' - `teal_card`: A list-like structure containing report elements |
|
15 |
#' - `teal_report`: A report object containing a `teal_card` |
|
16 |
#' - `ReportCard`: Deprecated R6 class for report cards |
|
17 |
#' - `code_chunk`: Code blocks created with [code_chunk()] |
|
18 |
#' - `chunk_output`: Output from evaluated code chunks |
|
19 |
#' - Plot objects: `ggplot`, `recordedplot`, `trellis`, `grob` |
|
20 |
#' - Table objects: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, |
|
21 |
#' `listing_df`, `gtsummary`, `flextable`, `datatables` |
|
22 |
#' - Text: `character` strings (rendered as markdown) |
|
23 |
#' - Other objects: Conditions, model summaries, etc. |
|
24 |
#' @param ... Additional arguments passed to methods. |
|
25 |
#' |
|
26 |
#' @details |
|
27 |
#' ## Relationship with `teal_card` |
|
28 |
#' |
|
29 |
#' The `teal_card` class is a central component in the `teal.reporter` ecosystem. It is an S3 list |
|
30 |
#' where each element represents a piece of report content (text, plots, tables, code chunks, etc.). |
|
31 |
#' The `toHTML` method for `teal_card` objects: |
|
32 |
#' |
|
33 |
#' 1. Iterates through each element in the `teal_card` list |
|
34 |
#' 2. Calls `toHTML()` recursively on each element based on its class |
|
35 |
#' 3. Wraps all converted elements in a [bslib::card()] container |
|
36 |
#' |
|
37 |
#' This hierarchical conversion allows complex report structures to be rendered as styled HTML |
|
38 |
#' with proper formatting for each content type. |
|
39 |
#' |
|
40 |
#' ## Content Type Conversions |
|
41 |
#' |
|
42 |
#' **Text and Markdown:** Character strings are converted to HTML using `CommonMark` markdown syntax. |
|
43 |
#' Supports headers, lists, code blocks, emphasis, and other markdown features. |
|
44 |
#' |
|
45 |
#' **Code Chunks:** Created with [code_chunk()], these are rendered as collapsible Bootstrap |
|
46 |
#' accordions with syntax highlighting. The accordion includes the programming language indicator |
|
47 |
#' and an icon. |
|
48 |
#' |
|
49 |
#' **Plots:** Plot objects (`ggplot`, `recordedplot`, `trellis`, `grob`) are converted to PNG |
|
50 |
#' images with base64-encoded data URIs, making them self-contained in the HTML output. |
|
51 |
#' |
|
52 |
#' **Tables:** Table objects are converted to styled HTML tables, typically via `flextable` |
|
53 |
#' for consistent formatting. |
|
54 |
#' |
|
55 |
#' ## Viewer Integration |
|
56 |
#' |
|
57 |
#' All HTML output is wrapped with [htmltools::browsable()], which enables: |
|
58 |
#' - Automatic render in IDE Viewer when displayed interactively |
|
59 |
#' - Proper HTML dependency injection (Bootstrap CSS/JavaScript, Font Awesome icons, etc.) |
|
60 |
#' - Standalone HTML files with all required resources |
|
61 |
#' |
|
62 |
#' You can override the `browsable` behavior with: |
|
63 |
#' ```r |
|
64 |
#' print(toHTML(x), browse = FALSE) # Print markup to console instead |
|
65 |
#' ``` |
|
66 |
#' |
|
67 |
#' @return An HTML representation of the input object. The exact return type depends on the |
|
68 |
#' input class: |
|
69 |
#' - For `teal_card`: A `bslib::card()` containing all elements |
|
70 |
#' - For `code_chunk`: A `bslib::accordion()` with the code |
|
71 |
#' - For plots: A `shiny::tags$img()` tag |
|
72 |
#' - For text: HTML markup from markdown conversion |
|
73 |
#' - For tables: HTML table elements |
|
74 |
#' |
|
75 |
#' All returns are wrapped with `htmltools::browsable()` to enable viewer display. |
|
76 |
#' |
|
77 |
#' @seealso |
|
78 |
#' - [teal_report()] for creating report objects |
|
79 |
#' - [teal_card()] for creating report cards |
|
80 |
#' - [code_chunk()] for creating code blocks |
|
81 |
#' - [render()] for rendering complete reports to files |
|
82 |
#' |
|
83 |
#' @examples |
|
84 |
#' # Initialize empty report |
|
85 |
#' report <- teal_report() |
|
86 |
#' |
|
87 |
#' # Add arbitrary markdown elements to the report's teal_card |
|
88 |
#' teal_card(report) <- c( |
|
89 |
#' teal_card(report), |
|
90 |
#' "## Document section", |
|
91 |
#' "Lorem ipsum dolor sit amet" |
|
92 |
#' ) |
|
93 |
#' |
|
94 |
#' # Use within() to execute code and add code-chunk |
|
95 |
#' report <- within(report, a <- 2) |
|
96 |
#' |
|
97 |
#' # within() automatically captures code and outputs |
|
98 |
#' report <- within(report, plot(a)) |
|
99 |
#' |
|
100 |
#' html <- tools::toHTML(report) |
|
101 |
#' # display HTML markup in viewer |
|
102 |
#' html |
|
103 |
#' |
|
104 |
#' # Print HTML markup to console instead of viewer |
|
105 |
#' print(html, browse = FALSE) |
|
106 |
#' |
|
107 |
#' @export |
|
108 |
#' @aliases teal_card-preview |
|
109 |
#' @method toHTML default |
|
110 |
toHTML.default <- function(x, ...) { |
|
111 | 487x |
htmltools::browsable(.toHTML(x, ...)) |
112 |
} |
|
113 | ||
114 |
#' @keywords internal |
|
115 |
.toHTML <- function(x, ...) { # nolint: object_name. |
|
116 | 487x |
UseMethod(".toHTML", x) |
117 |
} |
|
118 | ||
119 |
#' @method .toHTML default |
|
120 |
#' @keywords internal |
|
121 |
.toHTML.default <- function(x, ...) { |
|
122 | 261x |
htmltools::HTML(commonmark::markdown_html(x, extensions = TRUE)) |
123 |
} |
|
124 | ||
125 |
#' @method .toHTML ReportCard |
|
126 |
#' @keywords internal |
|
127 |
.toHTML.ReportCard <- function(x, ...) { |
|
128 | 1x |
shiny::tagList(lapply(x$get_content(), tools::toHTML, ...)) |
129 |
} |
|
130 | ||
131 |
#' @method .toHTML teal_card |
|
132 |
#' @keywords internal |
|
133 |
.toHTML.teal_card <- function(x, ...) { |
|
134 | 2x |
bslib::card(lapply(x, tools::toHTML, ...)) |
135 |
} |
|
136 | ||
137 |
#' @method .toHTML teal_report |
|
138 |
#' @keywords internal |
|
139 |
.toHTML.teal_report <- function(x, ...) { |
|
140 | 1x |
tools::toHTML(teal_card(x), ...) |
141 |
} |
|
142 | ||
143 |
#' @method .toHTML rtables |
|
144 |
#' @keywords internal |
|
145 |
.toHTML.rtables <- function(x, ...) { |
|
146 | 78x |
shiny::tags$pre(tools::toHTML(to_flextable(x))) |
147 |
} |
|
148 | ||
149 |
#' @method .toHTML flextable |
|
150 |
#' @keywords internal |
|
151 |
.toHTML.flextable <- function(x, ...) { |
|
152 | 78x |
flextable::htmltools_value(x) |
153 |
} |
|
154 | ||
155 |
#' @method .toHTML condition |
|
156 |
#' @keywords internal |
|
157 |
.toHTML.condition <- function(x, ...) { |
|
158 | ! |
conditionMessage(x) |
159 |
} |
|
160 | ||
161 |
.plot2html <- function(x, ...) { |
|
162 | 56x |
on.exit(unlink(tmpfile)) |
163 | 56x |
tmpfile <- tempfile(fileext = ".png") |
164 | 56x |
dims <- .determine_default_dimensions(x) |
165 | 56x |
grDevices::png(filename = tmpfile, width = dims$width, height = dims$height) |
166 | 56x |
print(x) |
167 | 56x |
grDevices::dev.off() |
168 | 56x |
shiny::tags$img(src = knitr::image_uri(tmpfile), style = "width: 100%; height: auto;") |
169 |
} |
|
170 | ||
171 |
#' @method .toHTML recordedplot |
|
172 |
#' @keywords internal |
|
173 |
.toHTML.recordedplot <- .plot2html |
|
174 | ||
175 |
#' @method .toHTML trellis |
|
176 |
#' @keywords internal |
|
177 |
.toHTML.trellis <- .plot2html |
|
178 | ||
179 |
#' @method .toHTML gg |
|
180 |
#' @keywords internal |
|
181 |
.toHTML.gg <- function(x, ...) { |
|
182 | 2x |
on.exit(unlink(tmpfile)) |
183 | 2x |
dims <- .determine_default_dimensions(x, convert_to_inches = TRUE, dpi = 100) |
184 | 2x |
tmpfile <- tempfile(fileext = ".png") |
185 | 2x |
ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100) |
186 | 2x |
shiny::tags$img(src = knitr::image_uri(tmpfile)) |
187 |
} |
|
188 | ||
189 |
#' @method .toHTML grob |
|
190 |
#' @keywords internal |
|
191 |
.toHTML.grob <- function(x, ...) { |
|
192 | 1x |
on.exit(unlink(tmpfile)) |
193 | 1x |
dims <- .determine_default_dimensions(x) |
194 | 1x |
tmpfile <- tempfile(fileext = ".png") |
195 | 1x |
grDevices::png(filename = tmpfile, width = dims$width, height = dims$height) |
196 | 1x |
grid::grid.newpage() |
197 | 1x |
grid::grid.draw(x) |
198 | 1x |
grDevices::dev.off() |
199 | 1x |
shiny::tags$img(src = knitr::image_uri(tmpfile)) |
200 |
} |
|
201 | ||
202 |
#' @method .toHTML code_chunk |
|
203 |
#' @keywords internal |
|
204 |
.toHTML.code_chunk <- function(x, ...) { |
|
205 | 5x |
bslib::accordion( |
206 | 5x |
class = "code_chunk", |
207 | 5x |
open = FALSE, |
208 | 5x |
bslib::accordion_panel( |
209 | 5x |
title = shiny::tags$span(shiny::icon("code"), attr(x, "lang", exact = TRUE)), |
210 | 5x |
value = "rcode", |
211 | 5x |
shiny::tags$pre( |
212 | 5x |
shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang", exact = TRUE))), |
213 | 5x |
.noWS = "inside" |
214 |
) |
|
215 |
) |
|
216 |
) |
|
217 |
} |
|
218 | ||
219 |
#' @method .toHTML chunk_output |
|
220 |
#' @keywords internal |
|
221 |
.toHTML.chunk_output <- function(x, ...) { |
|
222 | 2x |
new_x <- x[[1]] |
223 | 2x |
mostattributes(new_x) <- c(attributes(unclass(x)), attributes(new_x)) |
224 | 2x |
tools::toHTML(new_x, ...) |
225 |
} |
|
226 | ||
227 |
#' @method .toHTML summary.lm |
|
228 |
#' @keywords internal |
|
229 |
.toHTML.summary.lm <- function(x, ...) { |
|
230 | ! |
shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n")) |
231 |
} |
|
232 | ||
233 |
#' @method .toHTML TableTree |
|
234 |
#' @keywords internal |
|
235 |
.toHTML.TableTree <- .toHTML.rtables |
|
236 | ||
237 |
#' @method .toHTML ElementaryTable |
|
238 |
#' @keywords internal |
|
239 |
.toHTML.ElementaryTable <- .toHTML.rtables |
|
240 | ||
241 |
#' @method .toHTML rlisting |
|
242 |
#' @keywords internal |
|
243 |
.toHTML.rlisting <- .toHTML.rtables |
|
244 | ||
245 |
#' @method .toHTML data.frame |
|
246 |
#' @keywords internal |
|
247 |
.toHTML.data.frame <- .toHTML.rtables |
|
248 | ||
249 |
#' @method .toHTML datatables |
|
250 |
#' @keywords internal |
|
251 |
.toHTML.datatables <- function(x, ...) { |
|
252 | ! |
x |
253 |
} |
|
254 | ||
255 |
#' @method .toHTML gtsummary |
|
256 |
#' @keywords internal |
|
257 |
.toHTML.gtsummary <- function(x, ...) { |
|
258 | ! |
tools::toHTML(gtsummary::as_flex_table(x)) |
259 |
} |
|
260 | ||
261 |
#' @method .toHTML listing_df |
|
262 |
#' @keywords internal |
|
263 |
.toHTML.listing_df <- function(x, ...) { |
|
264 | ! |
tools::toHTML(flextable::as_flextable(x)) |
265 |
} |
1 |
.onLoad <- function(libname, pkgname) { |
|
2 | 2x |
op <- options() |
3 | ||
4 | 2x |
teal_reporter_default_options <- list( |
5 | 2x |
teal.reporter.global_knitr = list( |
6 | 2x |
echo = TRUE, |
7 | 2x |
tidy.opts = list(width.cutoff = 60), |
8 | 2x |
tidy = requireNamespace("formatR", quietly = TRUE) |
9 |
), |
|
10 | 2x |
teal.reporter.devices.dev.width = 800, |
11 | 2x |
teal.reporter.devices.dev.height = 600, |
12 | 2x |
teal.reporter.rmd_output = c( |
13 | 2x |
"html" = "html_document", "pdf" = "pdf_document", |
14 | 2x |
"powerpoint" = "powerpoint_presentation", |
15 | 2x |
"word" = "word_document" |
16 |
), |
|
17 | 2x |
teal.reporter.rmd_yaml_args = list( |
18 | 2x |
author = "NEST", title = "Report", |
19 | 2x |
date = as.character(Sys.Date()), output = "html_document", |
20 | 2x |
toc = FALSE |
21 |
) |
|
22 |
) |
|
23 | ||
24 | 2x |
toset <- !(names(teal_reporter_default_options) %in% names(op)) |
25 | 1x |
if (any(toset)) options(teal_reporter_default_options[toset]) |
26 | ||
27 |
# Manual import instead of using backports and adding 1 more dependency |
|
28 | 2x |
if (getRversion() < "4.4") { |
29 | ! |
assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname)) |
30 |
} |
|
31 | ||
32 | 2x |
invisible() |
33 |
} |
|
34 | ||
35 |
.onAttach <- function(libname, pkgname) { |
|
36 | 3x |
if (!requireNamespace("formatR", quietly = TRUE)) { |
37 | 1x |
packageStartupMessage( |
38 | 1x |
"For better code formatting, consider installing the formatR package." |
39 |
) |
|
40 |
} |
|
41 |
} |
1 |
.content_to_rmd <- function(block, ...) { |
|
2 | 4x |
path <- basename(tempfile(pattern = "report_item_", fileext = ".rds")) |
3 | 4x |
suppressWarnings(saveRDS(block, file = path)) |
4 | 4x |
sprintf("```{r echo = FALSE, eval = TRUE}\nreadRDS('%s')\n```", path) |
5 |
} |
|
6 | ||
7 |
.plot_to_rmd <- function(block, ...) { |
|
8 | 14x |
path <- basename(tempfile(pattern = "report_item_", fileext = ".rds")) |
9 | 14x |
suppressWarnings(saveRDS(block, file = path)) |
10 | 14x |
dims <- .determine_default_dimensions(block, convert_to_inches = TRUE) |
11 | ||
12 | 14x |
chunk <- if (inherits(block, "grob")) { |
13 | ! |
"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\n._figure <- readRDS('%s')\ngrid::grid.newpage()\ngrid::grid.draw(._figure)\n```" # nolint line_length_linter. |
14 |
} else { |
|
15 | 14x |
"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```" |
16 |
} |
|
17 | ||
18 | 14x |
sprintf( |
19 | 14x |
chunk, |
20 | 14x |
dims$width, |
21 | 14x |
dims$height, |
22 | 14x |
path |
23 |
) |
|
24 |
} |
|
25 | ||
26 |
#' Convert `ReporterCard`/`teal_card` content to `rmarkdown` |
|
27 |
#' |
|
28 |
#' This is an S3 generic that is used to generate content in `rmarkdown` format |
|
29 |
#' from various types of blocks in a `ReporterCard` or `teal_card` object. |
|
30 |
#' |
|
31 |
#' # Customize `to_rmd` |
|
32 |
#' The methods for this S3 generic can be extended by the app developer or even overwritten. |
|
33 |
#' For this a function with the name `to_rmd.<class>` should be defined in the |
|
34 |
#' Global Environment, where `<class>` is the class of the object to be converted. |
|
35 |
#' |
|
36 |
#' For example, to override the default behavior for `code_chunk` class, you can use: |
|
37 |
#' |
|
38 |
#' ```r |
|
39 |
#' to_rmd.code_chunk <- function(block, ..., output_format) { |
|
40 |
#' # custom implementation |
|
41 |
#' sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block) |
|
42 |
#' } |
|
43 |
#' ``` |
|
44 |
#' |
|
45 |
#' Alternatively, you can register the S3 method using `registerS3method("to_rmd", "<class>", fun)` |
|
46 |
#' |
|
47 |
#' @param block (`any`) content which can be represented in Rmarkdown syntax. |
|
48 |
#' @return `character(1)` containing a content or Rmarkdown document. |
|
49 |
#' @keywords internal |
|
50 |
to_rmd <- function(block, ...) { |
|
51 | 195x |
UseMethod("to_rmd") |
52 |
} |
|
53 | ||
54 |
#' @method to_rmd default |
|
55 |
#' @keywords internal |
|
56 |
to_rmd.default <- function(block, ...) { |
|
57 | 195x |
.to_rmd(block, ...) |
58 |
} |
|
59 | ||
60 |
.to_rmd <- function(block, ...) { |
|
61 | 195x |
UseMethod(".to_rmd") |
62 |
} |
|
63 | ||
64 |
#' @method .to_rmd default |
|
65 |
#' @keywords internal |
|
66 |
.to_rmd.default <- function(block, ...) { |
|
67 | ! |
block |
68 |
} |
|
69 | ||
70 |
#' @method .to_rmd teal_report |
|
71 |
#' @keywords internal |
|
72 |
.to_rmd.teal_report <- function(block, ...) { |
|
73 | 28x |
to_rmd(teal_card(block), ...) |
74 |
} |
|
75 | ||
76 |
#' @method .to_rmd teal_card |
|
77 |
#' @keywords internal |
|
78 |
.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) { |
|
79 | 40x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
80 | 40x |
is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation") |
81 | 40x |
powerpoint_exception_parsed <- if (is_powerpoint) { |
82 | ! |
format_code_block_function <- quote( |
83 | ! |
code_block <- function(code_text) { |
84 | ! |
df <- data.frame(code_text) |
85 | ! |
ft <- flextable::flextable(df) |
86 | ! |
ft <- flextable::delete_part(ft, part = "header") |
87 | ! |
ft <- flextable::autofit(ft, add_h = 0) |
88 | ! |
ft <- flextable::fontsize(ft, size = 7, part = "body") |
89 | ! |
ft <- flextable::bg(x = ft, bg = "lightgrey") |
90 | ! |
ft <- flextable::border_outer(ft) |
91 | ! |
if (flextable::flextable_dim(ft)$widths > 8) { |
92 | ! |
ft <- flextable::width(ft, width = 8) |
93 |
} |
|
94 | ! |
ft |
95 |
} |
|
96 |
) |
|
97 | ! |
deparse1(format_code_block_function, collapse = "\n") |
98 |
} else { |
|
99 | 40x |
NULL |
100 |
} |
|
101 | 40x |
global_knitr_parsed <- sprintf( |
102 | 40x |
"knitr::opts_chunk$set(%s)", |
103 | 40x |
paste(utils::capture.output(dput(global_knitr)), collapse = "") |
104 |
) |
|
105 | 40x |
global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE) |
106 | ||
107 | 40x |
m_yaml <- metadata(block) |
108 | 40x |
paste( |
109 | 40x |
c( |
110 | 40x |
if (length(m_yaml)) as_yaml_auto(m_yaml), |
111 | 40x |
if (length(global_knitr) || is_powerpoint) to_rmd(global_knitr_code_chunk), |
112 | 40x |
unlist(lapply( |
113 | 40x |
block, |
114 | 40x |
function(x) to_rmd(x, output_format = m_yaml$output, ...) |
115 |
)) |
|
116 |
), |
|
117 | 40x |
collapse = "\n\n" |
118 |
) |
|
119 |
} |
|
120 | ||
121 |
#' @method .to_rmd code_chunk |
|
122 |
#' @keywords internal |
|
123 |
.to_rmd.code_chunk <- function(block, ..., output_format = NULL) { |
|
124 | 43x |
params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l) |
125 | 43x |
block_str <- format(block) |
126 | 43x |
lang <- attr(block, "lang", exact = TRUE) |
127 | 43x |
if (identical(output_format, "powerpoint_presentation")) { |
128 | ! |
block_content_list <- lapply( |
129 | ! |
split_text_block(block, 30), |
130 | ! |
function(x, lang) { |
131 | ! |
code_block <- sprintf("code_block(\n%s)", shQuote(x, type = "cmd")) |
132 | ! |
format(code_chunk(code_block, echo = FALSE, lang = lang)) |
133 |
}, |
|
134 | ! |
lang = lang |
135 |
) |
|
136 | ! |
paste(sprintf("\\newpage\n\n---\n\n%s\n", block_content_list), collapse = "\n\n") |
137 |
} else { |
|
138 | 43x |
format(block) |
139 |
} |
|
140 |
} |
|
141 | ||
142 |
#' @method .to_rmd character |
|
143 |
#' @keywords internal |
|
144 |
.to_rmd.character <- function(block, ...) { |
|
145 | 54x |
block |
146 |
} |
|
147 | ||
148 |
#' @method .to_rmd chunk_output |
|
149 |
#' @keywords internal |
|
150 |
.to_rmd.chunk_output <- function(block, ..., include_chunk_output) { |
|
151 | 8x |
if (!missing(include_chunk_output) && isTRUE(include_chunk_output)) { |
152 | 4x |
new_block <- block[[1]] |
153 | 4x |
mostattributes(new_block) <- c(attributes(unclass(block)), attributes(new_block)) |
154 | 4x |
to_rmd(new_block, ..., include_chunk_output = include_chunk_output) |
155 |
} |
|
156 |
} |
|
157 | ||
158 |
#' @method .to_rmd condition |
|
159 |
#' @keywords internal |
|
160 |
.to_rmd.condition <- function(block, ...) { |
|
161 | ! |
conditionMessage(block) |
162 |
} |
|
163 | ||
164 |
#' @method .to_rmd gg |
|
165 |
#' @keywords internal |
|
166 |
.to_rmd.gg <- .plot_to_rmd |
|
167 | ||
168 |
#' @method .to_rmd trellis |
|
169 |
#' @keywords internal |
|
170 |
.to_rmd.trellis <- .plot_to_rmd |
|
171 | ||
172 |
#' @method .to_rmd recordedplot |
|
173 |
#' @keywords internal |
|
174 |
.to_rmd.recordedplot <- .plot_to_rmd |
|
175 | ||
176 |
#' @method .to_rmd grob |
|
177 |
#' @keywords internal |
|
178 |
.to_rmd.grob <- .plot_to_rmd |
|
179 | ||
180 |
#' @method .to_rmd Heatmap |
|
181 |
#' @keywords internal |
|
182 |
.to_rmd.Heatmap <- .plot_to_rmd |
|
183 | ||
184 |
#' @method .to_rmd datatables |
|
185 |
#' @keywords internal |
|
186 |
.to_rmd.datatables <- .content_to_rmd |
|
187 | ||
188 |
#' @method .to_rmd summary.lm |
|
189 |
#' @keywords internal |
|
190 |
.to_rmd.summary.lm <- .content_to_rmd |
|
191 | ||
192 |
#' @method .to_rmd rtables |
|
193 |
#' @keywords internal |
|
194 |
.to_rmd.rtables <- function(block, ...) { |
|
195 | 4x |
flextable_block <- to_flextable(block) |
196 | 4x |
attr(flextable_block, "keep") <- attr(block, "keep") |
197 | 4x |
to_rmd(flextable_block, ...) |
198 |
} |
|
199 | ||
200 |
#' @method .to_rmd flextable |
|
201 |
#' @keywords internal |
|
202 |
.to_rmd.flextable <- .content_to_rmd |
|
203 | ||
204 |
#' @method .to_rmd TableTree |
|
205 |
#' @keywords internal |
|
206 |
.to_rmd.TableTree <- .to_rmd.rtables |
|
207 | ||
208 |
#' @method .to_rmd ElementaryTable |
|
209 |
#' @keywords internal |
|
210 |
.to_rmd.ElementaryTable <- .to_rmd.rtables |
|
211 | ||
212 |
#' @method .to_rmd rlisting |
|
213 |
#' @keywords internal |
|
214 |
.to_rmd.rlisting <- .to_rmd.rtables |
|
215 | ||
216 |
#' @method .to_rmd data.frame |
|
217 |
#' @keywords internal |
|
218 |
.to_rmd.data.frame <- .to_rmd.rtables |
|
219 | ||
220 |
#' @method .to_rmd gtsummary |
|
221 |
#' @keywords internal |
|
222 |
.to_rmd.gtsummary <- function(block, ...) { |
|
223 | ! |
to_rmd(gtsummary::as_flex_table(block), ...) |
224 |
} |
|
225 | ||
226 |
#' @method .to_rmd listing_df |
|
227 |
#' @keywords internal |
|
228 |
.to_rmd.listing_df <- function(block, ...) { |
|
229 | ! |
to_rmd(flextable::as_flextable(block), ...) |
230 |
} |
1 |
# reporter_previewer_content -------------------------------------------------------------------------------------- |
|
2 | ||
3 |
#' @keywords internal |
|
4 |
reporter_previewer_content_ui <- function(id, cached_content = rlang::list2()) { |
|
5 | ! |
ns <- shiny::NS(id) |
6 | ! |
shiny::tags$div( |
7 | ! |
.custom_css_dependency(), |
8 | ! |
bslib::accordion( |
9 | ! |
id = ns("reporter_cards"), |
10 | ! |
class = "teal-reporter report-previewer-accordion", |
11 | ! |
!!!cached_content |
12 |
), |
|
13 | ! |
sortable::sortable_js( |
14 | ! |
css_id = ns("reporter_cards"), |
15 | ! |
options = sortable::sortable_options( |
16 | ! |
onSort = sortable::sortable_js_capture_input(ns("reporter_cards_order")), |
17 | ! |
handle = ".accordion-icon" |
18 |
) |
|
19 |
) |
|
20 |
) |
|
21 |
} |
|
22 | ||
23 |
#' @keywords internal |
|
24 |
reporter_previewer_content_srv <- function(id, reporter) { |
|
25 | 11x |
shiny::moduleServer(id, function(input, output, session) { |
26 | 11x |
shiny::setBookmarkExclude("card_remove_id") |
27 | ||
28 | 11x |
session$onRestored(function(state) { |
29 | ! |
if (is.null(state$dir)) { |
30 | ! |
return(NULL) |
31 |
} |
|
32 | ! |
reporterdir <- file.path(state$dir, "reporter") |
33 | ! |
reporter$from_jsondir(reporterdir) |
34 |
}) |
|
35 | ||
36 | 11x |
shiny::exportTestValues(cards = reporter$get_cards()) |
37 | 11x |
current_ids_rv <- shiny::reactiveVal() |
38 | 11x |
queues_rv <- list(insert = shiny::reactiveVal(), remove = shiny::reactiveVal()) |
39 | ||
40 | 11x |
shiny::observeEvent(reporter$get_cards(), { |
41 | 6x |
all_cards <- reporter$get_cards() |
42 | 6x |
reporter_ids <- names(all_cards) |
43 | 6x |
current_ids <- current_ids_rv() |
44 | ||
45 | 6x |
to_add <- !reporter_ids %in% current_ids |
46 | 6x |
to_remove <- !current_ids %in% reporter_ids |
47 | 3x |
if (any(to_add)) queues_rv$insert(reporter_ids[to_add]) |
48 | ! |
if (any(to_remove)) queues_rv$remove(current_ids[to_remove]) |
49 | ||
50 | 6x |
shinyjs::toggle("empty_reporters", condition = length(all_cards) == 0L) |
51 |
}) |
|
52 | ||
53 | 11x |
shiny::observeEvent(queues_rv$insert(), { |
54 | 3x |
lapply(queues_rv$insert(), function(card_id) { |
55 | 3x |
current_ids_rv(c(current_ids_rv(), card_id)) |
56 |
}) |
|
57 |
}) |
|
58 | ||
59 | 11x |
shiny::observeEvent(queues_rv$remove(), { |
60 | ! |
lapply(queues_rv$remove(), bslib::accordion_panel_remove, id = "reporter_cards") |
61 |
}) |
|
62 | ||
63 | 11x |
shiny::observeEvent(input$card_remove_id, { |
64 | ! |
reporter$remove_cards(ids = input$card_remove_id) |
65 |
}) |
|
66 | ||
67 | 11x |
shiny::observeEvent(input$reporter_cards_order, { |
68 | ! |
reporter$reorder_cards(input$reporter_cards_order) |
69 |
}) |
|
70 |
}) |
|
71 |
} |
1 |
#' @name eval_code-teal_report |
|
2 |
#' @rdname eval_code-teal_report |
|
3 |
#' @aliases eval_code,teal_report-method |
|
4 |
#' |
|
5 |
#' @inherit teal.code::eval_code |
|
6 |
#' @param object (`teal_report`) |
|
7 |
#' @param code_block_opts (`list`) Additional options for the R code chunk in R Markdown. |
|
8 |
#' @return `teal_reporter` environment with the code evaluated and the outputs added |
|
9 |
#' to the card or `qenv.error` if evaluation fails. |
|
10 |
#' @importFrom teal.code eval_code |
|
11 |
#' |
|
12 |
#' @examples |
|
13 |
#' td <- teal.data::teal_data() |
|
14 |
#' td <- teal.code::eval_code(td, "iris <- iris") |
|
15 |
#' tr <- as.teal_report(td) |
|
16 |
#' tr <- teal.code::eval_code(tr, "a <- 1") |
|
17 |
#' tr <- teal.code::eval_code(tr, "b <- 2L # with comment") |
|
18 |
#' tr <- teal.code::eval_code(tr, quote(library(checkmate))) |
|
19 |
#' tr <- teal.code::eval_code(tr, expression(assert_number(a))) |
|
20 |
#' teal_card(tr) |
|
21 |
setMethod( |
|
22 |
"eval_code", |
|
23 |
signature = c(object = "teal_report"), |
|
24 |
function(object, code, code_block_opts = list(), ...) { |
|
25 | 22x |
new_object <- methods::callNextMethod(object = object, code = code, ...) |
26 | 22x |
if (inherits(new_object, "error")) { |
27 | ! |
return(new_object) |
28 |
} |
|
29 | 22x |
new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts) |
30 | ||
31 | 22x |
teal_card(new_object) <- c(teal_card(new_object), new_blocks) |
32 | 22x |
new_object |
33 |
} |
|
34 |
) |
1 |
#' Show report previewer button module |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' Provides a button that triggers showing the report preview in a modal. |
|
5 |
#' |
|
6 |
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. |
|
7 |
#' |
|
8 |
#' @name reporter_previewer |
|
9 |
#' |
|
10 |
#' @param id (`character(1)`) `shiny` module instance id. |
|
11 |
#' @param label (`character(1)`) label of the button. By default it is "Preview Report". |
|
12 |
#' @param reporter (`Reporter`) instance. |
|
13 |
#' |
|
14 |
#' @return `NULL`. |
|
15 |
NULL |
|
16 | ||
17 |
#' @rdname reporter_previewer |
|
18 |
#' @export |
|
19 |
preview_report_button_ui <- function(id, label = "Preview Report") { |
|
20 | ! |
checkmate::assert_string(label, null.ok = TRUE) |
21 | ! |
ns <- shiny::NS(id) |
22 | ! |
shiny::tagList( |
23 | ! |
.action_button_busy( |
24 | ! |
ns("preview_button"), |
25 | ! |
label = shiny::tags$span( |
26 | ! |
label, |
27 | ! |
shiny::uiOutput(ns("preview_button_counter")) |
28 |
), |
|
29 | ! |
icon = "file-earmark-text", |
30 | ! |
outline = TRUE |
31 |
) |
|
32 |
) |
|
33 |
} |
|
34 | ||
35 |
#' @rdname reporter_previewer |
|
36 |
#' @export |
|
37 |
preview_report_button_srv <- function(id, reporter) { |
|
38 | 4x |
checkmate::assert_class(reporter, "Reporter") |
39 | ||
40 | 4x |
shiny::moduleServer(id, function(input, output, session) { |
41 | 4x |
shiny::setBookmarkExclude(c("preview_button")) |
42 | ||
43 | 4x |
shiny::observeEvent(reporter$get_cards(), { |
44 | 4x |
shinyjs::toggleClass( |
45 | 4x |
id = "preview_button", condition = length(reporter$get_cards()) == 0, class = "disabled" |
46 |
) |
|
47 |
}) |
|
48 | ||
49 | 4x |
output$preview_button_counter <- shiny::renderUI({ |
50 | 4x |
shiny::tags$span( |
51 | 4x |
class = "badge rounded-pill bg-primary", |
52 | 4x |
length(reporter$get_cards()) |
53 |
) |
|
54 |
}) |
|
55 | ||
56 | 4x |
preview_modal <- function(cached_content) { |
57 | 2x |
shiny::tags$div( |
58 | 2x |
class = "teal-reporter reporter-previewer-modal", |
59 | 2x |
.custom_css_dependency(), |
60 | 2x |
.accordion_toggle_js_dependency(), |
61 | 2x |
shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")), |
62 | 2x |
shiny::modalDialog( |
63 | 2x |
easyClose = TRUE, |
64 | 2x |
size = "xl", |
65 | 2x |
title = "Report Preview", |
66 | 2x |
reporter_previewer_content_ui(session$ns("preview_content")), |
67 | 2x |
footer = shiny::tagList( |
68 | 2x |
shiny::tags$button( |
69 | 2x |
type = "button", |
70 | 2x |
class = "btn btn-outline-secondary", |
71 | 2x |
"data-bs-dismiss" = "modal", |
72 | 2x |
"Dismiss" |
73 |
) |
|
74 |
) |
|
75 |
) |
|
76 |
) |
|
77 |
} |
|
78 | ||
79 | 4x |
reporter_previewer_content_srv(id = "preview_content", reporter = reporter) |
80 | ||
81 | 4x |
srv_list <- shiny::reactiveValues() |
82 | 4x |
shiny::observeEvent( |
83 | 4x |
list(input$preview_button, reporter$open_previewer()), |
84 | 4x |
ignoreInit = TRUE, |
85 |
{ |
|
86 | 2x |
shiny::req(input$preview_button != 0 || !is.null(reporter$open_previewer())) # prevent unnecessary triggering. |
87 | 2x |
shiny::showModal(preview_modal()) |
88 | ||
89 | 2x |
panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards")) |
90 | 2x |
lapply( |
91 | 2x |
names(reporter$get_cards()), |
92 | 2x |
function(card_id) { |
93 |
# Only show loading placeholder for cards that are being initialized for the first time |
|
94 | ! |
first_run <- is.null(srv_list[[card_id]]) |
95 | ||
96 | ! |
bslib::accordion_panel_insert( |
97 | ! |
id = panel_ns(NULL), |
98 | ! |
previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id, show_loading = first_run) |
99 |
) |
|
100 | ||
101 | ! |
if (first_run) { # Only initialize srv once per card_id |
102 | ! |
previewer_card_srv( |
103 | ! |
id = panel_ns(card_id), |
104 | ! |
card_r = shiny::reactive(reporter$get_cards()[[card_id]]), |
105 | ! |
card_id = card_id, |
106 | ! |
reporter = reporter |
107 |
) |
|
108 | ! |
srv_list[[card_id]] <- card_id |
109 |
} |
|
110 |
} |
|
111 |
) |
|
112 |
} |
|
113 |
) |
|
114 |
}) |
|
115 |
} |
1 |
#' Render `teal_card` |
|
2 |
#' @inheritParams rmarkdown::render |
|
3 |
#' @param input (`teal_report` or `teal_code`) object to render. |
|
4 |
#' @param global_knitr (`list`) options to apply to every code chunk in a teal_card document. |
|
5 |
#' [Read more here](https://rmarkdown.rstudio.com/lesson-3.html#global-options). |
|
6 |
#' @param keep_rmd (`logical(1)`) if `.Rmd` should be kept after rendering to desired `output_format`. |
|
7 |
#' @param ... arguments passed to `rmarkdown::render`. |
|
8 |
#' @examples |
|
9 |
#' report <- teal_report() |
|
10 |
#' teal_card(report) <- c( |
|
11 |
#' teal_card(report), |
|
12 |
#' "## Document section", |
|
13 |
#' "Lorem ipsum dolor sit amet" |
|
14 |
#' ) |
|
15 |
#' report <- within(report, a <- 2) |
|
16 |
#' report <- within(report, plot(a)) |
|
17 |
#' metadata(teal_card(report)) <- list( |
|
18 |
#' title = "My Document", |
|
19 |
#' author = "NEST" |
|
20 |
#' ) |
|
21 |
#' if (interactive()) { |
|
22 |
#' render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10)) |
|
23 |
#' } |
|
24 |
#' @export |
|
25 |
render <- function( |
|
26 |
input, |
|
27 |
output_dir = getwd(), |
|
28 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
29 |
keep_rmd = TRUE, |
|
30 |
...) { |
|
31 | 20x |
checkmate::assert_multi_class(input, c("teal_report", "teal_card", "Reporter")) |
32 | 20x |
checkmate::assert_string(output_dir) |
33 | 20x |
checkmate::assert_list(global_knitr, names = "named") |
34 | 20x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
35 | 20x |
checkmate::assert_flag(keep_rmd) |
36 | 20x |
checkmate::assert_subset(names(list(...)), names(formals(rmarkdown::render))) |
37 | ||
38 |
# Set output dir to a new working directory. Absolute paths in rmarkdown files will break .Rmd portability |
|
39 | 20x |
dir.create(output_dir, recursive = TRUE, showWarnings = FALSE) |
40 | 20x |
old_wd <- setwd(dir = output_dir) |
41 | 20x |
on.exit(setwd(old_wd)) |
42 | ||
43 |
# This Rmd file is for render purpose as it contains evaluated code chunks and their outputs. |
|
44 | 20x |
rmd_filepath <- "report.Rmd" |
45 | 20x |
temp_rmd_content <- to_rmd( |
46 | 20x |
block = input, |
47 | 20x |
global_knitr = c(global_knitr, list(eval = FALSE)), # we don't want to rerun evaluated code chunks to render |
48 | 20x |
include_chunk_output = TRUE |
49 |
) |
|
50 | 20x |
cat(temp_rmd_content, file = rmd_filepath) |
51 | 20x |
args <- utils::modifyList(list(...), list(input = rmd_filepath)) |
52 | 20x |
tryCatch( |
53 | 20x |
do.call(rmarkdown::render, args), |
54 | 20x |
finally = { |
55 | 20x |
report_items <- list.files(pattern = "report_item_") |
56 | 20x |
unlink(c(rmd_filepath, report_items)) |
57 |
} |
|
58 |
) |
|
59 | ||
60 | 20x |
if (keep_rmd) { |
61 |
# This Rmd file doesn't contain chunk_outputs as they can be reproduced when executing code-chunks |
|
62 | 20x |
out_rmd_content <- to_rmd( |
63 | 20x |
block = input, |
64 | 20x |
global_knitr = global_knitr, |
65 | 20x |
include_chunk_output = FALSE |
66 |
) |
|
67 | 20x |
cat(out_rmd_content, file = rmd_filepath) |
68 |
} |
|
69 | 20x |
output_dir |
70 |
} |
1 |
previewer_card_ui <- function(id, card_id, show_loading = TRUE) { |
|
2 | ! |
ns <- shiny::NS(id) |
3 | ! |
accordion_item <- bslib::accordion_panel( |
4 | ! |
value = card_id, |
5 | ! |
title = shiny::tags$label(shiny::uiOutput(ns("title"))), |
6 | ! |
icon = bslib::tooltip( |
7 | ! |
bsicons::bs_icon("arrows-move"), |
8 | ! |
"Move card" |
9 |
), |
|
10 | ! |
if (show_loading) { |
11 | ! |
shiny::tags$h6(id = ns(paste0("loading_placeholder_", card_id)), class = "text-muted", "Loading the report...") |
12 |
}, |
|
13 | ! |
shiny::uiOutput(ns("card_content")) |
14 |
) |
|
15 | ! |
accordion_item <- shiny::tagAppendAttributes(accordion_item, "data-rank-id" = card_id) |
16 | ||
17 | ! |
accordion_item <- shiny::tagAppendAttributes( |
18 | ! |
tag = accordion_item, |
19 | ! |
.cssSelector = ".accordion-header", |
20 | ! |
class = "d-flex", |
21 |
) |
|
22 | ||
23 | ! |
accordion_item <- htmltools::tagAppendChildren( |
24 | ! |
tag = accordion_item, |
25 | ! |
.cssSelector = ".accordion-header", |
26 | ! |
ui_previewer_card_actions(ns("actions")) |
27 |
) |
|
28 |
} |
|
29 | ||
30 |
previewer_card_srv <- function(id, card_r, card_id, reporter) { |
|
31 | 3x |
shiny::moduleServer(id, function(input, output, session) { |
32 | 3x |
output$title <- shiny::renderUI({ |
33 | 3x |
title <- metadata(shiny::req(card_r()), "title") |
34 | 3x |
if (is.null(title) || isFALSE(nzchar(title))) { |
35 | 1x |
title <- shiny::tags$span("(Empty title)", class = "text-muted") |
36 |
} |
|
37 | 3x |
title |
38 |
}) |
|
39 | 3x |
output$card_content <- shiny::renderUI({ |
40 | 3x |
result <- reporter$get_cached_html(card_id) |
41 | 3x |
shiny::removeUI(sprintf("#%s", session$ns(paste0("loading_placeholder_", card_id)))) |
42 | 3x |
result |
43 |
}) |
|
44 | ||
45 | 3x |
srv_previewer_card_actions("actions", card_r, card_id, reporter) |
46 |
}) |
|
47 |
} |
1 |
# deprecated ------------------------------------------------------------------------------------------------------ |
|
2 | ||
3 |
#' Report previewer module |
|
4 |
#' |
|
5 |
#' @description `r lifecycle::badge("deprecated")` |
|
6 |
#' |
|
7 |
#' Module offers functionalities to visualize, manipulate, |
|
8 |
#' and interact with report cards that have been added to a report. |
|
9 |
#' It includes a previewer interface to see the cards and options to modify the report before downloading. |
|
10 |
#' |
|
11 |
#' Cards are saved by the `shiny` bookmarking mechanism. |
|
12 |
#' |
|
13 |
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. |
|
14 |
#' |
|
15 |
#' This function is deprecated and will be removed in the next release. |
|
16 |
#' Please use `preview_report_button_ui()` and `preview_report_button_srv()` |
|
17 |
#' to create a preview button that opens a modal with the report preview. |
|
18 |
#' |
|
19 |
#' @details `r global_knitr_details()` |
|
20 |
#' |
|
21 |
#' @name reporter_previewer_deprecated |
|
22 |
#' |
|
23 |
#' @param id (`character(1)`) `shiny` module instance id. |
|
24 |
#' @param reporter (`Reporter`) instance. |
|
25 |
#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) |
|
26 |
#' for customizing the rendering process. |
|
27 |
#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible |
|
28 |
#' values and `"download"` is required. |
|
29 |
#' Default `c("download", "load", "reset")` |
|
30 |
#' @inheritParams reporter_download_inputs |
|
31 |
#' |
|
32 |
#' @return `NULL`. |
|
33 |
NULL |
|
34 | ||
35 |
#' @rdname reporter_previewer_deprecated |
|
36 |
#' @export |
|
37 |
reporter_previewer_ui <- function(id) { |
|
38 | ! |
ns <- shiny::NS(id) |
39 | ! |
lifecycle::deprecate_soft( |
40 | ! |
when = "0.5.0", |
41 | ! |
what = "reporter_previewer_ui()", |
42 | ! |
details = paste( |
43 | ! |
"Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n", |
44 | ! |
"Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,", |
45 | ! |
"and `preview_report_button_ui()` instead." |
46 |
) |
|
47 |
) |
|
48 | ! |
bslib::page_fluid( |
49 | ! |
shiny::tagList( |
50 | ! |
shinyjs::useShinyjs(), |
51 | ! |
shiny::singleton( |
52 | ! |
shiny::tags$head( |
53 | ! |
shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")), |
54 | ! |
shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter")) |
55 |
) |
|
56 |
), |
|
57 | ||
58 |
# Extend shinyjs::js to include function defined in extendShinyJs.js |
|
59 | ! |
shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")), |
60 | ! |
shiny::tags$div( |
61 | ! |
class = "well", |
62 | ! |
style = "display: inline-flex; flex-direction: row; gap: 10px;", |
63 | ! |
shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")), |
64 | ! |
shiny::tags$span( |
65 | ! |
id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report") |
66 |
), |
|
67 | ! |
shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report")) |
68 |
), |
|
69 | ! |
shiny::tags$div(reporter_previewer_content_ui(ns("previewer"))) |
70 |
) |
|
71 |
) |
|
72 |
} |
|
73 | ||
74 |
#' @rdname reporter_previewer_deprecated |
|
75 |
#' @export |
|
76 |
reporter_previewer_srv <- function(id, |
|
77 |
reporter, |
|
78 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
79 |
rmd_output = getOption("teal.reporter.rmd_output"), |
|
80 |
rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"), |
|
81 |
previewer_buttons = c("download", "load", "reset")) { |
|
82 | 11x |
lifecycle::deprecate_soft( |
83 | 11x |
when = "0.5.0", |
84 | 11x |
what = "reporter_previewer_srv()", |
85 | 11x |
details = paste( |
86 | 11x |
"Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n", |
87 | 11x |
"Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,", |
88 | 11x |
"and `preview_report_button_srv()` instead." |
89 |
) |
|
90 |
) |
|
91 | 11x |
checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE) |
92 | 11x |
checkmate::assert_true("download" %in% previewer_buttons) |
93 | 10x |
checkmate::assert_class(reporter, "Reporter") |
94 | 10x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
95 | 10x |
checkmate::assert_subset( |
96 | 10x |
rmd_output, |
97 | 10x |
c("html_document", "pdf_document", "powerpoint_presentation", "word_document"), |
98 | 10x |
empty.ok = FALSE |
99 |
) |
|
100 | 10x |
checkmate::assert_list(rmd_yaml_args, names = "named") |
101 | 10x |
checkmate::assert_names( |
102 | 10x |
names(rmd_yaml_args), |
103 | 10x |
subset.of = c("author", "title", "date", "output", "toc"), |
104 | 10x |
must.include = "output" |
105 |
) |
|
106 | 8x |
checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) |
107 | ||
108 | 7x |
shiny::moduleServer(id, function(input, output, session) { |
109 | 7x |
if (!"load" %in% previewer_buttons) { |
110 | 1x |
shinyjs::hide(id = "load_span") |
111 |
} |
|
112 | 7x |
if (!"download" %in% previewer_buttons) { |
113 | ! |
shinyjs::hide(id = "download_span") |
114 |
} |
|
115 | 7x |
if (!"reset" %in% previewer_buttons) { |
116 | 1x |
shinyjs::hide(id = "reset_span") |
117 |
} |
|
118 | 7x |
report_load_srv("load", reporter = reporter) |
119 | 7x |
download_report_button_srv( |
120 | 7x |
"download", |
121 | 7x |
reporter = reporter, |
122 | 7x |
global_knitr = global_knitr, |
123 | 7x |
rmd_output = rmd_output, |
124 | 7x |
rmd_yaml_args = rmd_yaml_args |
125 |
) |
|
126 | 7x |
reset_report_button_srv("reset", reporter = reporter) |
127 | 7x |
reporter_previewer_content_srv("previewer", reporter = reporter) |
128 |
}) |
|
129 |
} |
1 |
#' Load `Reporter` button module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' Provides a button to upload `ReporterCard`(s) to the `Reporter`. |
|
6 |
#' |
|
7 |
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`. |
|
8 |
#' |
|
9 |
#' @name load_report_button |
|
10 |
#' |
|
11 |
#' @param id `character(1)` this `shiny` module's id. |
|
12 |
#' @param label (`character(1)`) label of the button. By default it is empty. |
|
13 |
#' @param reporter [`Reporter`] instance. |
|
14 |
NULL |
|
15 | ||
16 |
#' @rdname load_report_button |
|
17 |
#' @return `shiny::tagList` |
|
18 |
#' @export |
|
19 |
report_load_ui <- function(id, label = NULL) { |
|
20 | ! |
checkmate::assert_string(label, null.ok = TRUE) |
21 | ! |
.action_button_busy( |
22 | ! |
shiny::NS(id, "reporter_load"), |
23 | ! |
label = label, |
24 | ! |
icon = "upload", |
25 | ! |
outline = TRUE |
26 |
) |
|
27 |
} |
|
28 | ||
29 |
#' @rdname load_report_button |
|
30 |
#' @return `shiny::moduleServer` |
|
31 |
#' @export |
|
32 |
report_load_srv <- function(id, reporter) { |
|
33 | 15x |
checkmate::assert_class(reporter, "Reporter") |
34 | ||
35 | 15x |
shiny::moduleServer( |
36 | 15x |
id, |
37 | 15x |
function(input, output, session) { |
38 | 15x |
shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load")) |
39 | 15x |
ns <- session$ns |
40 | ||
41 | 15x |
archiver_modal <- function() { |
42 | 3x |
nr_cards <- length(reporter$get_cards()) |
43 | 3x |
shiny::div( |
44 | 3x |
class = "teal-reporter reporter-modal", |
45 | 3x |
.custom_css_dependency(), |
46 | 3x |
shiny::modalDialog( |
47 | 3x |
easyClose = TRUE, |
48 | 3x |
shiny::tags$h3("Load the Report"), |
49 | 3x |
shiny::tags$hr(), |
50 | 3x |
shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)", |
51 | 3x |
multiple = FALSE, |
52 | 3x |
accept = c(".zip") |
53 |
), |
|
54 | 3x |
footer = shiny::div( |
55 | 3x |
shiny::tags$button( |
56 | 3x |
type = "button", |
57 | 3x |
class = "btn btn-outline-secondary", |
58 | 3x |
`data-bs-dismiss` = "modal", |
59 | 3x |
NULL, |
60 | 3x |
"Dismiss" |
61 |
), |
|
62 | 3x |
shinyjs::disabled( |
63 | 3x |
shiny::tags$button( |
64 | 3x |
id = ns("reporter_load_main"), |
65 | 3x |
type = "button", |
66 | 3x |
class = "btn btn-primary action-button", |
67 | 3x |
NULL, |
68 | 3x |
"Load" |
69 |
) |
|
70 |
) |
|
71 |
) |
|
72 |
) |
|
73 |
) |
|
74 |
} |
|
75 | ||
76 | 15x |
shiny::observeEvent(input$archiver_zip, { |
77 | 3x |
shinyjs::enable(id = "reporter_load_main") |
78 |
}) |
|
79 | ||
80 | 15x |
shiny::observeEvent(input$reporter_load, { |
81 | 3x |
shiny::showModal(archiver_modal()) |
82 |
}) |
|
83 | ||
84 | 15x |
shiny::observeEvent(input$reporter_load_main, { |
85 | 3x |
load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]]) |
86 | 3x |
shiny::removeModal() |
87 |
}) |
|
88 |
} |
|
89 |
) |
|
90 |
} |
|
91 | ||
92 |
#' @keywords internal |
|
93 |
load_json_report <- function(reporter, zip_path, filename) { |
|
94 | 3x |
tmp_dir <- tempdir() |
95 | 3x |
output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4")))) |
96 | 3x |
dir.create(path = output_dir) |
97 | 3x |
if (!is.null(zip_path) && grepl("report(er)?_", filename)) { |
98 | 3x |
tryCatch( |
99 | 3x |
expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE), |
100 | 3x |
warning = function(cond) { |
101 | ! |
print(cond) |
102 | ! |
shiny::showNotification( |
103 | ! |
ui = "Unzipping folder warning!", |
104 | ! |
action = "Please contact app developer", |
105 | ! |
type = "warning" |
106 |
) |
|
107 |
}, |
|
108 | 3x |
error = function(cond) { |
109 | ! |
print(cond) |
110 | ! |
shiny::showNotification( |
111 | ! |
ui = "Unzipping folder error!", |
112 | ! |
action = "Please contact app developer", |
113 | ! |
type = "error" |
114 |
) |
|
115 |
} |
|
116 |
) |
|
117 | 3x |
tryCatch( |
118 | 3x |
reporter$from_jsondir(output_dir), |
119 | 3x |
warning = function(cond) { |
120 | ! |
print(cond) |
121 | ! |
shiny::showNotification( |
122 | ! |
ui = "Loading reporter warning!", |
123 | ! |
action = "Please contact app developer", |
124 | ! |
type = "warning" |
125 |
) |
|
126 |
}, |
|
127 | 3x |
error = function(cond) { |
128 | 1x |
print(cond) |
129 | 1x |
shiny::showNotification( |
130 | 1x |
ui = "Loading reporter error!", |
131 | 1x |
action = "Please contact app developer", |
132 | 1x |
type = "error" |
133 |
) |
|
134 |
} |
|
135 |
) |
|
136 |
} else { |
|
137 | ! |
shiny::showNotification( |
138 | ! |
paste( |
139 | ! |
"Failed to load the Reporter file.", |
140 | ! |
"Please make sure that the filename starts with `report_`." |
141 |
), |
|
142 | ! |
type = "error" |
143 |
) |
|
144 |
} |
|
145 |
} |
|
146 |
1 + 1 |
1 |
#' Simple reporter module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' |
|
5 |
#' Module provides compact UI and server functions for managing a report in a `shiny` app. |
|
6 |
#' This module combines functionalities for [adding cards to a report][add_card_button], |
|
7 |
#' [downloading the report][download_report_button], and [resetting report content][reset_report_button]. |
|
8 |
#' |
|
9 |
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`. |
|
10 |
#' |
|
11 |
#' @details `r global_knitr_details()` |
|
12 |
#' |
|
13 |
#' @name simple_reporter |
|
14 |
#' |
|
15 |
#' @param id (`character(1)`) `shiny` module instance id. |
|
16 |
#' @param reporter (`Reporter`) instance. |
|
17 |
#' @param card_fun (`reactive` or `function`) which returns a [`teal_card`] or [`ReportCard`] instance. |
|
18 |
#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process. |
|
19 |
#' @inheritParams reporter_download_inputs |
|
20 |
#' |
|
21 |
#' @return `NULL`. |
|
22 |
#' |
|
23 |
#' @examples |
|
24 |
#' if (interactive()) { |
|
25 |
#' library(shiny) |
|
26 |
#' |
|
27 |
#' shinyApp( |
|
28 |
#' ui = fluidPage(simple_reporter_ui("simple")), |
|
29 |
#' server = function(input, output, session) { |
|
30 |
#' simple_reporter_srv("simple", Reporter$new(), function(card) card) |
|
31 |
#' } |
|
32 |
#' ) |
|
33 |
#' } |
|
34 |
NULL |
|
35 | ||
36 |
#' @rdname simple_reporter |
|
37 |
#' @export |
|
38 |
simple_reporter_ui <- function(id) { |
|
39 | ! |
ns <- shiny::NS(id) |
40 | ! |
shiny::tagList( |
41 | ! |
.custom_css_dependency(), |
42 | ! |
shiny::tags$div( |
43 | ! |
shiny::tags$label(class = "text-primary", shiny::tags$strong("Reporter")), |
44 | ! |
shiny::tags$div( |
45 | ! |
class = "simple_reporter_container", |
46 | ! |
add_card_button_ui(ns("add_report_card_simple")), |
47 | ! |
download_report_button_ui(ns("download_button_simple")), |
48 | ! |
report_load_ui(ns("archive_load_simple")), |
49 | ! |
reset_report_button_ui(ns("reset_button_simple")) |
50 |
), |
|
51 | ! |
shiny::tags$br() |
52 |
) |
|
53 |
) |
|
54 |
} |
|
55 | ||
56 |
#' @rdname simple_reporter |
|
57 |
#' @export |
|
58 |
simple_reporter_srv <- function( |
|
59 |
id, |
|
60 |
reporter, |
|
61 |
card_fun, |
|
62 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
63 |
rmd_output = getOption("teal.reporter.rmd_output"), |
|
64 |
rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")) { |
|
65 | 5x |
shiny::moduleServer( |
66 | 5x |
id, |
67 | 5x |
function(input, output, session) { |
68 | 5x |
add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun) |
69 | 5x |
download_report_button_srv( |
70 | 5x |
"download_button_simple", |
71 | 5x |
reporter = reporter, |
72 | 5x |
global_knitr = global_knitr, |
73 | 5x |
rmd_output = rmd_output, |
74 | 5x |
rmd_yaml_args = rmd_yaml_args |
75 |
) |
|
76 | 5x |
report_load_srv("archive_load_simple", reporter = reporter) |
77 | 5x |
reset_report_button_srv("reset_button_simple", reporter = reporter) |
78 |
} |
|
79 |
) |
|
80 |
} |
1 |
#' @rdname srv_editor_block |
|
2 |
#' @export |
|
3 |
ui_editor_block <- function(id, value, cached_html) { |
|
4 | 1x |
UseMethod("ui_editor_block", value) |
5 |
} |
|
6 | ||
7 |
#' UI and Server functions for editing report document blocks |
|
8 |
#' |
|
9 |
#' These functions provide a user interface and server logic for editing and extending |
|
10 |
#' the editor functionality to support new data types. |
|
11 |
#' |
|
12 |
#' @details |
|
13 |
#' The methods for this S3 generic can be extended by the app developer to new classes |
|
14 |
#' or even overwritten. |
|
15 |
#' For this a function with the name `srv_editor_block.<class>` and/or `ui_editor_block.<class>` |
|
16 |
#' should be defined in the Global Environment, where `<class>` is the class of |
|
17 |
#' the object to be used in the method. |
|
18 |
#' |
|
19 |
#' For example, to override the default behavior for `character` class, you can use: |
|
20 |
#' |
|
21 |
#' ```r |
|
22 |
#' ui_editor_block.character <- function(id, value) { |
|
23 |
#' # custom implementation |
|
24 |
#' shiny::tagList( |
|
25 |
#' shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable CUSTOM markdown block"), |
|
26 |
#' shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%") |
|
27 |
#' ) |
|
28 |
#' } |
|
29 |
#' srv_editor_block.character <- function(id, value) { |
|
30 |
#' # custom implementation |
|
31 |
#' # ... |
|
32 |
#' } |
|
33 |
#' ``` |
|
34 |
#' |
|
35 |
#' Alternatively, you can register the S3 method using |
|
36 |
#' `registerS3method("ui_editor_block", "<class>", fun)` and |
|
37 |
#' `registerS3method("srv_editor_block", "<class>", fun)`. |
|
38 |
#' |
|
39 |
#' @param id (`character(1)`) A unique identifier for the module. |
|
40 |
#' @param value The content of the block to be edited. It can be a character string or other types. |
|
41 |
#' @param cached_html (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI. |
|
42 |
#' @export |
|
43 |
srv_editor_block <- function(id, value) { |
|
44 | 8x |
UseMethod("srv_editor_block", value) |
45 |
} |
|
46 | ||
47 |
#' @export |
|
48 |
ui_editor_block.default <- function(id, value, cached_html) { |
|
49 | 1x |
.ui_editor_block(id, value, cached_html) |
50 |
} |
|
51 | ||
52 |
#' @export |
|
53 |
srv_editor_block.default <- function(id, value) { |
|
54 | 8x |
.srv_editor_block(id, value) |
55 |
} |
|
56 | ||
57 |
#' @keywords internal |
|
58 |
.ui_editor_block <- function(id, value, cached_html) { |
|
59 | 1x |
UseMethod(".ui_editor_block", value) |
60 |
} |
|
61 | ||
62 |
#' @keywords internal |
|
63 |
.srv_editor_block <- function(id, value) { |
|
64 | 8x |
UseMethod(".srv_editor_block", value) |
65 |
} |
|
66 | ||
67 |
#' @method .ui_editor_block default |
|
68 |
.ui_editor_block.default <- function(id, value, cached_html) { |
|
69 | ! |
shiny::tags$div( |
70 | ! |
shiny::tags$h6( |
71 | ! |
shiny::tags$span( |
72 | ! |
class = "fa-stack small text-muted", |
73 |
# style = "width: 2em;", # necessary to avoid extra space after icon |
|
74 | ! |
shiny::icon("pencil", class = "fa-stack-1x"), |
75 | ! |
shiny::icon("ban", class = "fa-stack-2x fa-inverse text-black-50") |
76 |
), |
|
77 | ! |
"Non-editable block" |
78 |
), |
|
79 | ! |
if (is.null(cached_html)) { |
80 | ! |
tools::toHTML(value) |
81 |
} else { |
|
82 | ! |
cached_html |
83 |
} |
|
84 |
) |
|
85 |
} |
|
86 | ||
87 |
#' @method .srv_editor_block default |
|
88 |
.srv_editor_block.default <- function(id, value) { |
|
89 | 1x |
shiny::moduleServer(id, function(input, output, session) result <- NULL) # No input being changed, skipping update |
90 |
} |
|
91 | ||
92 |
#' @method .ui_editor_block character |
|
93 |
.ui_editor_block.character <- function(id, value, cached_html) { |
|
94 | 1x |
ns <- shiny::NS(id) |
95 | 1x |
shiny::tagList( |
96 | 1x |
shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"), |
97 | 1x |
shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%") |
98 |
) |
|
99 |
} |
|
100 | ||
101 |
#' @method .srv_editor_block character |
|
102 |
.srv_editor_block.character <- function(id, value) { |
|
103 | 7x |
shiny::moduleServer(id, function(input, output, session) result <- shiny::reactive(input$content)) |
104 |
} |
1 |
#' @export |
|
2 |
`[.teal_report` <- function(x, names) { |
|
3 | 1x |
x <- NextMethod("`[`", x) # unverified doesn't need warning for code inconsistency |
4 | 1x |
x@teal_card <- x@teal_card # todo: https://github.com/insightsengineering/teal.reporter/issues/394 |
5 | 1x |
x |
6 |
} |