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 | 3x |
checkmate::assert_string(label, null.ok = TRUE) |
21 | 3x |
.outline_button( |
22 | 3x |
shiny::NS(id, "reporter_load"), |
23 | 3x |
label = label, |
24 | 3x |
icon = "upload" |
25 |
) |
|
26 |
} |
|
27 | ||
28 |
#' @rdname load_report_button |
|
29 |
#' @return `shiny::moduleServer` |
|
30 |
#' @export |
|
31 |
report_load_srv <- function(id, reporter) { |
|
32 | 15x |
checkmate::assert_class(reporter, "Reporter") |
33 | ||
34 | 15x |
shiny::moduleServer( |
35 | 15x |
id, |
36 | 15x |
function(input, output, session) { |
37 | 15x |
shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load")) |
38 | 15x |
ns <- session$ns |
39 | ||
40 | 15x |
archiver_modal <- function() { |
41 | 3x |
nr_cards <- length(reporter$get_cards()) |
42 | 3x |
shiny::div( |
43 | 3x |
class = "teal-reporter reporter-modal", |
44 | 3x |
.custom_css_dependency(), |
45 | 3x |
shiny::modalDialog( |
46 | 3x |
easyClose = TRUE, |
47 | 3x |
shiny::tags$h3("Load the Report"), |
48 | 3x |
shiny::tags$hr(), |
49 | 3x |
shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)", |
50 | 3x |
multiple = FALSE, |
51 | 3x |
accept = c(".zip") |
52 |
), |
|
53 | 3x |
footer = shiny::div( |
54 | 3x |
shiny::tags$button( |
55 | 3x |
type = "button", |
56 | 3x |
class = "btn btn-outline-secondary", |
57 | 3x |
`data-bs-dismiss` = "modal", |
58 | 3x |
NULL, |
59 | 3x |
"Dismiss" |
60 |
), |
|
61 | 3x |
shinyjs::disabled( |
62 | 3x |
shiny::tags$button( |
63 | 3x |
id = ns("reporter_load_main"), |
64 | 3x |
type = "button", |
65 | 3x |
class = "btn btn-primary action-button", |
66 | 3x |
NULL, |
67 | 3x |
"Load" |
68 |
) |
|
69 |
) |
|
70 |
) |
|
71 |
) |
|
72 |
) |
|
73 |
} |
|
74 | ||
75 | 15x |
shiny::observeEvent(input$archiver_zip, { |
76 | 3x |
shinyjs::enable(id = "reporter_load_main") |
77 |
}) |
|
78 | ||
79 | 15x |
shiny::observeEvent(input$reporter_load, { |
80 | 3x |
shiny::showModal(archiver_modal()) |
81 |
}) |
|
82 | ||
83 | 15x |
shiny::observeEvent(input$reporter_load_main, { |
84 | 3x |
load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]]) |
85 | 3x |
shiny::removeModal() |
86 |
}) |
|
87 |
} |
|
88 |
) |
|
89 |
} |
|
90 | ||
91 |
#' @keywords internal |
|
92 |
load_json_report <- function(reporter, zip_path, filename) { |
|
93 | 3x |
tmp_dir <- tempdir() |
94 | 3x |
output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4")))) |
95 | 3x |
dir.create(path = output_dir) |
96 | 3x |
if (!is.null(zip_path) && grepl("report(er)?_", filename)) { |
97 | 3x |
tryCatch( |
98 | 3x |
expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE), |
99 | 3x |
warning = function(cond) { |
100 | ! |
print(cond) |
101 | ! |
shiny::showNotification( |
102 | ! |
ui = "Unzipping folder warning!", |
103 | ! |
action = "Please contact app developer", |
104 | ! |
type = "warning" |
105 |
) |
|
106 |
}, |
|
107 | 3x |
error = function(cond) { |
108 | ! |
print(cond) |
109 | ! |
shiny::showNotification( |
110 | ! |
ui = "Unzipping folder error!", |
111 | ! |
action = "Please contact app developer", |
112 | ! |
type = "error" |
113 |
) |
|
114 |
} |
|
115 |
) |
|
116 | 3x |
tryCatch( |
117 | 3x |
reporter$from_jsondir(output_dir), |
118 | 3x |
warning = function(cond) { |
119 | ! |
print(cond) |
120 | ! |
shiny::showNotification( |
121 | ! |
ui = "Loading reporter warning!", |
122 | ! |
action = "Please contact app developer", |
123 | ! |
type = "warning" |
124 |
) |
|
125 |
}, |
|
126 | 3x |
error = function(cond) { |
127 | 1x |
print(cond) |
128 | 1x |
shiny::showNotification( |
129 | 1x |
ui = "Loading reporter error!", |
130 | 1x |
action = "Please contact app developer", |
131 | 1x |
type = "error" |
132 |
) |
|
133 |
} |
|
134 |
) |
|
135 |
} else { |
|
136 | ! |
shiny::showNotification( |
137 | ! |
paste( |
138 | ! |
"Failed to load the Reporter file.", |
139 | ! |
"Please make sure that the filename starts with `report_`." |
140 |
), |
|
141 | ! |
type = "error" |
142 |
) |
|
143 |
} |
|
144 |
} |
|
145 |
1 + 1 |
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 | 83x |
private$cards <- shiny::reactiveValues() |
23 | 83x |
private$cached_html <- shiny::reactiveValues() |
24 | 83x |
private$open_previewer_r <- shiny::reactiveVal(NULL) |
25 | 83x |
invisible(self) |
26 |
}, |
|
27 | ||
28 |
#' @description Append one or more `ReportCard` or `teal_card` objects to the `Reporter`. |
|
29 |
#' |
|
30 |
#' @param cards (`ReportCard` or `teal_card`) or a list of such objects |
|
31 |
#' @return `self`, invisibly. |
|
32 |
#' @examplesIf require("ggplot2") |
|
33 |
#' library(ggplot2) |
|
34 |
#' |
|
35 |
#' card1 <- teal_card("## Header 2 text", "A paragraph of default text") |
|
36 |
#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) |
|
37 |
#' metadata(card1, "title") <- "Card1" |
|
38 |
#' |
|
39 |
#' card2 <- teal_card("Document introduction") |
|
40 |
#' metadata(card2, "title") <- "Card2" |
|
41 |
#' |
|
42 |
#' reporter <- Reporter$new() |
|
43 |
#' reporter$append_cards(list(card1, card2)) |
|
44 |
append_cards = function(cards) { |
|
45 | 73x |
if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) { |
46 | 6x |
cards <- list(cards) |
47 |
} |
|
48 | ||
49 | 73x |
checkmate::assert_list(cards, types = c("ReportCard", "teal_card")) |
50 | 73x |
new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content()) |
51 | ||
52 | 73x |
if (!is.null(self$get_template())) { |
53 | 2x |
new_cards <- lapply(new_cards, self$get_template()) |
54 |
} |
|
55 | ||
56 |
# Set up unique id for each card |
|
57 | 73x |
names(new_cards) <- vapply(new_cards, function(card) { |
58 | 115x |
sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8)) |
59 | 73x |
}, character(1L)) |
60 | ||
61 | 73x |
for (card_id in names(new_cards)) { |
62 | 115x |
private$cards[[card_id]] <- new_cards[[card_id]] |
63 | 115x |
private$cached_html[[card_id]] <- lapply(new_cards[[card_id]], tools::toHTML) |
64 |
} |
|
65 | 73x |
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 | ! |
if (inherits(card, "ReportCard")) { |
128 | ! |
card <- card$get_content() |
129 |
} |
|
130 | ! |
private$cards[[card_id]] <- card |
131 | ! |
private$cached_html[[card_id]] <- lapply(card, tools::toHTML) |
132 | ! |
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 | 180x |
result <- if (shiny::isRunning()) { |
156 | ! |
shiny::reactiveValuesToList(private$cards) |
157 |
} else { |
|
158 | 180x |
shiny::isolate(shiny::reactiveValuesToList(private$cards)) |
159 |
} |
|
160 | 180x |
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 | 180x |
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 | 47x |
cards <- self$get_cards() |
189 | 47x |
blocks <- teal_card() |
190 | 47x |
for (idx in seq_along(cards)) { |
191 | 57x |
card <- cards[[idx]] |
192 | 57x |
title <- trimws(metadata(card, "title")) |
193 | 57x |
metadata(card)$title <- NULL |
194 | 57x |
card_title <- if (length(title) > 0 && nzchar(title)) { |
195 | 8x |
sprintf("# %s", title) |
196 |
} else { |
|
197 | 49x |
sprintf("# _Unnamed Card (%d)_", idx) |
198 |
} |
|
199 | 57x |
blocks <- c(blocks, as.teal_card(card_title), card) |
200 | 10x |
if (idx != length(cards) && length(sep)) blocks <- c(blocks, trimws(sep)) |
201 |
} |
|
202 | 47x |
blocks |
203 |
}, |
|
204 |
#' @description Resets the `Reporter`, removing all `teal_card` objects and metadata. |
|
205 |
#' |
|
206 |
#' @return `self`, invisibly. |
|
207 |
#' |
|
208 |
reset = function() { |
|
209 | 27x |
if (shiny::isRunning()) { |
210 | ! |
for (card_id in names(private$cards)) private$cards[[card_id]] <- NULL |
211 |
} else { |
|
212 | 27x |
private$cards <- shiny::reactiveValues() |
213 |
} |
|
214 | 27x |
private$override_order <- character(0L) |
215 | 27x |
private$metadata <- list() |
216 | 27x |
invisible(self) |
217 |
}, |
|
218 |
#' @description Removes specific `teal_card` objects from the `Reporter` by their indices. |
|
219 |
#' |
|
220 |
#' @param ids (`integer`, `character`) the indexes of cards (either name) |
|
221 |
#' @return `self`, invisibly. |
|
222 |
remove_cards = function(ids = NULL) { |
|
223 | 1x |
checkmate::assert( |
224 | 1x |
checkmate::check_null(ids), |
225 | 1x |
checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards)), |
226 | 1x |
checkmate::check_character(ids, min.len = 1, max.len = length(private$cards)) |
227 |
) |
|
228 | 1x |
for (card_id in ids) { |
229 | 1x |
private$cards[[card_id]] <- NULL |
230 |
} |
|
231 | 1x |
invisible(self) |
232 |
}, |
|
233 |
#' @description Get the metadata associated with this `Reporter`. |
|
234 |
#' |
|
235 |
#' @return `named list` of metadata to be appended. |
|
236 |
#' @examples |
|
237 |
#' reporter <- Reporter$new()$append_metadata(list(sth = "sth")) |
|
238 |
#' reporter$get_metadata() |
|
239 |
#' |
|
240 | 39x |
get_metadata = function() private$metadata, |
241 |
#' @description Appends metadata to this `Reporter`. |
|
242 |
#' |
|
243 |
#' @param meta (`named list`) of metadata to be appended. |
|
244 |
#' @return `self`, invisibly. |
|
245 |
#' @examples |
|
246 |
#' reporter <- Reporter$new()$append_metadata(list(sth = "sth")) |
|
247 |
#' reporter$get_metadata() |
|
248 |
#' |
|
249 |
append_metadata = function(meta) { |
|
250 | 31x |
checkmate::assert_list(meta, names = "unique") |
251 | 25x |
checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata))) |
252 | 23x |
private$metadata <- append(private$metadata, meta) |
253 | 23x |
invisible(self) |
254 |
}, |
|
255 |
#' @description |
|
256 |
#' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`. |
|
257 |
#' @param reporter (`Reporter`) instance to copy from. |
|
258 |
#' @return invisibly self |
|
259 |
#' @examples |
|
260 |
#' reporter <- Reporter$new() |
|
261 |
#' reporter$from_reporter(reporter) |
|
262 |
from_reporter = function(reporter) { |
|
263 | 10x |
lifecycle::deprecate_warn("0.5.0.9000", "Reporter$from_reporter()") |
264 | 10x |
checkmate::assert_class(reporter, "Reporter") |
265 | 10x |
self$reset() |
266 | 10x |
self$append_cards(reporter$get_cards()) |
267 | 10x |
self$append_metadata(reporter$get_metadata()) |
268 | 10x |
invisible(self) |
269 |
}, |
|
270 |
#' @description Convert a `Reporter` to a list and transfer any associated files to specified directory. |
|
271 |
#' @param output_dir (`character(1)`) a path to the directory where files will be copied. |
|
272 |
#' @return `named list` representing the `Reporter` instance, including version information, |
|
273 |
#' metadata, and report cards. |
|
274 |
#' @examples |
|
275 |
#' reporter <- Reporter$new() |
|
276 |
#' tmp_dir <- file.path(tempdir(), "testdir") |
|
277 |
#' dir.create(tmp_dir) |
|
278 |
#' reporter$to_list(tmp_dir) |
|
279 |
to_list = function(output_dir) { |
|
280 | 17x |
checkmate::assert_directory_exists(output_dir) |
281 | 15x |
rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list()) |
282 | 15x |
rlist[["metadata"]] <- self$get_metadata() |
283 | 15x |
cards <- self$get_cards() |
284 | 15x |
for (i in seq_along(cards)) { |
285 |
# we want to have list names being a class names to indicate the class for $from_list |
|
286 | 20x |
card <- cards[[i]] |
287 | 20x |
card_class <- class(card)[1] |
288 | 20x |
u_card <- list() |
289 | 20x |
tmp <- tempfile(fileext = ".rds") |
290 | 20x |
suppressWarnings(saveRDS(card, file = tmp)) |
291 | 20x |
tmp_base <- basename(tmp) |
292 | 20x |
file.copy(tmp, file.path(output_dir, tmp_base)) |
293 | 20x |
u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base) |
294 | 20x |
rlist$cards <- c(rlist$cards, u_card) |
295 |
} |
|
296 | 15x |
rlist |
297 |
}, |
|
298 |
#' @description Extracts and saves all figure elements from the `teal_card` objects in the |
|
299 |
#' `Reporter` to a specified directory. |
|
300 |
#' @param output_dir (`character(1)`) a path to the directory where figures will be saved. |
|
301 |
#' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures. |
|
302 |
write_figures = function(output_dir, sub_directory = "figures") { |
|
303 | 5x |
figures_dir <- file.path(output_dir, sub_directory) |
304 | 5x |
dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE) |
305 | 5x |
cards <- self$get_cards() |
306 | 5x |
for (card_id in names(cards)) { |
307 | 6x |
card <- cards[[card_id]] |
308 | 6x |
cached_html <- self$get_cached_html(card_id) |
309 | 6x |
for (element_ix in seq_along(card)) { |
310 | 19x |
card_element <- card[[element_ix]] |
311 |
if ( |
|
312 | 19x |
inherits(card_element, "chunk_output") && |
313 | 19x |
checkmate::test_multi_class( |
314 | 19x |
card_element[[1]], |
315 | 19x |
classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap") |
316 |
) |
|
317 |
) { |
|
318 | ! |
base64_image <- cached_html[[names(card)[[element_ix]]]] |
319 |
if ( # Ensure we only save valid base64 images |
|
320 | ! |
!is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") && |
321 | ! |
!is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src) |
322 |
) { |
|
323 | ! |
b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src) |
324 | ! |
writeBin( |
325 | ! |
jsonlite::base64_dec(b64), |
326 | ! |
file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix)) |
327 |
) |
|
328 |
} |
|
329 |
} |
|
330 |
} |
|
331 |
} |
|
332 |
}, |
|
333 |
#' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory. |
|
334 |
#' @param rlist (`named list`) representing a `Reporter` instance. |
|
335 |
#' @param output_dir (`character(1)`) a path to the directory from which files will be copied. |
|
336 |
#' @return `self`, invisibly. |
|
337 |
#' @note if Report has an id when converting to JSON then It will be compared to the currently available one. |
|
338 |
#' @examples |
|
339 |
#' reporter <- Reporter$new() |
|
340 |
#' tmp_dir <- file.path(tempdir(), "testdir") |
|
341 |
#' unlink(tmp_dir, recursive = TRUE) |
|
342 |
#' dir.create(tmp_dir) |
|
343 |
#' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir) |
|
344 |
from_list = function(rlist, output_dir) { |
|
345 | 8x |
id <- self$get_id() |
346 | 8x |
checkmate::assert_list(rlist) |
347 | 8x |
checkmate::assert_directory_exists(output_dir) |
348 | 8x |
stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter") |
349 | 8x |
stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id) |
350 | 7x |
if (rlist$version %in% c("1")) { |
351 | 7x |
new_cards <- list() |
352 | 7x |
cards_names <- names(rlist$cards) |
353 | 7x |
cards_names <- gsub("[.][0-9]*$", "", cards_names) |
354 | 7x |
for (iter_c in seq_along(rlist$cards)) { |
355 | 12x |
card_class <- cards_names[iter_c] |
356 | 12x |
card <- rlist$cards[[iter_c]] |
357 | 12x |
if (card_class == "teal_card") { |
358 | 12x |
new_card <- readRDS(file.path(output_dir, card$path)) |
359 | 12x |
class(new_card) <- "teal_card" |
360 | 12x |
new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards |
361 | 12x |
names(new_card) <- card$name |
362 |
} else { |
|
363 | ! |
new_card <- eval(str2lang(card_class))$new() |
364 | ! |
new_card$from_list(card, output_dir) |
365 |
} |
|
366 | 12x |
new_cards <- c(new_cards, new_card) |
367 |
} |
|
368 |
} else { |
|
369 | ! |
stop( |
370 | ! |
sprintf( |
371 | ! |
"The provided %s reporter version is not supported.", |
372 | ! |
rlist$version |
373 |
) |
|
374 |
) |
|
375 |
} |
|
376 | 7x |
self$reset() |
377 | 7x |
self$set_id(rlist$id) |
378 | 7x |
self$append_cards(new_cards) |
379 | 7x |
self$append_metadata(rlist$metadata) |
380 | 7x |
invisible(self) |
381 |
}, |
|
382 |
#' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory. |
|
383 |
#' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics. |
|
384 |
#' @return `output_dir` argument. |
|
385 |
#' @examples |
|
386 |
#' reporter <- Reporter$new() |
|
387 |
#' tmp_dir <- file.path(tempdir(), "jsondir") |
|
388 |
#' dir.create(tmp_dir) |
|
389 |
#' reporter$to_jsondir(tmp_dir) |
|
390 |
to_jsondir = function(output_dir) { |
|
391 | 13x |
checkmate::assert_directory_exists(output_dir) |
392 | 11x |
json <- self$to_list(output_dir) |
393 | 11x |
cat( |
394 | 11x |
jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), |
395 | 11x |
file = file.path(output_dir, "Report.json") |
396 |
) |
|
397 | 11x |
output_dir |
398 |
}, |
|
399 |
#' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory. |
|
400 |
#' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics. |
|
401 |
#' @return `self`, invisibly. |
|
402 |
#' @note if Report has an id when converting to JSON then It will be compared to the currently available one. |
|
403 |
#' @examples |
|
404 |
#' reporter <- Reporter$new() |
|
405 |
#' tmp_dir <- file.path(tempdir(), "jsondir") |
|
406 |
#' dir.create(tmp_dir) |
|
407 |
#' unlink(list.files(tmp_dir, recursive = TRUE)) |
|
408 |
#' reporter$to_jsondir(tmp_dir) |
|
409 |
#' reporter$from_jsondir(tmp_dir) |
|
410 |
from_jsondir = function(output_dir) { |
|
411 | 5x |
checkmate::assert_directory_exists(output_dir) |
412 | 5x |
dir_files <- list.files(output_dir) |
413 | 5x |
stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0) |
414 | 5x |
stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files)) |
415 | 5x |
json <- jsonlite::read_json(file.path(output_dir, "Report.json")) |
416 | 5x |
self$reset() |
417 | 5x |
self$from_list(json, output_dir) |
418 | 4x |
invisible(self) |
419 |
}, |
|
420 |
#' @description Set the `Reporter` id |
|
421 |
#' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list. |
|
422 |
#' The id is added to the downloaded file name. |
|
423 |
#' @param id (`character(1)`) a Report id. |
|
424 |
#' @return `self`, invisibly. |
|
425 |
set_id = function(id) { |
|
426 | 14x |
private$id <- id |
427 | 14x |
invisible(self) |
428 |
}, |
|
429 |
#' @description Get or set the reactive trigger to open the previewer modal. |
|
430 |
#' @param val value to the passed to the reactive trigger. |
|
431 |
#' @return `reactiveVal` value |
|
432 |
open_previewer = function(val) { |
|
433 | ! |
if (missing(val)) { |
434 | ! |
private$open_previewer_r() |
435 |
} else { |
|
436 | ! |
private$open_previewer_r(val) |
437 |
} |
|
438 |
}, |
|
439 |
#' @description Get cached HTML for a specific `teal_card` by its id. |
|
440 |
#' @param card_id (`character(1)`) the unique id of the card. |
|
441 |
get_cached_html = function(card_id) { |
|
442 | 6x |
if (shiny::isRunning()) { |
443 | ! |
private$cached_html[[card_id]] |
444 |
} else { |
|
445 | 6x |
shiny::isolate(private$cached_html[[card_id]]) |
446 |
} |
|
447 |
}, |
|
448 |
#' @description Get the `Reporter` id |
|
449 |
#' @return `character(1)` the `Reporter` id. |
|
450 | 43x |
get_id = function() private$id, |
451 |
#' @description Set template function for `teal_card` |
|
452 |
#' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards` |
|
453 |
#' @param template (`function`) a template function. |
|
454 |
#' @return `self`, invisibly. |
|
455 |
#' @examples |
|
456 |
#' |
|
457 |
#' reporter <- teal.reporter::Reporter$new() |
|
458 |
#' template_fun <- function(document) { |
|
459 |
#' disclaimer <- teal.reporter::teal_card("Here comes disclaimer text") |
|
460 |
#' c(disclaimer, document) |
|
461 |
#' } |
|
462 |
#' reporter$set_template(template_fun) |
|
463 |
#' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text") |
|
464 |
#' metadata(doc1, "title") <- "Welcome card" |
|
465 |
#' reporter$append_cards(doc1) |
|
466 |
#' reporter$get_cards() |
|
467 |
set_template = function(template) { |
|
468 | 2x |
private$template <- template |
469 | 2x |
invisible(self) |
470 |
}, |
|
471 |
#' @description Get the `Reporter` template |
|
472 |
#' @return a template `function`. |
|
473 | 85x |
get_template = function() private$template |
474 |
), |
|
475 |
private = list( |
|
476 |
id = "", |
|
477 |
cards = NULL, # reactiveValues |
|
478 |
cached_html = NULL, # reactiveValues |
|
479 |
open_previewer_r = NULL, # reactiveVal to trigger reactive contexts |
|
480 |
override_order = character(0L), # to sort cards (reactiveValues are not sortable) |
|
481 |
metadata = list(), |
|
482 |
template = NULL, |
|
483 |
# @description The copy constructor. |
|
484 |
# |
|
485 |
# @param name the name of the field |
|
486 |
# @param value the value of the field |
|
487 |
# @return the new value of the field |
|
488 |
# |
|
489 |
deep_clone = function(name, value) { |
|
490 | 31x |
shiny::isolate({ |
491 | 31x |
if (name == "cards") { |
492 | 1x |
new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) { |
493 | 1x |
if (R6::is.R6(card)) card$clone(deep = TRUE) else card |
494 |
}) |
|
495 | 1x |
do.call(shiny::reactiveValues, new_cards) |
496 |
} else { |
|
497 | 30x |
value |
498 |
} |
|
499 |
}) |
|
500 |
} |
|
501 |
), |
|
502 |
lock_objects = TRUE, |
|
503 |
lock_class = TRUE |
|
504 |
) |
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 |
#' 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 |
#' @importFrom tools toHTML |
|
2 |
NULL |
|
3 | ||
4 |
#' @method toHTML default |
|
5 |
#' @keywords internal |
|
6 |
#' @export |
|
7 |
toHTML.default <- function(x, ...) { |
|
8 | 429x |
.toHTML(x, ...) |
9 |
} |
|
10 | ||
11 |
#' @keywords internal |
|
12 |
.toHTML <- function(x, ...) { # nolint: object_name. |
|
13 | 429x |
UseMethod(".toHTML", x) |
14 |
} |
|
15 | ||
16 |
#' @method .toHTML default |
|
17 |
#' @keywords internal |
|
18 |
.toHTML.default <- function(x, ...) { |
|
19 | 216x |
shiny::HTML(commonmark::markdown_html(x, extensions = TRUE)) |
20 |
} |
|
21 | ||
22 |
#' @method .toHTML ReportCard |
|
23 |
#' @keywords internal |
|
24 |
.toHTML.ReportCard <- function(x, ...) { |
|
25 | ! |
shiny::tagList(lapply(x$get_content(), tools::toHTML)) |
26 |
} |
|
27 | ||
28 |
#' @method .toHTML teal_card |
|
29 |
#' @keywords internal |
|
30 |
.toHTML.teal_card <- function(x, ...) { |
|
31 | ! |
shiny::tagList(lapply(x, tools::toHTML, ...)) |
32 |
} |
|
33 | ||
34 |
#' @method .toHTML teal_report |
|
35 |
#' @keywords internal |
|
36 |
.toHTML.teal_report <- function(x, ...) { |
|
37 | ! |
tools::toHTML(teal_card(x), ...) |
38 |
} |
|
39 | ||
40 |
#' @method .toHTML rtables |
|
41 |
#' @keywords internal |
|
42 |
.toHTML.rtables <- function(x, ...) { |
|
43 | 78x |
shiny::tags$pre(tools::toHTML(to_flextable(x))) |
44 |
} |
|
45 | ||
46 |
#' @method .toHTML flextable |
|
47 |
#' @keywords internal |
|
48 |
.toHTML.flextable <- function(x, ...) { |
|
49 | 78x |
flextable::htmltools_value(x) |
50 |
} |
|
51 | ||
52 |
#' @method .toHTML condition |
|
53 |
#' @keywords internal |
|
54 |
.toHTML.condition <- function(x, ...) { |
|
55 | ! |
conditionMessage(x) |
56 |
} |
|
57 | ||
58 |
.plot2html <- function(x, ...) { |
|
59 | 56x |
on.exit(unlink(tmpfile)) |
60 | 56x |
tmpfile <- tempfile(fileext = ".png") |
61 | 56x |
dims <- resolve_figure_dimensions(x) |
62 | 56x |
grDevices::png(filename = tmpfile, width = dims$width, height = dims$height) |
63 | 56x |
print(x) |
64 | 56x |
grDevices::dev.off() |
65 | 56x |
shiny::tags$img(src = knitr::image_uri(tmpfile), style = "width: 100%; height: auto;") |
66 |
} |
|
67 | ||
68 |
#' @method .toHTML recordedplot |
|
69 |
#' @keywords internal |
|
70 |
.toHTML.recordedplot <- .plot2html |
|
71 | ||
72 |
#' @method .toHTML trellis |
|
73 |
#' @keywords internal |
|
74 |
.toHTML.trellis <- .plot2html |
|
75 | ||
76 |
#' @method .toHTML gg |
|
77 |
#' @keywords internal |
|
78 |
.toHTML.gg <- function(x, ...) { |
|
79 | ! |
on.exit(unlink(tmpfile)) |
80 | ! |
dims <- resolve_figure_dimensions(x, convert_to_inches = TRUE, dpi = 100) |
81 | ! |
tmpfile <- tempfile(fileext = ".png") |
82 | ! |
ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100) |
83 | ! |
shiny::tags$img(src = knitr::image_uri(tmpfile)) |
84 |
} |
|
85 | ||
86 |
#' @method .toHTML grob |
|
87 |
#' @keywords internal |
|
88 |
.toHTML.grob <- function(x, ...) { |
|
89 | ! |
on.exit(unlink(tmpfile)) |
90 | ! |
dims <- resolve_figure_dimensions(x) |
91 | ! |
tmpfile <- tempfile(fileext = ".png") |
92 | ! |
grDevices::png(filename = tmpfile, width = dims$width, height = dims$height) |
93 | ! |
grid::grid.newpage() |
94 | ! |
grid::grid.draw(x) |
95 | ! |
grDevices::dev.off() |
96 | ! |
shiny::tags$img(src = knitr::image_uri(tmpfile)) |
97 |
} |
|
98 | ||
99 |
#' @method .toHTML code_chunk |
|
100 |
#' @keywords internal |
|
101 |
.toHTML.code_chunk <- function(x, ...) { |
|
102 | 1x |
shiny::tags$pre( |
103 | 1x |
shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang"))), |
104 | 1x |
.noWS = "inside" |
105 |
) |
|
106 |
} |
|
107 | ||
108 |
#' @method .toHTML chunk_output |
|
109 |
#' @keywords internal |
|
110 |
.toHTML.chunk_output <- function(x, ...) { |
|
111 | ! |
new_x <- x[[1]] |
112 | ! |
attributes(new_x) <- c(attributes(x)[!names(attributes(x)) %in% "class"], attributes(new_x)) |
113 | ! |
tools::toHTML(new_x, ...) |
114 |
} |
|
115 | ||
116 |
#' @method .toHTML summary.lm |
|
117 |
#' @keywords internal |
|
118 |
.toHTML.summary.lm <- function(x, ...) { |
|
119 | ! |
shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n")) |
120 |
} |
|
121 | ||
122 |
#' @method .toHTML TableTree |
|
123 |
#' @keywords internal |
|
124 |
.toHTML.TableTree <- .toHTML.rtables |
|
125 | ||
126 |
#' @method .toHTML ElementaryTable |
|
127 |
#' @keywords internal |
|
128 |
.toHTML.ElementaryTable <- .toHTML.rtables |
|
129 | ||
130 |
#' @method .toHTML rlisting |
|
131 |
#' @keywords internal |
|
132 |
.toHTML.rlisting <- .toHTML.rtables |
|
133 | ||
134 |
#' @method .toHTML data.frame |
|
135 |
#' @keywords internal |
|
136 |
.toHTML.data.frame <- .toHTML.rtables |
|
137 | ||
138 |
#' @method .toHTML datatables |
|
139 |
#' @keywords internal |
|
140 |
.toHTML.datatables <- function(x, ...) { |
|
141 | ! |
x |
142 |
} |
|
143 | ||
144 |
#' @method .toHTML gtsummary |
|
145 |
#' @keywords internal |
|
146 |
.toHTML.gtsummary <- function(x, ...) { |
|
147 | ! |
tools::toHTML(gtsummary::as_flex_table(x)) |
148 |
} |
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 | ! |
shiny::moduleServer(id, function(input, output, session) { |
20 | ! |
blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot |
21 | ! |
blocks_queue_rv <- shiny::reactiveVal() |
22 | ||
23 | ! |
shiny::observeEvent(card_r(), { # Reset on card change |
24 | ! |
for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL |
25 | ! |
blocks_queue_rv(NULL) # Force retriggering |
26 | ! |
blocks_queue_rv(names(card_r())) |
27 |
}) |
|
28 | ||
29 | ! |
shiny::observeEvent(blocks_queue_rv(), { |
30 | ! |
lapply(blocks_queue_rv(), function(block_name) { |
31 | ! |
new_block_id <- shiny::NS("blocks", block_name) |
32 | ! |
block_content <- card_r()[[block_name]] %||% "" # Initialize as empty string |
33 | ! |
blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content) |
34 | ||
35 | ! |
if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered |
36 | ! |
new_block_ui <- ui_editor_block( |
37 | ! |
session$ns(new_block_id), |
38 | ! |
value = block_content, |
39 | ! |
cached_html = NULL |
40 |
) |
|
41 | ! |
shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui) |
42 |
} |
|
43 |
}) |
|
44 |
}) |
|
45 | ||
46 | ! |
shiny::observeEvent(input$add_block, { |
47 | ! |
new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1) |
48 | ! |
blocks_queue_rv(new_name) |
49 |
}) |
|
50 | ||
51 | ! |
blocks_inputs_rvs |
52 |
}) |
|
53 |
} |
1 |
ui_previewer_card_actions <- function(id) { |
|
2 | ! |
ns <- shiny::NS(id) |
3 | ! |
shiny::tagList( |
4 | ! |
shiny::actionLink( |
5 | ! |
inputId = ns("edit_action"), |
6 | ! |
class = "btn btn-primary btn-sm float-end p-3", |
7 | ! |
label = NULL, |
8 | ! |
title = "Edit card", |
9 | ! |
icon = shiny::icon("edit") |
10 |
), |
|
11 | ! |
shiny::actionLink( |
12 | ! |
inputId = ns("remove_action"), |
13 | ! |
class = "btn btn-danger btn-sm float-end p-3", |
14 | ! |
label = NULL, |
15 | ! |
icon = shiny::icon("trash-alt"), |
16 |
) |
|
17 |
) |
|
18 |
} |
|
19 | ||
20 |
srv_previewer_card_actions <- function(id, card_r, card_id, reporter) { |
|
21 | ! |
shiny::moduleServer(id, function(input, output, session) { |
22 | ! |
new_card_rv <- shiny::reactiveVal() |
23 | ||
24 | ! |
shiny::observeEvent( |
25 | ! |
ignoreInit = TRUE, |
26 | ! |
input$edit_action, |
27 |
{ |
|
28 | ! |
template_card <- card_r() |
29 | ! |
new_card_rv(template_card) |
30 | ! |
title <- metadata(template_card, "title") |
31 | ||
32 | ! |
if (is.null(title) || isFALSE(nzchar(title))) { |
33 | ! |
title <- shiny::tags$span(class = "text-muted", "(Empty title)") |
34 |
} |
|
35 | ||
36 | ! |
shiny::showModal( |
37 | ! |
shiny::modalDialog( |
38 | ! |
title = shiny::tags$span( |
39 | ! |
class = "edit_title_container", |
40 | ! |
"Editing Card:", |
41 | ! |
shiny::tags$span(id = session$ns("static_title"), title), |
42 | ! |
shiny::actionButton( |
43 | ! |
session$ns("edit_title"), |
44 | ! |
label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"), |
45 | ! |
class = "fs-6", |
46 | ! |
title = "Edit title" |
47 |
), |
|
48 | ! |
shinyjs::hidden( |
49 | ! |
shiny::textInput( |
50 | ! |
session$ns("new_title"), |
51 | ! |
label = NULL, value = metadata(template_card, "title") |
52 |
) |
|
53 |
) |
|
54 |
), |
|
55 | ! |
size = "l", |
56 | ! |
easyClose = TRUE, |
57 | ! |
shiny::tagList( |
58 | ! |
ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)), |
59 | ! |
shiny::uiOutput(session$ns("add_text_element_button_ui")) |
60 |
), |
|
61 | ! |
footer = shiny::tagList( |
62 | ! |
shiny::actionButton(session$ns("edit_save"), label = "Save"), |
63 | ! |
shiny::modalButton("Close") |
64 |
) |
|
65 |
) |
|
66 |
) |
|
67 |
} |
|
68 |
) |
|
69 | ||
70 | ! |
block_input_names_rvs <- srv_card_editor("editor", new_card_rv) |
71 | ||
72 | ! |
shiny::observeEvent(input$edit_title, { |
73 | ! |
shinyjs::hide("edit_title") |
74 | ! |
shinyjs::hide("static_title") |
75 | ! |
shinyjs::show("new_title") |
76 | ! |
shinyjs::js$jumpToFocus(session$ns("new_title")) |
77 |
}) |
|
78 | ||
79 |
# Handle |
|
80 | ! |
shiny::observeEvent(input$edit_save, { |
81 | ! |
new_card <- shiny::req(new_card_rv()) |
82 | ! |
input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs)) |
83 | ! |
for (name in names(input_r)) { |
84 | ! |
new_card[[name]] <- shiny::isolate(input_r[[name]]()) |
85 |
} |
|
86 | ! |
if (isFALSE(is.null(input$new_title))) { |
87 | ! |
metadata(new_card, "title") <- input$new_title |
88 |
} |
|
89 | ! |
if (isFALSE(identical(new_card, card_r()))) { |
90 | ! |
tryCatch( |
91 |
{ |
|
92 | ! |
reporter$replace_card(card = new_card, card_id = card_id) |
93 | ! |
new_card_rv(NULL) |
94 | ! |
reporter$open_previewer(Sys.time()) |
95 | ! |
shiny::showNotification("Card was successfully updated.", type = "message") |
96 |
}, |
|
97 | ! |
error = function(err) { |
98 | ! |
shiny::showNotification( |
99 | ! |
sprintf( |
100 | ! |
"A card with the name '%s' already exists. Please use a different name.", |
101 | ! |
metadata(new_card, "title") |
102 |
), |
|
103 | ! |
type = "error", |
104 | ! |
duration = 5 |
105 |
) |
|
106 | ! |
shinyjs::enable("edit_save") |
107 |
} |
|
108 |
) |
|
109 |
} else { |
|
110 | ! |
new_card_rv(NULL) |
111 | ! |
reporter$open_previewer(Sys.time()) |
112 |
} |
|
113 |
}) |
|
114 | ||
115 |
# Handle remove button |
|
116 | ! |
shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id)) |
117 |
}) |
|
118 |
} |
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 | 3x |
checkmate::assert_string(label, null.ok = TRUE) |
28 | 3x |
.outline_button(shiny::NS(id, "download_button"), label = label, icon = "download") |
29 |
} |
|
30 | ||
31 |
#' @rdname download_report_button |
|
32 |
#' @export |
|
33 |
download_report_button_srv <- function(id, |
|
34 |
reporter, |
|
35 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
36 |
rmd_output = getOption("teal.reporter.rmd_output"), |
|
37 |
rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")) { |
|
38 | 20x |
checkmate::assert_class(reporter, "Reporter") |
39 | 20x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
40 | 20x |
checkmate::assert_subset( |
41 | 20x |
rmd_output, |
42 | 20x |
c( |
43 | 20x |
"html_document", "pdf_document", |
44 | 20x |
"powerpoint_presentation", "word_document" |
45 |
), |
|
46 | 20x |
empty.ok = FALSE |
47 |
) |
|
48 | 20x |
checkmate::assert_list(rmd_yaml_args, names = "named") |
49 | 20x |
checkmate::assert_names( |
50 | 20x |
names(rmd_yaml_args), |
51 | 20x |
subset.of = c("author", "title", "date", "output", "toc"), |
52 | 20x |
must.include = "output" |
53 |
) |
|
54 | 18x |
checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) |
55 | ||
56 | 17x |
shiny::moduleServer(id, function(input, output, session) { |
57 | 17x |
shiny::setBookmarkExclude(c("download_button")) |
58 | ||
59 | 17x |
ns <- session$ns |
60 | ||
61 | 17x |
download_modal <- function() { |
62 | 1x |
nr_cards <- length(reporter$get_cards()) |
63 | 1x |
downb <- shiny::downloadButton( |
64 | 1x |
outputId = ns("download_data"), |
65 | 1x |
label = "Download", |
66 | 1x |
class = c( |
67 | 1x |
"btn", "teal-reporter", "download-ok", "btn-primary", "shiny-download-link", |
68 | 1x |
if (nr_cards == 0) "disabled" |
69 |
), |
|
70 | 1x |
icon = shiny::icon("download") |
71 |
) |
|
72 | ||
73 | 1x |
shiny::tags$div( |
74 | 1x |
class = "teal-reporter reporter-modal", |
75 | 1x |
.custom_css_dependency(), |
76 | 1x |
shiny::modalDialog( |
77 | 1x |
easyClose = TRUE, |
78 | 1x |
shiny::tags$h3("Download the Report"), |
79 | 1x |
shiny::tags$hr(), |
80 | 1x |
if (length(reporter$get_cards()) == 0) { |
81 | ! |
shiny::tags$div( |
82 | ! |
shiny::tags$p( |
83 | ! |
class = "text-danger", |
84 | ! |
shiny::tags$strong("No Cards Added") |
85 |
), |
|
86 | ! |
shiny::tags$br() |
87 |
) |
|
88 |
} else { |
|
89 | 1x |
shiny::tags$div( |
90 | 1x |
shiny::tags$p( |
91 | 1x |
class = "text-success", |
92 | 1x |
shiny::tags$strong(paste("Number of cards: ", nr_cards)) |
93 |
), |
|
94 | 1x |
shiny::tags$br() |
95 |
) |
|
96 |
}, |
|
97 | 1x |
reporter_download_inputs( |
98 | 1x |
rmd_yaml_args = rmd_yaml_args, |
99 | 1x |
rmd_output = rmd_output, |
100 | 1x |
showrcode = any_rcode_block(reporter), |
101 | 1x |
session = session |
102 |
), |
|
103 | 1x |
footer = shiny::tagList( |
104 | 1x |
shiny::tags$button( |
105 | 1x |
type = "button", |
106 | 1x |
class = "btn btn-outline-secondary", |
107 | 1x |
`data-bs-dismiss` = "modal", |
108 | 1x |
NULL, |
109 | 1x |
"Dismiss" |
110 |
), |
|
111 | 1x |
shiny::tags$a( |
112 | 1x |
id = ns("download_data"), |
113 | 1x |
class = "btn btn-primary shiny-download-link", |
114 | 1x |
href = "", |
115 | 1x |
target = "_blank", |
116 | 1x |
download = NA, |
117 | 1x |
shiny::icon("download"), |
118 | 1x |
"Download" |
119 |
) |
|
120 |
) |
|
121 |
) |
|
122 |
) |
|
123 |
} |
|
124 | ||
125 | 17x |
shiny::observeEvent(reporter$get_cards(), { |
126 | 9x |
shinyjs::toggleState(length(reporter$get_cards()) > 0, id = "download_button") |
127 |
}) |
|
128 | ||
129 | 17x |
shiny::observeEvent(input$download_button, shiny::showModal(download_modal())) |
130 | ||
131 | 17x |
output$download_data <- shiny::downloadHandler( |
132 | 17x |
filename = function() paste0(.report_identifier(reporter), ".zip"), |
133 | 17x |
content = function(file) { |
134 | 3x |
shiny::showNotification("Rendering and Downloading the document.") |
135 | 3x |
shinybusy::block(id = ns("download_data"), text = "", type = "dots") |
136 | 3x |
rmd_yaml_with_inputs <- lapply(names(rmd_yaml_args), function(x) input[[x]]) |
137 | 3x |
names(rmd_yaml_with_inputs) <- names(rmd_yaml_args) |
138 | ! |
if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode |
139 | 3x |
report_render_and_compress( |
140 | 3x |
reporter = reporter, |
141 | 3x |
rmd_yaml_args = rmd_yaml_with_inputs, |
142 | 3x |
global_knitr = global_knitr, |
143 | 3x |
file = file |
144 |
) |
|
145 | 3x |
shinybusy::unblock(id = ns("download_data")) |
146 |
}, |
|
147 | 17x |
contentType = "application/zip" |
148 |
) |
|
149 |
}) |
|
150 |
} |
|
151 | ||
152 |
#' Render the report |
|
153 |
#' |
|
154 |
#' Render the report and zip the created directory. |
|
155 |
#' |
|
156 |
#' @param reporter (`Reporter`) instance. |
|
157 |
#' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their values. |
|
158 |
#' @param global_knitr (`list`) a global `knitr` parameters, like echo. |
|
159 |
#' But if local parameter is set it will have priority. |
|
160 |
#' @param file (`character(1)`) where to copy created zip file. |
|
161 |
#' |
|
162 |
#' @return `file` argument, invisibly. |
|
163 |
#' |
|
164 |
#' @keywords internal |
|
165 |
report_render_and_compress <- function(reporter, rmd_yaml_args, global_knitr, file = tempfile()) { |
|
166 | 8x |
checkmate::assert_class(reporter, "Reporter") |
167 | 8x |
checkmate::assert_list(rmd_yaml_args, names = "named") |
168 | 7x |
checkmate::assert_string(file) |
169 | ||
170 | 5x |
tmp_dir <- file.path(tempdir(), .report_identifier(reporter)) |
171 | ||
172 | 5x |
cards_combined <- reporter$get_blocks() |
173 | 5x |
metadata(cards_combined) <- utils::modifyList(metadata(cards_combined), rmd_yaml_args) |
174 | ||
175 | 5x |
tryCatch( |
176 | 5x |
render( |
177 | 5x |
input = cards_combined, |
178 | 5x |
output_dir = tmp_dir, |
179 | 5x |
global_knitr = global_knitr, |
180 | 5x |
quiet = TRUE |
181 |
), |
|
182 | 5x |
warning = function(cond) message("Render document warning: ", cond), |
183 | 5x |
error = function(cond) { |
184 | ! |
message("Render document error: ", cond) |
185 | ! |
do.call("return", args = list(), envir = parent.frame(2)) |
186 |
} |
|
187 |
) |
|
188 | ||
189 | 5x |
tryCatch( |
190 | 5x |
reporter$to_jsondir(tmp_dir), |
191 | 5x |
warning = function(cond) message("Archive document warning: ", cond), |
192 | 5x |
error = function(cond) message("Archive document error: ", cond) |
193 |
) |
|
194 | ||
195 | 5x |
tryCatch( |
196 | 5x |
reporter$write_figures(tmp_dir), |
197 | 5x |
warning = function(cond) message("Save reporter images warning: ", cond), |
198 | 5x |
error = function(cond) message("Save reporter images error: ", cond) |
199 |
) |
|
200 | ||
201 | 5x |
temp_zip_file <- tempfile(fileext = ".zip") |
202 | 5x |
tryCatch( |
203 | 5x |
zip::zipr(temp_zip_file, tmp_dir), |
204 | 5x |
warning = function(cond) message("Zipping folder warning: ", cond), |
205 | 5x |
error = function(cond) message("Zipping folder error: ", cond) |
206 |
) |
|
207 | ||
208 | 5x |
tryCatch( |
209 |
{ |
|
210 | 5x |
file.copy(temp_zip_file, file) |
211 | 5x |
unlink(tmp_dir, recursive = TRUE) |
212 |
}, |
|
213 | 5x |
warning = function(cond) message("Copying file warning: ", cond), |
214 | 5x |
error = function(cond) message("Copying file error: ", cond) |
215 |
) |
|
216 | 5x |
invisible(file) |
217 |
} |
|
218 | ||
219 |
#' Get the custom list of UI inputs |
|
220 |
#' |
|
221 |
#' @param rmd_output (`character`) vector with `rmarkdown` output types, |
|
222 |
#' by default all possible `pdf_document`, `html_document`, `powerpoint_presentation`, and `word_document`. |
|
223 |
#' If vector is named then those names will appear in the `UI`. |
|
224 |
#' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their default values. |
|
225 |
#' This `list` will result in the custom subset of UI inputs for the download reporter functionality. |
|
226 |
#' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`. |
|
227 |
#' The `list` must include at least `"output"` field. |
|
228 |
#' The default value for `"output"` has to be in the `rmd_output` argument. |
|
229 |
#' |
|
230 |
#' @keywords internal |
|
231 |
reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) { |
|
232 | 1x |
shiny::tagList( |
233 | 1x |
lapply(names(rmd_yaml_args), function(e) { |
234 | 5x |
switch(e, |
235 | 1x |
author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author), |
236 | 1x |
title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title), |
237 | 1x |
date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date), |
238 | 1x |
output = shiny::tags$div( |
239 | 1x |
shinyWidgets::pickerInput( |
240 | 1x |
inputId = session$ns("output"), |
241 | 1x |
label = "Choose a document type: ", |
242 | 1x |
choices = rmd_output, |
243 | 1x |
selected = rmd_yaml_args$output |
244 |
) |
|
245 |
), |
|
246 | 1x |
toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc) |
247 |
) |
|
248 |
}), |
|
249 | 1x |
if (showrcode) { |
250 | ! |
shiny::checkboxInput( |
251 | ! |
session$ns("showrcode"), |
252 | ! |
label = "Include R Code", |
253 | ! |
value = FALSE |
254 |
) |
|
255 |
} |
|
256 |
) |
|
257 |
} |
|
258 | ||
259 |
#' @noRd |
|
260 |
#' @keywords internal |
|
261 |
any_rcode_block <- function(reporter) { |
|
262 | 3x |
cards <- reporter$get_cards() |
263 | ||
264 | 3x |
any( |
265 | 3x |
vapply( |
266 | 3x |
reporter$get_blocks(), |
267 | 3x |
inherits, |
268 | 3x |
logical(1), |
269 | 3x |
what = "code_chunk" |
270 |
) |
|
271 |
) |
|
272 |
} |
|
273 | ||
274 |
.report_identifier <- function(reporter) { |
|
275 | 8x |
id <- paste0("_", reporter$get_id()) %||% "" |
276 | 8x |
timestamp <- format(Sys.time(), "_%y%m%d%H%M%S") |
277 | 8x |
sprintf("reporter%s%s", id, timestamp) |
278 |
} |
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 |
#' @examples |
|
19 |
#' # Create a new empty card |
|
20 |
#' report <- teal_card() |
|
21 |
#' |
|
22 |
#' # Create a card with content |
|
23 |
#' report <- teal_card("## Headline", "Some text", summary(iris)) |
|
24 |
#' |
|
25 |
#' # Extract card from a teal_report |
|
26 |
#' tr <- teal_report(teal_card = teal_card("## Title")) |
|
27 |
#' doc <- teal_card(tr) |
|
28 |
#' |
|
29 |
#' # Add elements to the report |
|
30 |
#' report <- c(report, list("## Table"), list(summary(mtcars))) |
|
31 |
#' |
|
32 |
#' # Subset the report to keep only the first two elements |
|
33 |
#' report <- report[1:2] |
|
34 |
#' |
|
35 |
#' # Append new elements after the first element |
|
36 |
#' report <- append(report, c(list("## Table 2"), list(summary(mtcars))), after = 1) |
|
37 |
#' |
|
38 |
#' # Verify that the object remains a teal_card |
|
39 |
#' class(report) |
|
40 |
#' |
|
41 |
#' @aliases teal_card |
|
42 |
#' @name teal_card |
|
43 |
#' |
|
44 |
#' @export |
|
45 |
teal_card <- function(...) { |
|
46 | 777x |
UseMethod("teal_card") |
47 |
} |
|
48 | ||
49 |
#' @export |
|
50 |
#' @keywords internal |
|
51 |
teal_card.default <- function(...) { |
|
52 | 601x |
x <- lapply(list(...), .convert_teal_card_input) |
53 | ||
54 | 601x |
if (length(x) > 0) { |
55 | 350x |
names(x) <- vapply( |
56 | 350x |
sample.int(.Machine$integer.max, size = length(x)), |
57 | 350x |
function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8), |
58 | 350x |
character(1) |
59 |
) |
|
60 |
} |
|
61 | 601x |
structure(x, class = "teal_card") |
62 |
} |
|
63 | ||
64 |
#' @export |
|
65 |
#' @keywords internal |
|
66 |
teal_card.teal_card <- function(...) { |
|
67 | 89x |
dots <- list(...) |
68 | 89x |
c(dots[[1]], dots[-1]) |
69 |
} |
|
70 | ||
71 |
#' @export |
|
72 |
#' @keywords internal |
|
73 |
teal_card.teal_report <- function(...) { |
|
74 | 84x |
dots <- list(...) |
75 | 84x |
dots[[1]] <- dots[[1]]@teal_card |
76 | 84x |
do.call(teal_card, args = dots) |
77 |
} |
|
78 | ||
79 |
#' @export |
|
80 |
#' @keywords internal |
|
81 |
teal_card.qenv <- function(...) { |
|
82 | 3x |
dots <- list(...) |
83 | 3x |
dots[[1]] <- .code_to_card(dots[[1]]@code) |
84 | 3x |
do.call(teal_card, args = dots) |
85 |
} |
|
86 | ||
87 |
#' @rdname teal_card |
|
88 |
#' @param value (`teal_card`) object to set in the `teal_report`. |
|
89 |
#' @export |
|
90 |
`teal_card<-` <- function(x, value) { |
|
91 | 40x |
x <- methods::as(x, "teal_report") |
92 | 40x |
checkmate::assert_class(x, "teal_report") |
93 | 40x |
x@teal_card <- as.teal_card(value) |
94 | 40x |
x |
95 |
} |
|
96 | ||
97 |
#' @export |
|
98 |
`[[<-.teal_card` <- function(x, index, value) { |
|
99 | 6x |
new_card <- as.teal_card(value) |
100 | 6x |
value <- new_card[[1]] |
101 | 6x |
new_x <- NextMethod() |
102 | 6x |
if (checkmate::test_integerish(index)) { |
103 | 2x |
names(new_x)[[index]] <- names(new_card)[[1]] |
104 |
} |
|
105 | 6x |
new_x |
106 |
} |
|
107 | ||
108 |
#' Create or coerce to a teal_card |
|
109 |
#' |
|
110 |
#' This function ensures that input is converted to a teal_card object. |
|
111 |
#' It accepts various input types and converts them appropriately. |
|
112 |
#' |
|
113 |
#' @param x Object to convert to teal_card |
|
114 |
#' @return A teal_card object |
|
115 |
#' @rdname teal_card |
|
116 |
#' @export |
|
117 |
as.teal_card <- function(x) { # nolint: object_name. |
|
118 | 812x |
if (inherits(x, "teal_card")) { |
119 | 514x |
return(x) |
120 |
} |
|
121 | 298x |
if (identical(class(x), "list")) { |
122 | 92x |
return(do.call(teal_card, unname(x))) |
123 |
} |
|
124 | 206x |
teal_card(x) |
125 |
} |
|
126 | ||
127 |
#' @rdname teal_card |
|
128 |
#' @export |
|
129 |
c.teal_card <- function(...) { |
|
130 | 315x |
dots <- list(...) |
131 | 315x |
structure( |
132 | 315x |
Reduce( |
133 | 315x |
f = function(u, v) { |
134 | 705x |
v <- as.teal_card(v) |
135 | 705x |
if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u |
136 | 3x |
if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v` |
137 | 2x |
v |
138 |
} else { |
|
139 | 1x |
warning( |
140 | 1x |
"Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n", |
141 | 1x |
"Restoring original content and adding only new items to the end of the card." |
142 |
) |
|
143 | 1x |
utils::modifyList(u, v) |
144 |
} |
|
145 |
} else { |
|
146 | 702x |
attrs <- utils::modifyList(attributes(u) %||% list(), attributes(v)) |
147 | 702x |
attrs$names <- union(names(u), names(v)) |
148 | 702x |
attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %||% list(), metadata(v)) |
149 | 702x |
result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass |
150 | 702x |
attributes(result) <- attrs |
151 | 702x |
result |
152 |
} |
|
153 |
}, |
|
154 | 315x |
x = dots, |
155 | 315x |
init = list() |
156 |
), |
|
157 | 315x |
class = "teal_card" |
158 |
) |
|
159 |
} |
|
160 | ||
161 |
#' @param i index specifying elements to extract or replace |
|
162 |
#' @rdname teal_card |
|
163 |
#' @export |
|
164 |
`[.teal_card` <- function(x, i) { |
|
165 | 5x |
out <- NextMethod() |
166 | 5x |
class(out) <- "teal_card" |
167 | 5x |
attr(out, "metadata") <- metadata(x) |
168 | 5x |
out |
169 |
} |
|
170 | ||
171 |
#' Access metadata from a `teal_card` or `ReportCard` |
|
172 |
#' |
|
173 |
#' This function retrieves metadata from a `teal_card` or `ReportCard` object. |
|
174 |
#' When `which` is `NULL`, it returns all metadata fields as a list. |
|
175 |
#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata. |
|
176 |
#' @param which (`character` or `NULL`) The name of the metadata field to extract. |
|
177 |
#' @return A list of metadata fields or a specific field if `which` is provided. |
|
178 |
#' @export |
|
179 |
metadata <- function(object, which = NULL) { |
|
180 | 1134x |
checkmate::assert_string(which, null.ok = TRUE) |
181 | 1134x |
UseMethod("metadata", object) |
182 |
} |
|
183 | ||
184 |
#' @rdname metadata |
|
185 |
#' @export |
|
186 |
metadata.teal_card <- function(object, which = NULL) { |
|
187 | 1130x |
metadata <- attr(object, which = "metadata", exact = TRUE) |
188 | 1130x |
result <- metadata %||% list() |
189 | 1130x |
if (is.null(which)) { |
190 | 1047x |
return(result) |
191 |
} |
|
192 | 83x |
result[[which]] |
193 |
} |
|
194 | ||
195 |
#' @rdname metadata |
|
196 |
#' @export |
|
197 |
metadata.ReportCard <- function(object, which = NULL) { |
|
198 | 4x |
result <- list(title = object$get_name()) |
199 | 4x |
if (is.null(which)) { |
200 | 1x |
return(result) |
201 |
} |
|
202 | 3x |
result[[which]] |
203 |
} |
|
204 | ||
205 |
#' Set metadata for a `teal_card` or `ReportCard` |
|
206 |
#' |
|
207 |
#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object. |
|
208 |
#' It can be used to add new metadata or update existing fields. |
|
209 |
#' @param object (`teal_card` or `ReportCard`) The object to modify. |
|
210 |
#' @param which (`character`) The name of the metadata field to set. |
|
211 |
#' @param value The value to assign to the specified metadata field. |
|
212 |
#' @return The modified object with updated metadata. |
|
213 |
#' @export |
|
214 |
`metadata<-` <- function(object, which = NULL, value) { |
|
215 | 266x |
checkmate::assert_string(which, null.ok = TRUE) |
216 | 266x |
UseMethod("metadata<-", object) |
217 |
} |
|
218 | ||
219 |
#' @rdname metadata-set |
|
220 |
#' @export |
|
221 |
`metadata<-.teal_card` <- function(object, which = NULL, value) { |
|
222 | 249x |
if (missing(which)) { |
223 | 181x |
checkmate::assert_list(value, names = "named") |
224 | 181x |
attr(object, which = "metadata") <- value |
225 | 181x |
return(object) |
226 |
} |
|
227 | 68x |
attr(object, which = "metadata") <- utils::modifyList( |
228 | 68x |
metadata(object), structure(list(value), names = which) |
229 |
) |
|
230 | 68x |
object |
231 |
} |
|
232 | ||
233 |
#' @rdname metadata-set |
|
234 |
#' @details |
|
235 |
#' The `ReportCard` class only supports the `title` field in metadata. |
|
236 |
#' @export |
|
237 |
`metadata<-.ReportCard` <- function(object, which, value) { |
|
238 | 17x |
if (missing(which)) { |
239 | 3x |
if (!is.null(value[["title"]])) { |
240 | 2x |
object$set_name(value[["title"]]) |
241 |
} |
|
242 | 3x |
if (length(value) >= 2 || length(value) == 1 && is.null(value[["title"]])) { |
243 | 2x |
warning("ReportCard class only supports `title` in metadata.") |
244 |
} |
|
245 | 3x |
return(object) |
246 |
} |
|
247 | ||
248 | 14x |
if (isFALSE(identical(which, "title"))) { |
249 | 1x |
warning("ReportCard class only supports `title` in metadata.") |
250 |
} else { |
|
251 | 13x |
object$set_name(value) |
252 |
} |
|
253 | 14x |
object |
254 |
} |
|
255 | ||
256 |
#' Generate an R Markdown code chunk |
|
257 |
#' |
|
258 |
#' This function creates a `code_chunk` object, which represents an R Markdown |
|
259 |
#' code chunk. It stores the R code and any specified chunk options (e.g., `echo`, `eval`). |
|
260 |
#' These objects are typically processed later to generate the final R Markdown text. |
|
261 |
#' |
|
262 |
#' @param code A character string containing the R code. |
|
263 |
#' @param ... Additional named parameters to be included as chunk options (e.g., `echo = TRUE`). |
|
264 |
#' Check [`knitr` options/](https://yihui.org/knitr/options/) for more details. |
|
265 |
#' @param lang (`character(1)`) See [`knitr::knit_engines`]. |
|
266 |
#' |
|
267 |
#' @return An object of class `code_chunk`. |
|
268 |
#' @examples |
|
269 |
#' my_chunk <- code_chunk("x <- 1:10", echo = TRUE, message = FALSE) |
|
270 |
#' class(my_chunk) |
|
271 |
#' attributes(my_chunk)$param |
|
272 |
#' @export |
|
273 |
code_chunk <- function(code, ..., lang = "R") { |
|
274 | 122x |
checkmate::assert_character(code) |
275 | 122x |
params <- list(...) |
276 | 122x |
checkmate::assert_list(params, names = "named", .var.name = "...") |
277 | 122x |
structure( |
278 | 122x |
paste(code, collapse = "\n"), |
279 | 122x |
params = params, |
280 | 122x |
lang = lang, |
281 | 122x |
class = "code_chunk" |
282 |
) |
|
283 |
} |
|
284 | ||
285 |
#' Builds `teal_card` from code and outputs in `qenv` object |
|
286 |
#' |
|
287 |
#' Builds a `teal_card` from the code and outputs of a `teal_data` |
|
288 |
#' object, preserving the order of code execution and output display. |
|
289 |
#' |
|
290 |
#' @inheritParams eval_code-teal_report |
|
291 |
#' @param x (`list`) object from `qenv@code`. |
|
292 |
#' @return A `teal_card` built from the code and outputs in a `qenv` object. |
|
293 |
#' @keywords internal |
|
294 |
.code_to_card <- function(x, code_block_opts = list()) { |
|
295 | 26x |
elems <- Reduce( |
296 | 26x |
function(items, code_elem) { |
297 | 61x |
this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts)) |
298 | 61x |
this_outs <- Filter( # intentionally remove warnings,messages from the generated report |
299 | 61x |
function(x) !inherits(x[[1]], "condition"), |
300 | 61x |
lapply( |
301 | 61x |
attr(code_elem, "outputs"), |
302 | 61x |
function(x) structure(list(x), class = c("chunk_output")) |
303 |
) |
|
304 |
) |
|
305 | 61x |
c(items, list(this_chunk), this_outs) |
306 |
}, |
|
307 | 26x |
init = list(), |
308 | 26x |
x = x |
309 |
) |
|
310 | 26x |
do.call(teal_card, args = elems) |
311 |
} |
|
312 | ||
313 |
#' Internal helper for `teal_card`` input conversion |
|
314 |
#' |
|
315 |
#' Converts input values to a format compatible with `teal_card`. |
|
316 |
#' This function is used internally to handle common inputs, such as `ggplot` objects, |
|
317 |
#' ensuring they are appropriately converted to an "evaluable output" blocks that can |
|
318 |
#' be saved to `RDS` file efficiently. |
|
319 |
#' |
|
320 |
#' This function performs the following conversions: |
|
321 |
#' - `ggplot` objects are converted to `recordedplot` objects. |
|
322 |
#' |
|
323 |
#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`, |
|
324 |
#' no conversion is applied. |
|
325 |
#' |
|
326 |
#' @param x (`object`) An object to be converted. |
|
327 |
#' |
|
328 |
#' @return The processed object, possibly converted or left unchanged. |
|
329 |
#' |
|
330 |
#' @keywords internal |
|
331 |
.convert_teal_card_input <- function(x) { |
|
332 | 599x |
if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) { |
333 | 16x |
return(x) |
334 |
} |
|
335 | 583x |
if (inherits(x, "chunk_output")) { |
336 | 26x |
res <- structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output")) |
337 | 26x |
attributes(res) <- attributes(x) # keep same attributes |
338 | 26x |
res |
339 | 557x |
} else if (inherits(x, "ggplot")) { |
340 | 52x |
.ggplot_to_recordedplot(x) |
341 |
} else { |
|
342 | 505x |
x |
343 |
} |
|
344 |
} |
|
345 | ||
346 |
#' @noRd |
|
347 |
.ggplot_to_recordedplot <- function(x) { |
|
348 | 52x |
checkmate::assert_class(x, "ggplot") |
349 | 52x |
grDevices::pdf(file = NULL) |
350 | 52x |
grDevices::dev.control(displaylist = "enable") |
351 | 52x |
dev <- grDevices::dev.cur() |
352 | 52x |
on.exit(grDevices::dev.off(dev)) |
353 | 52x |
print(x) |
354 | 52x |
grDevices::recordPlot() |
355 |
} |
|
356 | ||
357 |
#' Determine default dimensions for report figures |
|
358 |
#' |
|
359 |
#' @param x An object, typically a `recordedplot` or `ggplot`, that has an |
|
360 |
#' optional attributes `dev.width` and `dev.height` that override the default |
|
361 |
#' dims set as options `teal.reporter.dev.fig.width` and |
|
362 |
#' `teal.reporter.dev.fig.height`. |
|
363 |
#' @return List with `width` and `height` elements. |
|
364 |
#' @keywords internal |
|
365 |
resolve_figure_dimensions <- function(x, convert_to_inches = FALSE, dpi = 96) { |
|
366 | 70x |
checkmate::assert_flag(convert_to_inches) |
367 | 70x |
width <- attr(x, "dev.width") %||% getOption("teal.reporter.dev.fig.width", 800) |
368 | 70x |
height <- attr(x, "dev.height") %||% getOption("teal.reporter.dev.fig.height", 600) |
369 | 70x |
if (width < 150 || height < 150) { |
370 | ! |
warning("Figure dimensions too small, setting to minimum of 150x150 pixels.") |
371 | ! |
width <- max(width, 150) |
372 | ! |
height <- max(height, 150) |
373 |
} |
|
374 | ||
375 | 70x |
if (convert_to_inches) { |
376 | 14x |
width <- width / dpi |
377 | 14x |
height <- height / dpi |
378 |
} |
|
379 | 70x |
list(width = width, height = height) |
380 |
} |
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 <- resolve_figure_dimensions(block, convert_to_inches = TRUE) |
11 | 14x |
sprintf( |
12 | 14x |
"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```", |
13 | 14x |
dims$width, |
14 | 14x |
dims$height, |
15 | 14x |
path |
16 |
) |
|
17 |
} |
|
18 | ||
19 |
#' Convert `ReporterCard`/`teal_card` content to `rmarkdown` |
|
20 |
#' |
|
21 |
#' This is an S3 generic that is used to generate content in `rmarkdown` format |
|
22 |
#' from various types of blocks in a `ReporterCard` or `teal_card` object. |
|
23 |
#' |
|
24 |
#' # Customize `to_rmd` |
|
25 |
#' The methods for this S3 generic can be extended by the app developer or even overwritten. |
|
26 |
#' For this a function with the name `to_rmd.<class>` should be defined in the |
|
27 |
#' Global Environment, where `<class>` is the class of the object to be converted. |
|
28 |
#' |
|
29 |
#' For example, to override the default behavior for `code_chunk` class, you can use: |
|
30 |
#' |
|
31 |
#' ```r |
|
32 |
#' to_rmd.code_chunk <- function(block, ..., output_format) { |
|
33 |
#' # custom implementation |
|
34 |
#' sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block) |
|
35 |
#' } |
|
36 |
#' ``` |
|
37 |
#' |
|
38 |
#' Alternatively, you can register the S3 method using `registerS3method("to_rmd", "<class>", fun)` |
|
39 |
#' |
|
40 |
#' @param block (`any`) content which can be represented in Rmarkdown syntax. |
|
41 |
#' @return `character(1)` containing a content or Rmarkdown document. |
|
42 |
#' @keywords internal |
|
43 |
to_rmd <- function(block, ...) { |
|
44 | 235x |
UseMethod("to_rmd") |
45 |
} |
|
46 | ||
47 |
#' @method to_rmd default |
|
48 |
#' @keywords internal |
|
49 |
to_rmd.default <- function(block, ...) { |
|
50 | 235x |
.to_rmd(block, ...) |
51 |
} |
|
52 | ||
53 |
.to_rmd <- function(block, ...) { |
|
54 | 235x |
UseMethod(".to_rmd") |
55 |
} |
|
56 | ||
57 |
#' @method .to_rmd default |
|
58 |
#' @keywords internal |
|
59 |
.to_rmd.default <- function(block, ...) { |
|
60 | ! |
block |
61 |
} |
|
62 | ||
63 |
#' @method .to_rmd teal_report |
|
64 |
#' @keywords internal |
|
65 |
.to_rmd.teal_report <- function(block, ...) { |
|
66 | 28x |
to_rmd(teal_card(block), ...) |
67 |
} |
|
68 | ||
69 |
#' @method .to_rmd teal_card |
|
70 |
#' @keywords internal |
|
71 |
.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) { |
|
72 | 40x |
checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) |
73 | 40x |
is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation") |
74 | 40x |
powerpoint_exception_parsed <- if (is_powerpoint) { |
75 | ! |
format_code_block_function <- quote( |
76 | ! |
code_block <- function(code_text) { |
77 | ! |
df <- data.frame(code_text) |
78 | ! |
ft <- flextable::flextable(df) |
79 | ! |
ft <- flextable::delete_part(ft, part = "header") |
80 | ! |
ft <- flextable::autofit(ft, add_h = 0) |
81 | ! |
ft <- flextable::fontsize(ft, size = 7, part = "body") |
82 | ! |
ft <- flextable::bg(x = ft, bg = "lightgrey") |
83 | ! |
ft <- flextable::border_outer(ft) |
84 | ! |
if (flextable::flextable_dim(ft)$widths > 8) { |
85 | ! |
ft <- flextable::width(ft, width = 8) |
86 |
} |
|
87 | ! |
ft |
88 |
} |
|
89 |
) |
|
90 | ! |
deparse1(format_code_block_function, collapse = "\n") |
91 |
} else { |
|
92 | 40x |
NULL |
93 |
} |
|
94 | 40x |
global_knitr_parsed <- sprintf( |
95 | 40x |
"knitr::opts_chunk$set(%s)", |
96 | 40x |
paste(utils::capture.output(dput(global_knitr)), collapse = "") |
97 |
) |
|
98 | 40x |
global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE) |
99 | 40x |
global_knitr_rendered <- to_rmd(global_knitr_code_chunk) |
100 | ||
101 |
# we need to prerender global_knitr as code_chunk for powerpoint will wrap it in code_block() call |
|
102 | 40x |
blocks_w_global_knitr <- append( |
103 | 40x |
block, |
104 | 40x |
if (length(global_knitr) || is_powerpoint) list(global_knitr_rendered), |
105 | 40x |
after = 0 |
106 |
) |
|
107 | ||
108 | 40x |
m <- metadata(block) |
109 | 40x |
paste( |
110 | 40x |
c( |
111 | 40x |
if (length(m)) as_yaml_auto(m), |
112 | 40x |
unlist(lapply( |
113 | 40x |
blocks_w_global_knitr, |
114 | 40x |
function(x) to_rmd(x, output_format = m$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 | 52x |
params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l) |
125 | 52x |
block_str <- format(block) |
126 | 52x |
lang <- attr(block, "lang", exact = TRUE) |
127 | 52x |
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 | 52x |
format(block) |
139 |
} |
|
140 |
} |
|
141 | ||
142 |
#' @method .to_rmd character |
|
143 |
#' @keywords internal |
|
144 |
.to_rmd.character <- function(block, ...) { |
|
145 | 85x |
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 |
attributes(new_block) <- c(attributes(block)[!names(attributes(block)) %in% "class"], attributes(new_block)) |
154 | 4x |
to_rmd(block[[1]], ..., 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 |
} |
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 | ! |
shiny::moduleServer(id, function(input, output, session) { |
32 | ! |
output$title <- shiny::renderUI({ |
33 | ! |
title <- metadata(shiny::req(card_r()), "title") |
34 | ! |
if (is.null(title) || isFALSE(nzchar(title))) { |
35 | ! |
title <- shiny::tags$span("(Empty title)", class = "text-muted") |
36 |
} |
|
37 | ! |
title |
38 |
}) |
|
39 | ! |
output$card_content <- shiny::renderUI({ |
40 | ! |
result <- reporter$get_cached_html(card_id) |
41 | ! |
shiny::removeUI(sprintf("#%s", session$ns(paste0("loading_placeholder_", card_id)))) |
42 | ! |
result |
43 |
}) |
|
44 | ||
45 | ! |
srv_previewer_card_actions("actions", card_r, card_id, reporter) |
46 |
}) |
|
47 |
} |
1 |
#' @rdname srv_editor_block |
|
2 |
#' @export |
|
3 |
ui_editor_block <- function(id, value, cached_html) { |
|
4 | ! |
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 | ! |
UseMethod("srv_editor_block", value) |
45 |
} |
|
46 | ||
47 |
#' @export |
|
48 |
ui_editor_block.default <- function(id, value, cached_html) { |
|
49 | ! |
.ui_editor_block(id, value, cached_html) |
50 |
} |
|
51 | ||
52 |
#' @export |
|
53 |
srv_editor_block.default <- function(id, value) { |
|
54 | ! |
.srv_editor_block(id, value) |
55 |
} |
|
56 | ||
57 |
#' @keywords internal |
|
58 |
.ui_editor_block <- function(id, value, cached_html) { |
|
59 | ! |
UseMethod(".ui_editor_block", value) |
60 |
} |
|
61 | ||
62 |
#' @keywords internal |
|
63 |
.srv_editor_block <- function(id, value) { |
|
64 | ! |
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 | ! |
shiny::moduleServer(id, function(input, output, session) 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 | ! |
ns <- shiny::NS(id) |
95 | ! |
shiny::tagList( |
96 | ! |
shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"), |
97 | ! |
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 | ! |
shiny::moduleServer(id, function(input, output, session) shiny::reactive(input$content)) |
104 |
} |
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 |
#' |
|
40 |
#' @return `NULL`. |
|
41 |
NULL |
|
42 | ||
43 |
#' @rdname add_card_button |
|
44 |
#' @export |
|
45 |
add_card_button_ui <- function(id, label = NULL) { |
|
46 | 2x |
checkmate::assert_string(label, null.ok = TRUE) |
47 | 2x |
.outline_button( |
48 | 2x |
shiny::NS(id, "add_report_card_button"), |
49 | 2x |
icon = "plus-lg", |
50 | 2x |
label = label |
51 |
) |
|
52 |
} |
|
53 | ||
54 |
#' @rdname add_card_button |
|
55 |
#' @export |
|
56 |
add_card_button_srv <- function(id, reporter, card_fun) { |
|
57 | 15x |
checkmate::assert_function(card_fun) |
58 | 15x |
checkmate::assert_class(reporter, "Reporter") |
59 | 15x |
checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE) |
60 | ||
61 | 15x |
shiny::moduleServer(id, function(input, output, session) { |
62 | 15x |
shiny::setBookmarkExclude(c( |
63 | 15x |
"add_report_card_button", "download_button", "reset_reporter", |
64 | 15x |
"add_card_ok", "download_data", "reset_reporter_ok", |
65 | 15x |
"label", "comment" |
66 |
)) |
|
67 | ||
68 | 15x |
ns <- session$ns |
69 | ||
70 | 15x |
add_modal <- function() { |
71 | 12x |
shiny::div( |
72 | 12x |
class = "teal-reporter reporter-modal", |
73 | 12x |
.custom_css_dependency(), |
74 | 12x |
shiny::modalDialog( |
75 | 12x |
easyClose = TRUE, |
76 | 12x |
shiny::tags$h3("Add a Card to the Report"), |
77 | 12x |
shiny::tags$hr(), |
78 | 12x |
shiny::textInput( |
79 | 12x |
ns("label"), |
80 | 12x |
"Card Name", |
81 | 12x |
value = "", |
82 | 12x |
placeholder = "Add the card title here", |
83 | 12x |
width = "100%" |
84 |
), |
|
85 | 12x |
shiny::textAreaInput( |
86 | 12x |
ns("comment"), |
87 | 12x |
"Comment", |
88 | 12x |
value = "", |
89 | 12x |
placeholder = "Add a comment here...", |
90 | 12x |
width = "100%" |
91 |
), |
|
92 | 12x |
shiny::tags$script( |
93 | 12x |
shiny::HTML( |
94 | 12x |
sprintf("shinyjs.autoFocusModal('%s');", ns("label")), # See extendShinyJs.js |
95 | 12x |
sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("label"), ns("add_card_ok")) # See extendShinyJs.js |
96 |
) |
|
97 |
), |
|
98 | 12x |
footer = shiny::div( |
99 | 12x |
shiny::tags$button( |
100 | 12x |
type = "button", |
101 | 12x |
class = "btn btn-outline-secondary", |
102 | 12x |
`data-bs-dismiss` = "modal", |
103 | 12x |
NULL, |
104 | 12x |
"Dismiss" |
105 |
), |
|
106 | 12x |
shiny::tags$button( |
107 | 12x |
id = ns("add_card_ok"), |
108 | 12x |
type = "button", |
109 | 12x |
class = "btn btn-primary action-button", |
110 | 12x |
NULL, |
111 | 12x |
"Add Card" |
112 |
) |
|
113 |
) |
|
114 |
) |
|
115 |
) |
|
116 |
} |
|
117 | ||
118 | 15x |
shiny::observeEvent(input$add_report_card_button, { |
119 | 12x |
shiny::showModal(add_modal()) |
120 |
}) |
|
121 | ||
122 |
# the add card button is disabled when clicked to prevent multi-clicks |
|
123 |
# please check the ui part for more information |
|
124 | 15x |
shiny::observeEvent(input$add_card_ok, { |
125 | 12x |
card_fun_args_nams <- names(formals(card_fun)) |
126 | 12x |
has_card_arg <- "card" %in% card_fun_args_nams |
127 | 12x |
has_comment_arg <- "comment" %in% card_fun_args_nams |
128 | 12x |
has_label_arg <- "label" %in% card_fun_args_nams |
129 | ||
130 | 12x |
arg_list <- list() |
131 | ||
132 | 12x |
if (has_comment_arg) { |
133 | 4x |
arg_list <- c(arg_list, list(comment = input$comment)) |
134 |
} |
|
135 | 12x |
if (has_label_arg) { |
136 | ! |
arg_list <- c(arg_list, list(label = input$label)) |
137 |
} |
|
138 | ||
139 | 12x |
shinyjs::disable("add_card_ok") |
140 | ||
141 | 12x |
if (has_card_arg) { |
142 |
# The default_card is defined here because formals() returns a pairedlist object |
|
143 |
# of formal parameter names and their default values. The values are missing |
|
144 |
# if not defined and the missing check does not work if supplied formals(card_fun)[[1]] |
|
145 | 10x |
default_card <- formals(card_fun)$card |
146 | 10x |
card <- `if`( |
147 | 10x |
missing(default_card), |
148 | 10x |
ReportCard$new(), |
149 | 10x |
eval(default_card, envir = environment(card_fun)) |
150 |
) |
|
151 | 10x |
arg_list <- c(arg_list, list(card = card)) |
152 |
} |
|
153 | ||
154 | 12x |
card <- try(do.call(card_fun, arg_list)) |
155 | ||
156 | 12x |
if (inherits(card, "try-error")) { |
157 | 3x |
msg <- paste0( |
158 | 3x |
"The card could not be added to the report. ", |
159 | 3x |
"Have the outputs for the report been created yet? If not please try again when they ", |
160 | 3x |
"are ready. Otherwise contact your application developer" |
161 |
) |
|
162 | 3x |
warning(msg) |
163 | 3x |
shiny::showNotification( |
164 | 3x |
msg, |
165 | 3x |
type = "error" |
166 |
) |
|
167 | 3x |
shinyjs::enable("add_card_ok") |
168 |
} else { |
|
169 | 9x |
checkmate::assert_multi_class(card, c("ReportCard", "teal_card")) |
170 | 9x |
if (inherits(card, "ReportCard")) { |
171 | 8x |
if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { |
172 | 1x |
card$append_text("Comment", "header3") |
173 | 1x |
card$append_text(input$comment) |
174 |
} |
|
175 | ||
176 | 8x |
if (!has_label_arg && length(input$label) == 1 && input$label != "") { |
177 | ! |
card$set_name(input$label) |
178 |
} |
|
179 | 1x |
} else if (inherits(card, "teal_card")) { |
180 | 1x |
if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { |
181 | 1x |
card <- c(card, "### Comment", input$comment) |
182 |
} |
|
183 | 1x |
if (!has_label_arg && length(input$label) == 1 && input$label != "") { |
184 | ! |
metadata(card, "title") <- input$label |
185 |
} |
|
186 |
} |
|
187 | ||
188 | 9x |
reporter$append_cards(list(card)) |
189 | 9x |
shiny::showNotification(sprintf("The card added successfully."), type = "message") |
190 | 9x |
shiny::removeModal() |
191 |
} |
|
192 |
}) |
|
193 |
}) |
|
194 |
} |
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 | 38x |
args <- list(...) |
50 | ! |
if (is.null(teal_card)) teal_card <- teal_card() |
51 | 38x |
checkmate::assert_class(teal_card, "teal_card") |
52 | 38x |
checkmate::assert_list(args, names = "named") |
53 | 38x |
methods::callNextMethod( |
54 | 38x |
.Object, |
55 | 38x |
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 |
#' teal_report(x1 = iris, x2 = mtcars) |
|
78 |
teal_report <- function(..., |
|
79 |
teal_card = NULL, |
|
80 |
code = character(0), |
|
81 |
join_keys = teal.data::join_keys()) { |
|
82 | 32x |
if (is.null(teal_card)) teal_card <- teal_card() |
83 | 38x |
methods::new( |
84 | 38x |
"teal_report", |
85 | 38x |
.xData = list2env(list(...)), |
86 | 38x |
teal_card = teal_card, |
87 | 38x |
join_keys = join_keys, |
88 | 38x |
code = code |
89 |
) |
|
90 |
} |
|
91 | ||
92 |
#' Internal function to convert `qenv` or `teal_data` to `teal_report` |
|
93 |
#' @noRd |
|
94 |
coerce.teal_report <- function(from, to) { # nolint: object_name. |
|
95 | 3x |
if (inherits(from, "teal_report")) { |
96 | ! |
return(from) |
97 |
} |
|
98 | 3x |
new_x <- teal_report() |
99 | 3x |
for (slot_name in methods::slotNames(from)) { |
100 | 12x |
methods::slot(new_x, slot_name) <- methods::slot(from, slot_name) |
101 |
} |
|
102 | 3x |
teal_card(new_x) <- .code_to_card(from@code) |
103 | 3x |
new_x |
104 |
} |
|
105 | ||
106 |
methods::setAs("qenv", "teal_report", coerce.teal_report) |
|
107 |
methods::setAs("teal_data", "teal_report", coerce.teal_report) |
|
108 | ||
109 |
#' @rdname teal_report |
|
110 |
#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`. |
|
111 |
#' @export |
|
112 |
as.teal_report <- function(x) { # nolint: object_name. |
|
113 | 2x |
checkmate::assert_class(x, "qenv") |
114 | 2x |
methods::as(x, "teal_report") |
115 |
} |
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 | 2x |
checkmate::assert_string(label, null.ok = TRUE) |
21 | 2x |
.outline_button( |
22 | 2x |
shiny::NS(id, "reset_reporter"), |
23 | 2x |
label = label, |
24 | 2x |
icon = "x-lg", |
25 | 2x |
class = "danger" |
26 |
) |
|
27 |
} |
|
28 | ||
29 |
#' @rdname reset_report_button |
|
30 |
#' @export |
|
31 |
reset_report_button_srv <- function(id, reporter) { |
|
32 | 12x |
checkmate::assert_class(reporter, "Reporter") |
33 | ||
34 | 12x |
shiny::moduleServer(id, function(input, output, session) { |
35 | 12x |
shiny::setBookmarkExclude(c("reset_reporter")) |
36 | ||
37 | 12x |
shiny::observeEvent(reporter$get_cards(), { |
38 | 7x |
shinyjs::toggleClass( |
39 | 7x |
id = "reset_reporter", condition = length(reporter$get_cards()) == 0, class = "disabled" |
40 |
) |
|
41 |
}) |
|
42 | ||
43 | 12x |
shiny::observeEvent(input$reset_reporter, { |
44 | 2x |
shiny::tags$div( |
45 | 2x |
class = "teal-reporter reporter-modal", |
46 | 2x |
.custom_css_dependency(), |
47 | 2x |
shiny::showModal( |
48 | 2x |
shiny::modalDialog( |
49 | 2x |
easyClose = TRUE, |
50 | 2x |
shiny::tags$h3("Reset the Report"), |
51 | 2x |
shiny::tags$hr(), |
52 | 2x |
shiny::tags$strong( |
53 | 2x |
shiny::tags$p( |
54 | 2x |
"Are you sure you want to reset the report? (This will remove ALL previously added cards)." |
55 |
) |
|
56 |
), |
|
57 | 2x |
footer = shiny::tagList( |
58 | 2x |
shiny::tags$button( |
59 | 2x |
type = "button", |
60 | 2x |
class = "btn btn-outline-secondary", |
61 | 2x |
`data-bs-dismiss` = "modal", |
62 | 2x |
NULL, |
63 | 2x |
"Dismiss" |
64 |
), |
|
65 | 2x |
shiny::actionButton(session$ns("reset_reporter_ok"), "Reset", class = "btn btn-primary") |
66 |
) |
|
67 |
) |
|
68 |
) |
|
69 |
) |
|
70 |
}) |
|
71 | ||
72 | 12x |
shiny::observeEvent(reporter$get_cards(), { |
73 | 7x |
if (length(reporter$get_cards())) { |
74 | 5x |
shinyjs::enable("reset_reporter") |
75 |
} else { |
|
76 | 2x |
shinyjs::disable("reset_reporter") |
77 |
} |
|
78 |
}) |
|
79 | ||
80 | 12x |
shiny::observeEvent(input$reset_reporter_ok, { |
81 | 2x |
reporter$reset() |
82 | 2x |
shiny::removeModal() |
83 |
}) |
|
84 |
}) |
|
85 |
} |
1 |
#' Panel group widget |
|
2 |
#' |
|
3 |
#' |
|
4 |
#' @param title (`character`) title of panel |
|
5 |
#' @param ... content of panel |
|
6 |
#' @param collapsed (`logical`, optional) |
|
7 |
#' whether to initially collapse panel |
|
8 |
#' @param input_id (`character`, optional) |
|
9 |
#' name of the panel item element. If supplied, this will register a shiny input variable that |
|
10 |
#' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`. |
|
11 |
#' |
|
12 |
#' @return `shiny.tag`. |
|
13 |
#' |
|
14 |
#' @keywords internal |
|
15 |
panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) { |
|
16 | 1x |
stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html"))) |
17 | 1x |
checkmate::assert_flag(collapsed) |
18 | 1x |
checkmate::assert_string(input_id, null.ok = TRUE) |
19 | ||
20 | 1x |
div_id <- paste0(input_id, "_div") |
21 | 1x |
panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1)) |
22 | ||
23 | 1x |
shiny::tags$div(.renderHook = function(res_tag) { |
24 | ! |
res_tag$children <- list( |
25 | ! |
shiny::tags$div( |
26 | ! |
class = "card", |
27 | ! |
style = "margin: 0.5rem 0;", |
28 | ! |
shiny::tags$div( |
29 | ! |
class = "card-header", |
30 | ! |
shiny::tags$div( |
31 | ! |
class = ifelse(collapsed, "collapsed", ""), |
32 | ! |
`data-bs-toggle` = "collapse", # bs5 |
33 | ! |
href = paste0("#", panel_id), |
34 | ! |
`aria-expanded` = ifelse(collapsed, "false", "true"), |
35 | ! |
shiny::icon("angle-down", class = "dropdown-icon"), |
36 | ! |
shiny::tags$label(style = "display: inline;", title) |
37 |
) |
|
38 |
), |
|
39 | ! |
shiny::tags$div( |
40 | ! |
id = panel_id, |
41 | ! |
class = paste("collapse", ifelse(collapsed, "", "show")), |
42 | ! |
shiny::tags$div(class = "card-body", ...) |
43 |
) |
|
44 |
) |
|
45 |
) |
|
46 | ||
47 | ! |
res_tag |
48 |
}) |
|
49 |
} |
|
50 | ||
51 |
#' Convert content into a `flextable` |
|
52 |
#' |
|
53 |
#' Converts supported table formats into a `flextable` for enhanced formatting and presentation. |
|
54 |
#' |
|
55 |
#' Function merges cells with `colspan` > 1, |
|
56 |
#' aligns columns to the center and row names to the left, |
|
57 |
#' indents the row names by 10 times indentation. |
|
58 |
#' |
|
59 |
#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df` |
|
60 |
#' |
|
61 |
#' @return `flextable`. |
|
62 |
#' |
|
63 |
#' @keywords internal |
|
64 |
to_flextable <- function(content) { |
|
65 | 86x |
if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) { |
66 | 42x |
ft <- rtables.officer::tt_to_flextable(content) |
67 | 44x |
} else if (inherits(content, "listing_df")) { |
68 | 1x |
mf <- rlistings::matrix_form(content) |
69 | 1x |
nr_header <- attr(mf, "nrow_header") |
70 | 1x |
df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE]) |
71 | 1x |
header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE]) |
72 | ||
73 | 1x |
ft <- rtables::df_to_tt(df) |
74 | 1x |
if (length(mf$main_title) != 0) { |
75 | ! |
rtables::main_title(ft) <- mf$main_title |
76 |
} |
|
77 | 1x |
rtables::subtitles(ft) <- mf$subtitles |
78 | 1x |
rtables::main_footer(ft) <- mf$main_footer |
79 | 1x |
rtables::prov_footer(ft) <- mf$prov_footer |
80 | 1x |
rtables::header_section_div(ft) <- mf$header_section_div |
81 | 1x |
ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1)) |
82 | 43x |
} else if (inherits(content, "data.frame")) { |
83 | 42x |
ft <- if (nrow(content) == 0) { |
84 | ! |
flextable::flextable(content) |
85 |
} else { |
|
86 | 42x |
rtables.officer::tt_to_flextable( |
87 | 42x |
rtables::df_to_tt(content) |
88 |
) |
|
89 |
} |
|
90 |
} else { |
|
91 | 1x |
stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table")) |
92 |
} |
|
93 | ||
94 | 85x |
ft |
95 |
} |
|
96 | ||
97 |
#' Get the merge index for a single span. |
|
98 |
#' This function retrieves the merge index for a single span, |
|
99 |
#' which is used in merging cells. |
|
100 |
#' @noRd |
|
101 |
#' @keywords internal |
|
102 |
get_merge_index_single <- function(span) { |
|
103 | ! |
ret <- list() |
104 | ! |
j <- 1 |
105 | ! |
while (j < length(span)) { |
106 | ! |
if (span[j] != 1) { |
107 | ! |
ret <- c(ret, list(seq(j, j + span[j] - 1))) |
108 |
} |
|
109 | ! |
j <- j + span[j] |
110 |
} |
|
111 | ! |
ret |
112 |
} |
|
113 | ||
114 |
#' Divide text block into smaller blocks |
|
115 |
#' |
|
116 |
#' Split a text block into smaller blocks with a specified number of lines. |
|
117 |
#' |
|
118 |
#' A single character string containing a text block of multiple lines (separated by `\n`) |
|
119 |
#' is split into multiple strings with n or less lines each. |
|
120 |
#' |
|
121 |
#' @param x (`character`) string containing the input block of text |
|
122 |
#' @param n (`integer`) number of lines per block |
|
123 |
#' |
|
124 |
#' @return |
|
125 |
#' List of character strings with up to `n` lines in each element. |
|
126 |
#' |
|
127 |
#' @keywords internal |
|
128 |
split_text_block <- function(x, n) { |
|
129 | 2x |
checkmate::assert_string(x) |
130 | 2x |
checkmate::assert_integerish(n, lower = 1L, len = 1L) |
131 | ||
132 | 2x |
lines <- strsplit(x, "\n")[[1]] |
133 | ||
134 | 2x |
if (length(lines) <= n) { |
135 | 1x |
return(list(x)) |
136 |
} |
|
137 | ||
138 | 1x |
nblocks <- ceiling(length(lines) / n) |
139 | 1x |
ind <- rep(1:nblocks, each = n)[seq_along(lines)] |
140 | 1x |
unname(lapply(split(lines, ind), paste, collapse = "\n")) |
141 |
} |
|
142 | ||
143 |
#' Retrieve text details for global_knitr options |
|
144 |
#' This function returns a character string describing the default settings for the global_knitr options. |
|
145 |
#' @noRd |
|
146 |
#' @keywords internal |
|
147 |
global_knitr_details <- function() { |
|
148 | ! |
paste0( |
149 | ! |
c( |
150 | ! |
" To access the default values for the `global_knitr` parameter,", |
151 | ! |
" use `getOption('teal.reporter.global_knitr')`. These defaults include:", |
152 | ! |
" - `echo = TRUE`", |
153 | ! |
" - `tidy.opts = list(width.cutoff = 60)`", |
154 | ! |
" - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise" |
155 |
), |
|
156 | ! |
collapse = "\n" |
157 |
) |
|
158 |
} |
|
159 | ||
160 |
#' @export |
|
161 |
#' @keywords internal |
|
162 |
format.code_chunk <- function(x, ...) { |
|
163 | 108x |
language <- attr(x, "lang", exact = TRUE) |
164 | 108x |
params <- attr(x, "params", exact = TRUE) |
165 | 108x |
if (language %in% names(knitr::knit_engines$get())) { |
166 | 107x |
sprintf( |
167 | 107x |
"```{%s}\n%s\n```", |
168 | 107x |
toString(c(language, paste(names(params), params, sep = "="))), |
169 | 107x |
NextMethod() |
170 |
) |
|
171 |
} else { |
|
172 | 1x |
sprintf("```%s\n%s\n```", language, NextMethod()) |
173 |
} |
|
174 |
} |
|
175 | ||
176 |
#' @keywords internal |
|
177 |
.outline_button <- function(id, label, icon = NULL, class = "primary") { |
|
178 | 10x |
shiny::tagList( |
179 | 10x |
shinyjs::useShinyjs(), |
180 | 10x |
.custom_css_dependency(), |
181 | 10x |
htmltools::htmlDependency( |
182 | 10x |
name = "teal-reporter-busy-disable", |
183 | 10x |
version = utils::packageVersion("teal.reporter"), |
184 | 10x |
package = "teal.reporter", |
185 | 10x |
src = "js", |
186 | 10x |
script = "busy-disable.js" |
187 |
), |
|
188 | 10x |
shiny::tags$button( |
189 | 10x |
id = id, |
190 | 10x |
class = sprintf("teal-reporter action-button teal-reporter-busy-disable outline-button %s", class), |
191 | 10x |
role = "button", |
192 | 10x |
style = "text-decoration: none;", |
193 | 10x |
if (!is.null(icon)) { |
194 | 10x |
margin_style <- ifelse(is.null(label), "margin: 0 10px 0 10px;", "") |
195 | 10x |
shiny::tags$span( |
196 | 10x |
style = margin_style, |
197 | 10x |
bsicons::bs_icon(icon, class = sprintf("text-%s", class)) |
198 |
) |
|
199 |
}, |
|
200 | 10x |
label |
201 |
) |
|
202 |
) |
|
203 |
} |
|
204 | ||
205 |
#' @keywords internal |
|
206 |
.custom_css_dependency <- function() { |
|
207 | 30x |
htmltools::htmlDependency( |
208 | 30x |
name = "teal-reporter", |
209 | 30x |
version = utils::packageVersion("teal.reporter"), |
210 | 30x |
package = "teal.reporter", |
211 | 30x |
src = "css", |
212 | 30x |
stylesheet = "custom.css" |
213 |
) |
|
214 |
} |
|
215 | ||
216 |
#' @noRd |
|
217 |
dummy <- function() { |
|
218 | ! |
R6::R6Class # Used to trick R CMD check for avoiding NOTE about R6 |
219 | ! |
jsonlite::fromJSON # Used to trick R CMD check for not detecting jsonlite usage |
220 |
} |
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 | ! |
.outline_button( |
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 |
) |
|
31 |
) |
|
32 |
} |
|
33 | ||
34 |
#' @rdname reporter_previewer |
|
35 |
#' @export |
|
36 |
preview_report_button_srv <- function(id, reporter) { |
|
37 | ! |
checkmate::assert_class(reporter, "Reporter") |
38 | ||
39 | ! |
shiny::moduleServer(id, function(input, output, session) { |
40 | ! |
shiny::setBookmarkExclude(c("preview_button")) |
41 | ||
42 | ! |
shiny::observeEvent(reporter$get_cards(), { |
43 | ! |
shinyjs::toggleClass( |
44 | ! |
id = "preview_button", condition = length(reporter$get_cards()) == 0, class = "disabled" |
45 |
) |
|
46 |
}) |
|
47 | ||
48 | ! |
output$preview_button_counter <- shiny::renderUI({ |
49 | ! |
shiny::tags$span( |
50 | ! |
class = "position-absolute badge rounded-pill bg-primary", |
51 | ! |
length(reporter$get_cards()) |
52 |
) |
|
53 |
}) |
|
54 | ||
55 | ! |
preview_modal <- function(cached_content) { |
56 | ! |
shiny::tags$div( |
57 | ! |
class = "teal-reporter reporter-previewer-modal", |
58 | ! |
.custom_css_dependency(), |
59 | ! |
shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")), |
60 | ! |
shiny::modalDialog( |
61 | ! |
easyClose = TRUE, |
62 | ! |
size = "xl", |
63 | ! |
title = "Report Preview", |
64 | ! |
reporter_previewer_content_ui(session$ns("preview_content")), |
65 | ! |
footer = shiny::tagList( |
66 | ! |
shiny::tags$button( |
67 | ! |
type = "button", |
68 | ! |
class = "btn btn-outline-secondary", |
69 | ! |
"data-bs-dismiss" = "modal", |
70 | ! |
"Dismiss" |
71 |
) |
|
72 |
) |
|
73 |
) |
|
74 |
) |
|
75 |
} |
|
76 | ||
77 | ! |
reporter_previewer_content_srv(id = "preview_content", reporter = reporter) |
78 | ||
79 | ! |
srv_list <- shiny::reactiveValues() |
80 | ||
81 | ! |
shiny::observeEvent( |
82 | ! |
list(input$preview_button, reporter$open_previewer()), |
83 | ! |
ignoreInit = TRUE, |
84 |
{ |
|
85 | ! |
shiny::showModal(preview_modal()) |
86 | ||
87 | ! |
panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards")) |
88 | ! |
lapply( |
89 | ! |
names(reporter$get_cards()), |
90 | ! |
function(card_id) { |
91 |
# Only show loading placeholder for cards that are being initialized for the first time |
|
92 | ! |
first_run <- is.null(srv_list[[card_id]]) |
93 | ||
94 | ! |
bslib::accordion_panel_insert( |
95 | ! |
id = panel_ns(NULL), |
96 | ! |
previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id, show_loading = first_run) |
97 |
) |
|
98 | ||
99 | ! |
if (first_run) { # Only initialize srv once per card_id |
100 | ! |
previewer_card_srv( |
101 | ! |
id = panel_ns(card_id), |
102 | ! |
card_r = shiny::reactive(reporter$get_cards()[[card_id]]), |
103 | ! |
card_id = card_id, |
104 | ! |
reporter = reporter |
105 |
) |
|
106 | ! |
srv_list[[card_id]] <- card_id |
107 |
} |
|
108 |
} |
|
109 |
) |
|
110 |
} |
|
111 |
) |
|
112 |
}) |
|
113 |
} |
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 | 1x |
ns <- shiny::NS(id) |
39 | 1x |
lifecycle::deprecate_soft( |
40 | 1x |
when = "0.5.0", |
41 | 1x |
what = "reporter_previewer_ui()", |
42 | 1x |
details = paste( |
43 | 1x |
"Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n", |
44 | 1x |
"Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,", |
45 | 1x |
"and `preview_report_button_ui()` instead." |
46 |
) |
|
47 |
) |
|
48 | 1x |
bslib::page_fluid( |
49 | 1x |
shiny::tagList( |
50 | 1x |
shinyjs::useShinyjs(), |
51 | 1x |
shiny::singleton( |
52 | 1x |
shiny::tags$head( |
53 | 1x |
shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")), |
54 | 1x |
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 | 1x |
shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")), |
60 | 1x |
shiny::tags$div( |
61 | 1x |
class = "well", |
62 | 1x |
style = "display: inline-flex; flex-direction: row; gap: 10px;", |
63 | 1x |
shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")), |
64 | 1x |
shiny::tags$span( |
65 | 1x |
id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report") |
66 |
), |
|
67 | 1x |
shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report")) |
68 |
), |
|
69 | 1x |
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 |
.onLoad <- function(libname, pkgname) { |
|
2 | ! |
op <- options() |
3 | ||
4 | ! |
teal_reporter_default_options <- list( |
5 | ! |
teal.reporter.global_knitr = list( |
6 | ! |
echo = TRUE, |
7 | ! |
tidy.opts = list(width.cutoff = 60), |
8 | ! |
tidy = requireNamespace("formatR", quietly = TRUE) |
9 |
), |
|
10 | ! |
teal.reporter.devices.dev.width = 800, |
11 | ! |
teal.reporter.devices.dev.height = 600, |
12 | ! |
teal.reporter.rmd_output = c( |
13 | ! |
"html" = "html_document", "pdf" = "pdf_document", |
14 | ! |
"powerpoint" = "powerpoint_presentation", |
15 | ! |
"word" = "word_document" |
16 |
), |
|
17 | ! |
teal.reporter.rmd_yaml_args = list( |
18 | ! |
author = "NEST", title = "Report", |
19 | ! |
date = as.character(Sys.Date()), output = "html_document", |
20 | ! |
toc = FALSE |
21 |
) |
|
22 |
) |
|
23 | ||
24 | ! |
toset <- !(names(teal_reporter_default_options) %in% names(op)) |
25 | ! |
if (any(toset)) options(teal_reporter_default_options[toset]) |
26 | ||
27 |
# Manual import instead of using backports and adding 1 more dependency |
|
28 | ! |
if (getRversion() < "4.4") { |
29 | ! |
assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname)) |
30 |
} |
|
31 | ||
32 | ! |
invisible() |
33 |
} |
|
34 | ||
35 |
.onAttach <- function(libname, pkgname) { |
|
36 | 2x |
if (!requireNamespace("formatR", quietly = TRUE)) { |
37 | ! |
packageStartupMessage( |
38 | ! |
"For better code formatting, consider installing the formatR package." |
39 |
) |
|
40 |
} |
|
41 |
} |
1 |
# reporter_previewer_content -------------------------------------------------------------------------------------- |
|
2 | ||
3 |
#' @keywords internal |
|
4 |
reporter_previewer_content_ui <- function(id, cached_content = rlang::list2()) { |
|
5 | 1x |
ns <- shiny::NS(id) |
6 | 1x |
shiny::tags$div( |
7 | 1x |
.custom_css_dependency(), |
8 | 1x |
bslib::accordion( |
9 | 1x |
id = ns("reporter_cards"), |
10 | 1x |
class = "teal-reporter report-previewer-accordion", |
11 | 1x |
!!!cached_content |
12 |
), |
|
13 | 1x |
sortable::sortable_js( |
14 | 1x |
css_id = ns("reporter_cards"), |
15 | 1x |
options = sortable::sortable_options( |
16 | 1x |
onSort = sortable::sortable_js_capture_input(ns("reporter_cards_order")), |
17 | 1x |
handle = ".accordion-icon" |
18 |
) |
|
19 |
) |
|
20 |
) |
|
21 |
} |
|
22 | ||
23 |
#' @keywords internal |
|
24 |
reporter_previewer_content_srv <- function(id, reporter) { |
|
25 | 7x |
shiny::moduleServer(id, function(input, output, session) { |
26 | 7x |
shiny::setBookmarkExclude("card_remove_id") |
27 | ||
28 | 7x |
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 | 7x |
shiny::exportTestValues(cards = reporter$get_cards()) |
37 | 7x |
current_ids_rv <- shiny::reactiveVal() |
38 | 7x |
queues_rv <- list(insert = shiny::reactiveVal(), remove = shiny::reactiveVal()) |
39 | ||
40 | 7x |
shiny::observeEvent(reporter$get_cards(), { |
41 | 2x |
all_cards <- reporter$get_cards() |
42 | 2x |
reporter_ids <- names(all_cards) |
43 | 2x |
current_ids <- current_ids_rv() |
44 | ||
45 | 2x |
to_add <- !reporter_ids %in% current_ids |
46 | 2x |
to_remove <- !current_ids %in% reporter_ids |
47 | 2x |
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 | 2x |
shinyjs::toggle("empty_reporters", condition = length(all_cards) == 0L) |
51 |
}) |
|
52 | ||
53 | 7x |
shiny::observeEvent(queues_rv$insert(), { |
54 | 2x |
lapply(queues_rv$insert(), function(card_id) { |
55 | 2x |
current_ids_rv(c(current_ids_rv(), card_id)) |
56 |
}) |
|
57 |
}) |
|
58 | ||
59 | 7x |
shiny::observeEvent(queues_rv$remove(), { |
60 | ! |
lapply(queues_rv$remove(), bslib::accordion_panel_remove, id = "reporter_cards") |
61 |
}) |
|
62 | ||
63 | 7x |
shiny::observeEvent(input$card_remove_id, { |
64 | ! |
reporter$remove_cards(ids = input$card_remove_id) |
65 |
}) |
|
66 | ||
67 | 7x |
shiny::observeEvent(input$reporter_cards_order, { |
68 | ! |
reporter$reorder_cards(input$reporter_cards_order) |
69 |
}) |
|
70 |
}) |
|
71 |
} |
1 |
#' @title `ReportCard`: An `R6` class for building report elements |
|
2 |
#' @docType class |
|
3 |
#' |
|
4 |
#' @description |
|
5 |
#' |
|
6 |
#' This `R6` class that supports creating a report card containing text, plot, table and |
|
7 |
#' metadata blocks that can be appended and rendered to form a report output from a `shiny` app. |
|
8 |
#' |
|
9 |
#' For more information about the various blocks, refer to the vignette: |
|
10 |
#' `vignette("teal-reporter-blocks-overview", "teal.reporter")`. |
|
11 |
#' |
|
12 |
#' @export |
|
13 |
#' |
|
14 |
ReportCard <- R6::R6Class( # nolint: object_name_linter. |
|
15 |
classname = "ReportCard", |
|
16 |
public = list( |
|
17 |
#' @description Initialize a `ReportCard` object. |
|
18 |
#' |
|
19 |
#' @return Object of class `ReportCard`, invisibly. |
|
20 |
#' @examples |
|
21 |
#' card <- ReportCard$new() |
|
22 |
#' |
|
23 |
initialize = function() { |
|
24 | 69x |
private$content <- teal_card() |
25 | 69x |
invisible(self) |
26 |
}, |
|
27 |
#' @description Appends a table to this `ReportCard`. |
|
28 |
#' |
|
29 |
#' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) |
|
30 |
#' that can be coerced into a table. |
|
31 |
#' @return `self`, invisibly. |
|
32 |
#' @examples |
|
33 |
#' card <- ReportCard$new()$append_table(iris) |
|
34 |
#' |
|
35 | 8x |
append_table = function(table) self$append_content(table), |
36 |
#' @description Appends a html content to this `ReportCard`. |
|
37 |
#' |
|
38 |
#' @param content An object that can be rendered as a HTML content. |
|
39 |
#' @return `self`, invisibly. |
|
40 |
#' @examples |
|
41 |
#' card <- ReportCard$new()$append_html(shiny::div("HTML Content")) |
|
42 |
#' |
|
43 | ! |
append_html = function(content) self$append_content(content), |
44 |
#' @description Appends a plot to this `ReportCard`. |
|
45 |
#' |
|
46 |
#' @param plot (`ggplot` or `grob` or `trellis`) plot object. |
|
47 |
#' @param dim (`numeric(2)`) width and height in pixels. |
|
48 |
#' @return `self`, invisibly. |
|
49 |
#' @examplesIf require("ggplot2") |
|
50 |
#' library(ggplot2) |
|
51 |
#' |
|
52 |
#' card <- ReportCard$new()$append_plot( |
|
53 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
54 |
#' ) |
|
55 |
#' |
|
56 |
append_plot = function(plot, dim = NULL) { |
|
57 | 21x |
checkmate::assert_numeric(dim, len = 2, any.missing = FALSE, null.ok = TRUE) |
58 | 21x |
if (!is.null(dim)) { |
59 | 1x |
if (!inherits(plot, "chunk_output")) { |
60 | 1x |
plot <- structure(list(plot), class = c("chunk_output")) |
61 |
} |
|
62 | 1x |
attr(plot, "dev.width") <- dim[1] |
63 | 1x |
attr(plot, "dev.height") <- dim[2] |
64 |
} |
|
65 | 21x |
self$append_content(plot) |
66 |
}, |
|
67 |
#' @description Appends a text paragraph to this `ReportCard`. |
|
68 |
#' |
|
69 |
#' @param text (`character`) The text content to add. |
|
70 |
#' @param style (`character(1)`) the style of the paragraph. |
|
71 |
#' @return `self`, invisibly. |
|
72 |
#' @examples |
|
73 |
#' card <- ReportCard$new()$append_text("A paragraph of default text") |
|
74 |
#' |
|
75 |
append_text = function(text, style = c("default", "header2", "header3", "verbatim")) { |
|
76 | 60x |
styled <- switch(match.arg(style), |
77 | 60x |
"default" = text, |
78 | 60x |
"verbatim" = sprintf("\n```\n%s\n```\n", text), |
79 | 60x |
"header2" = paste0("## ", text), |
80 | 60x |
"header3" = paste0("### ", text), |
81 | 60x |
text |
82 |
) |
|
83 | 60x |
self$append_content(styled) |
84 |
}, |
|
85 |
#' @description Appends an `R` code chunk to `ReportCard`. |
|
86 |
#' |
|
87 |
#' @param text (`character`) The `R` code to include. |
|
88 |
#' @param ... Additional `rmarkdown` parameters for formatting the `R` code chunk. |
|
89 |
#' @return `self`, invisibly. |
|
90 |
#' @examples |
|
91 |
#' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE) |
|
92 |
#' |
|
93 |
append_rcode = function(text, ...) { |
|
94 | 3x |
self$append_content(code_chunk(code = text, ...)) |
95 |
}, |
|
96 |
#' @description Appends a generic content to this `ReportCard`. |
|
97 |
#' |
|
98 |
#' @param content (Object.) |
|
99 |
#' @return `self`, invisibly. |
|
100 |
#' @examples |
|
101 |
#' card <- ReportCard$new()$append_content(code_chunk("foo <- 2")) |
|
102 |
#' |
|
103 |
append_content = function(content) { |
|
104 | 92x |
private$content <- c(private$content, content) |
105 | 92x |
invisible(self) |
106 |
}, |
|
107 |
#' @description Get all content blocks from this `ReportCard`. |
|
108 |
#' |
|
109 |
#' @return `teal_card()` containing appended elements. |
|
110 |
#' @examples |
|
111 |
#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2") |
|
112 |
#' |
|
113 |
#' card$get_content() |
|
114 |
#' |
|
115 |
#' |
|
116 | 46x |
get_content = function() private$content, |
117 |
#' @description Clears all content and metadata from `ReportCard`. |
|
118 |
#' |
|
119 |
#' @return `self`, invisibly. |
|
120 |
#' |
|
121 |
reset = function() { |
|
122 | ! |
private$content <- teal_card() |
123 | ! |
invisible(self) |
124 |
}, |
|
125 |
#' @description Get the metadata associated with `ReportCard`. |
|
126 |
#' |
|
127 |
#' @return `named list` list of elements. |
|
128 |
#' @examples |
|
129 |
#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2") |
|
130 |
#' |
|
131 |
#' card$get_metadata() |
|
132 |
#' |
|
133 |
get_metadata = function() { |
|
134 | 4x |
metadata(private$content) |
135 |
}, |
|
136 |
#' @description Appends metadata to this `ReportCard`. |
|
137 |
#' |
|
138 |
#' @param key (`character(1)`) string specifying the metadata key. |
|
139 |
#' @param value value associated with the metadata key. |
|
140 |
#' @return `self`, invisibly. |
|
141 |
#' @examplesIf require("ggplot2") |
|
142 |
#' library(ggplot2) |
|
143 |
#' |
|
144 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
145 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
146 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
147 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
148 |
#' card$get_content() |
|
149 |
#' card$get_metadata() |
|
150 |
#' |
|
151 |
append_metadata = function(key, value) { |
|
152 | 16x |
checkmate::assert_character(key, min.len = 0, max.len = 1) |
153 | 13x |
checkmate::assert_false(key %in% names(metadata(private$content))) |
154 | 12x |
metadata(private$content, key) <- value |
155 | 11x |
invisible(self) |
156 |
}, |
|
157 |
#' @description Get the name of the `ReportCard`. |
|
158 |
#' |
|
159 |
#' @return `character` a card name. |
|
160 |
#' @examples |
|
161 |
#' ReportCard$new()$set_name("NAME")$get_name() |
|
162 |
get_name = function() { |
|
163 | 9x |
metadata(private$content, "title") %||% character(0L) |
164 |
}, |
|
165 |
#' @description Set the name of the `ReportCard`. |
|
166 |
#' |
|
167 |
#' @param name (`character(1)`) a card name. |
|
168 |
#' @return `self`, invisibly. |
|
169 |
#' @examples |
|
170 |
#' ReportCard$new()$set_name("NAME")$get_name() |
|
171 |
set_name = function(name) { |
|
172 | 17x |
metadata(private$content, "title") <- name |
173 | 17x |
invisible(self) |
174 |
}, |
|
175 |
#' @description Set content block names for compatibility with newer `teal_card` |
|
176 |
#' @param new_names (`character`) vector of new names. |
|
177 |
set_content_names = function(new_names) { |
|
178 | ! |
names(private$content) <- new_names |
179 |
}, |
|
180 |
#' @description Convert the `ReportCard` to a list, including content and metadata. |
|
181 |
#' @param output_dir (`character`) with a path to the directory where files will be copied. |
|
182 |
#' @return (`named list`) a `ReportCard` representation. |
|
183 |
#' @examplesIf require("ggplot2") |
|
184 |
#' library(ggplot2) |
|
185 |
#' |
|
186 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
187 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
188 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
189 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
190 |
#' card$get_content() |
|
191 |
#' |
|
192 |
#' card$to_list(tempdir()) |
|
193 |
#' |
|
194 |
to_list = function(output_dir = lifecycle::deprecated()) { |
|
195 | ! |
if (lifecycle::is_present(output_dir)) { |
196 | ! |
lifecycle::deprecate_soft("0.5.0.9000", "ReportCard$to_list(output_dir)") |
197 |
} |
|
198 | ! |
private$content |
199 |
}, |
|
200 |
#' @description Reconstructs the `ReportCard` from a list representation. |
|
201 |
#' @param card (`named list`) a `ReportCard` representation. |
|
202 |
#' @param output_dir (`character`) with a path to the directory where a file will be copied. |
|
203 |
#' @return `self`, invisibly. |
|
204 |
#' @examplesIf require("ggplot2") |
|
205 |
#' library(ggplot2) |
|
206 |
#' |
|
207 |
#' card <- ReportCard$new()$append_text("Some text")$append_plot( |
|
208 |
#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() |
|
209 |
#' )$append_text("Some text")$append_metadata(key = "lm", |
|
210 |
#' value = lm(Ozone ~ Solar.R, airquality)) |
|
211 |
#' card$get_content() |
|
212 |
#' |
|
213 |
#' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir()) |
|
214 |
#' |
|
215 |
from_list = function(card, output_dir = lifecycle::deprecated()) { |
|
216 | ! |
if (lifecycle::is_present(output_dir)) { |
217 | ! |
lifecycle::deprecate_soft("0.5.0.9000", "ReportCard$to_list(output_dir)") |
218 |
} |
|
219 | ! |
self$reset() |
220 | ! |
private$content <- card |
221 | ! |
invisible(self) |
222 |
} |
|
223 |
), |
|
224 |
private = list( |
|
225 |
content = list(), |
|
226 |
name = character(0L), |
|
227 |
id = character(0L), |
|
228 |
# @description The copy constructor. |
|
229 |
# |
|
230 |
# @param name the name of the field |
|
231 |
# @param value the value of the field |
|
232 |
# @return the new value of the field |
|
233 |
# |
|
234 |
deep_clone = function(name, value) { |
|
235 | 42x |
if (name == "content") { |
236 | 2x |
content <- Reduce( |
237 | 2x |
f = function(result, this) { |
238 | 4x |
if (inherits(this, "R6")) { |
239 | ! |
this <- this$clone(deep = TRUE) |
240 |
} |
|
241 | 4x |
c(result, this) |
242 |
}, |
|
243 | 2x |
init = teal_card(), |
244 | 2x |
x = value |
245 |
) |
|
246 | ||
247 | 2x |
metadata(content) <- metadata(value) |
248 | 2x |
content |
249 |
} else { |
|
250 | 40x |
value |
251 |
} |
|
252 |
} |
|
253 |
), |
|
254 |
lock_objects = TRUE, |
|
255 |
lock_class = TRUE |
|
256 |
) |
|
257 | ||
258 |
#' @export |
|
259 |
length.ReportCard <- function(x) { |
|
260 | 1x |
length(x$get_content()) |
261 |
} |
1 |
#' Concatenate `teal_report` objects |
|
2 |
#' |
|
3 |
#' @param ... (`teal_report`) objects to concatenate |
|
4 |
#' |
|
5 |
#' @return A [`teal_report`] object with combined [`teal_card`] elements. |
|
6 |
#' |
|
7 |
#' @export |
|
8 |
#' @method c teal_report |
|
9 |
c.teal_report <- function(...) { |
|
10 | 42x |
result <- NextMethod() |
11 | 42x |
l <- Filter(function(x) inherits(x, "teal_report"), list(...)) |
12 | 42x |
if (length(l) > 1) { |
13 | 4x |
teal_card(result) <- do.call(c, lapply(l, function(x) teal_card(x))) |
14 |
} |
|
15 | 42x |
result |
16 |
} |
1 |
#' @export |
|
2 |
`[.teal_report` <- function(x, names) { |
|
3 | ! |
x <- NextMethod("`[`", x) # unverified doesn't need warning for code inconsistency |
4 | ! |
x@teal_card <- x@teal_card # todo: https://github.com/insightsengineering/teal.reporter/issues/394 |
5 | ! |
x |
6 |
} |
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 | 20x |
new_object <- methods::callNextMethod(object = object, code = code, ...) |
26 | 20x |
if (inherits(new_object, "error")) { |
27 | ! |
return(new_object) |
28 |
} |
|
29 | 20x |
new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts) |
30 | ||
31 | 20x |
teal_card(new_object) <- c(teal_card(new_object), new_blocks) |
32 | 20x |
new_object |
33 |
} |
|
34 |
) |
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 (`function`) which returns a [`ReportCard`] instance, |
|
18 |
#' the function has a `teal_card` argument and an optional `comment` argument. |
|
19 |
#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process. |
|
20 |
#' @inheritParams reporter_download_inputs |
|
21 |
#' |
|
22 |
#' @return `NULL`. |
|
23 |
#' |
|
24 |
#' @examples |
|
25 |
#' if (interactive()) { |
|
26 |
#' library(shiny) |
|
27 |
#' |
|
28 |
#' shinyApp( |
|
29 |
#' ui = fluidPage(simple_reporter_ui("simple")), |
|
30 |
#' server = function(input, output, session) { |
|
31 |
#' simple_reporter_srv("simple", Reporter$new(), function(card) card) |
|
32 |
#' } |
|
33 |
#' ) |
|
34 |
#' } |
|
35 |
NULL |
|
36 | ||
37 |
#' @rdname simple_reporter |
|
38 |
#' @export |
|
39 |
simple_reporter_ui <- function(id) { |
|
40 | 1x |
ns <- shiny::NS(id) |
41 | 1x |
shiny::tagList( |
42 | 1x |
.custom_css_dependency(), |
43 | 1x |
shiny::tags$div( |
44 | 1x |
shiny::tags$label(class = "text-primary", shiny::tags$strong("Reporter")), |
45 | 1x |
shiny::tags$div( |
46 | 1x |
class = "simple_reporter_container", |
47 | 1x |
add_card_button_ui(ns("add_report_card_simple")), |
48 | 1x |
download_report_button_ui(ns("download_button_simple")), |
49 | 1x |
report_load_ui(ns("archive_load_simple")), |
50 | 1x |
reset_report_button_ui(ns("reset_button_simple")) |
51 |
), |
|
52 | 1x |
shiny::tags$br() |
53 |
) |
|
54 |
) |
|
55 |
} |
|
56 | ||
57 |
#' @rdname simple_reporter |
|
58 |
#' @export |
|
59 |
simple_reporter_srv <- function( |
|
60 |
id, |
|
61 |
reporter, |
|
62 |
card_fun, |
|
63 |
global_knitr = getOption("teal.reporter.global_knitr"), |
|
64 |
rmd_output = c( |
|
65 |
"html" = "html_document", "pdf" = "pdf_document", |
|
66 |
"powerpoint" = "powerpoint_presentation", "word" = "word_document" |
|
67 |
), |
|
68 |
rmd_yaml_args = list( |
|
69 |
author = "NEST", title = "Report", |
|
70 |
date = as.character(Sys.Date()), output = "html_document", |
|
71 |
toc = FALSE |
|
72 |
)) { |
|
73 | 5x |
shiny::moduleServer( |
74 | 5x |
id, |
75 | 5x |
function(input, output, session) { |
76 | 5x |
add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun) |
77 | 5x |
download_report_button_srv( |
78 | 5x |
"download_button_simple", |
79 | 5x |
reporter = reporter, |
80 | 5x |
global_knitr = global_knitr, |
81 | 5x |
rmd_output = rmd_output, |
82 | 5x |
rmd_yaml_args = rmd_yaml_args |
83 |
) |
|
84 | 5x |
report_load_srv("archive_load_simple", reporter = reporter) |
85 | 5x |
reset_report_button_srv("reset_button_simple", reporter = reporter) |
86 |
} |
|
87 |
) |
|
88 |
} |