- | 377 |
+ 393 |
|
}
@@ -2756,98 +2868,98 @@ teal.reporter coverage - 82.57%
-
+
| 1 |
|
- #' @title `Renderer`
+ #' @title `Reporter`: An `R6` class for managing report cards
|
| 2 |
|
- #' @keywords internal
+ #' @docType class
|
| 3 |
|
- Renderer <- R6::R6Class( # nolint: object_name_linter.
+ #' @description `r lifecycle::badge("experimental")`
|
| 4 |
|
- classname = "Renderer",
+ #'
|
| 5 |
|
- public = list(
+ #' This `R6` class is designed to store and manage report cards,
|
| 6 |
|
- #' @description Returns a `Renderer` object.
+ #' facilitating the creation, manipulation, and serialization of report-related data.
|
| 7 |
|
- #'
+ #'
|
| 8 |
|
- #' @details Returns a `Renderer` object.
+ #' @export
|
| 9 |
|
- #'
+ #'
|
| 10 |
|
- #' @return `Renderer` object.
+ Reporter <- R6::R6Class( # nolint: object_name_linter.
|
| 11 |
|
- #' @examples
+ classname = "Reporter",
|
| 12 |
|
- #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
+ public = list(
|
| 13 |
|
- #' Renderer$new()
+ #' @description Initialize a `Reporter` object.
|
@@ -2861,126 +2973,126 @@ teal.reporter coverage - 82.57%
15 |
|
- initialize = function() {
+ #' @return Object of class `Reporter`, invisibly.
|
-
+
| 16 |
- 10x |
+ |
- tmp_dir <- tempdir()
+ #' @examples
|
-
+
| 17 |
- 10x |
+ |
- output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
+ #' reporter <- Reporter$new()
|
-
+
| 18 |
- 10x |
+ |
- dir.create(path = output_dir)
+ #'
|
-
+
| 19 |
- 10x |
+ |
- private$output_dir <- output_dir
+ initialize = function() {
|
| 20 |
- 10x |
+ 44x |
- invisible(self)
+ private$cards <- list()
|
-
+
| 21 |
- |
+ 44x |
- },
+ private$reactive_add_card <- shiny::reactiveVal(0)
|
-
+
| 22 |
- |
+ 44x |
- #' @description Finalizes a `Renderer` object.
+ invisible(self)
|
| 23 |
|
- finalize = function() {
+ },
|
-
+
| 24 |
- 10x |
+ |
- unlink(private$output_dir, recursive = TRUE)
+ #' @description Append one or more `ReportCard` objects to the `Reporter`.
|
| 25 |
|
- },
+ #'
|
| 26 |
|
- #' @description getting the `Rmd` text which could be easily rendered later.
+ #' @param cards (`ReportCard`) or a list of such objects
|
| 27 |
|
- #'
+ #' @return `self`, invisibly.
|
| 28 |
|
- #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
+ #' @examples
|
| 29 |
|
- #' @param yaml_header `character` an `rmarkdown` `yaml` header.
+ #' library(ggplot2)
|
| 30 |
|
- #' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
+ #' library(rtables)
|
| 31 |
|
- #' for customizing the rendering process.
+ #'
|
| 32 |
|
- #' @details `r global_knitr_details()`
+ #' card1 <- ReportCard$new()
|
@@ -2994,1043 +3106,1043 @@ teal.reporter coverage - 82.57%
34 |
|
- #' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
+ #' card1$append_text("Header 2 text", "header2")
|
| 35 |
|
- #' @examples
+ #' card1$append_text("A paragraph of default text", "header2")
|
| 36 |
|
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ #' card1$append_plot(
|
| 37 |
|
- #' card1 <- ReportCard$new()
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
| 38 |
|
- #'
+ #' )
|
| 39 |
|
- #' card1$append_text("Header 2 text", "header2")
+ #'
|
| 40 |
|
- #' card1$append_text("A paragraph of default text")
+ #' card2 <- ReportCard$new()
|
| 41 |
|
- #' card1$append_plot(
+ #'
|
| 42 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ #' card2$append_text("Header 2 text", "header2")
|
| 43 |
|
- #' )
+ #' card2$append_text("A paragraph of default text", "header2")
|
| 44 |
|
- #'
+ #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
|
| 45 |
|
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ #' table_res2 <- build_table(lyt, airquality)
|
| 46 |
|
- #' card2 <- ReportCard$new()
+ #' card2$append_table(table_res2)
|
| 47 |
|
- #'
+ #' card2$append_table(iris)
|
| 48 |
|
- #' card2$append_text("Header 2 text", "header2")
+ #'
|
| 49 |
|
- #' card2$append_text("A paragraph of default text", "header2")
+ #' reporter <- Reporter$new()
|
| 50 |
|
- #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
+ #' reporter$append_cards(list(card1, card2))
|
| 51 |
|
- #' table_res2 <- rtables::build_table(lyt, airquality)
+ append_cards = function(cards) {
|
-
+
| 52 |
- |
+ 41x |
- #' card2$append_table(table_res2)
+ checkmate::assert_list(cards, "ReportCard")
|
-
+
| 53 |
- |
+ 41x |
- #' card2$append_table(iris)
+ private$cards <- append(private$cards, cards)
|
-
+
| 54 |
- |
+ 41x |
- #' card2$append_rcode("2+2", echo = FALSE)
+ private$reactive_add_card(length(private$cards))
|
-
+
| 55 |
- |
+ 41x |
- #'
+ invisible(self)
|
| 56 |
|
- #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
+ },
|
| 57 |
|
- #' reporter <- Reporter$new()
+ #' @description Retrieves all `ReportCard` objects contained in the `Reporter`.
|
| 58 |
|
- #' reporter$append_cards(list(card1, card2))
+ #'
|
| 59 |
|
- #'
+ #' @return A (`list`) of [`ReportCard`] objects.
|
| 60 |
|
- #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
+ #' @examples
|
| 61 |
|
- #' yaml_l <- list(
+ #' library(ggplot2)
|
| 62 |
|
- #' author = yaml_quoted("NEST"),
+ #' library(rtables)
|
| 63 |
|
- #' title = yaml_quoted("Report"),
+ #'
|
| 64 |
|
- #' date = yaml_quoted("07/04/2019"),
+ #' card1 <- ReportCard$new()
|
| 65 |
|
- #' output = list(html_document = list(toc = FALSE))
+ #'
|
| 66 |
|
- #' )
+ #' card1$append_text("Header 2 text", "header2")
|
| 67 |
|
- #'
+ #' card1$append_text("A paragraph of default text", "header2")
|
| 68 |
|
- #' md_header <- getFromNamespace("md_header", "teal.reporter")
+ #' card1$append_plot(
|
| 69 |
|
- #' yaml_header <- md_header(yaml::as.yaml(yaml_l))
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
| 70 |
|
- #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
+ #' )
|
| 71 |
|
- #' result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
+ #'
|
| 72 |
|
- #'
+ #' card2 <- ReportCard$new()
|
| 73 |
|
- renderRmd = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr")) {
+ #'
|
-
+
| 74 |
- 8x |
+ |
- checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
+ #' card2$append_text("Header 2 text", "header2")
|
-
+
| 75 |
- 7x |
+ |
- checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
+ #' card2$append_text("A paragraph of default text", "header2")
|
| 76 |
|
-
+ #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
|
-
+
| 77 |
- 7x |
+ |
- if (missing(yaml_header)) {
+ #' table_res2 <- build_table(lyt, airquality)
|
-
+
| 78 |
- 2x |
+ |
- yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
+ #' card2$append_table(table_res2)
|
| 79 |
|
- }
+ #' card2$append_table(iris)
|
| 80 |
|
-
+ #'
|
-
+
| 81 |
- 7x |
+ |
- private$report_type <- get_yaml_field(yaml_header, "output")
+ #' reporter <- Reporter$new()
|
| 82 |
|
-
+ #' reporter$append_cards(list(card1, card2))
|
-
+
| 83 |
- 7x |
+ |
- parsed_global_knitr <- sprintf(
+ #' reporter$get_cards()
|
-
+
| 84 |
- 7x |
+ |
- "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n%s\n```\n",
+ get_cards = function() {
|
| 85 |
- 7x |
+ 72x |
- capture.output(dput(global_knitr)),
+ private$cards
|
-
+
| 86 |
- 7x |
+ |
- if (identical(private$report_type, "powerpoint_presentation")) {
+ },
|
-
+
| 87 |
- ! |
+ |
- format_code_block_function <- quote(
+ #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`.
|
-
+
| 88 |
- ! |
+ |
- code_block <- function(code_text) {
+ #'
|
-
+
| 89 |
- ! |
+ |
- df <- data.frame(code_text)
+ #' @param sep An optional separator to insert between each content block.
|
-
+
| 90 |
- ! |
+ |
- ft <- flextable::flextable(df)
+ #' Default is a `NewpageBlock$new()`object.
|
-
+
| 91 |
- ! |
+ |
- ft <- flextable::delete_part(ft, part = "header")
+ #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`.
|
-
+
| 92 |
- ! |
+ |
- ft <- flextable::autofit(ft, add_h = 0)
+ #' @examples
|
-
+
| 93 |
- ! |
+ |
- ft <- flextable::fontsize(ft, size = 7, part = "body")
+ #' library(ggplot2)
|
-
+
| 94 |
- ! |
+ |
- ft <- flextable::bg(x = ft, bg = "lightgrey")
+ #' library(rtables)
|
-
+
| 95 |
- ! |
+ |
- ft <- flextable::border_outer(ft)
+ #'
|
-
+
| 96 |
- ! |
+ |
- if (flextable::flextable_dim(ft)$widths > 8) {
+ #' card1 <- ReportCard$new()
|
-
+
| 97 |
- ! |
+ |
- ft <- flextable::width(ft, width = 8)
+ #'
|
| 98 |
|
- }
+ #' card1$append_text("Header 2 text", "header2")
|
-
+
| 99 |
- ! |
+ |
- ft
+ #' card1$append_text("A paragraph of default text", "header2")
|
| 100 |
|
- }
+ #' card1$append_plot(
|
| 101 |
|
- )
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
-
+
| 102 |
- ! |
+ |
- paste(deparse(format_code_block_function), collapse = "\n")
+ #' )
|
| 103 |
|
- } else {
+ #'
|
| 104 |
|
- ""
+ #' card2 <- ReportCard$new()
|
| 105 |
|
- }
+ #'
|
| 106 |
|
- )
+ #' card2$append_text("Header 2 text", "header2")
|
| 107 |
|
-
+ #' card2$append_text("A paragraph of default text", "header2")
|
-
+
| 108 |
- 7x |
+ |
- parsed_blocks <- paste(
+ #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
|
-
+
| 109 |
- 7x |
+ |
- unlist(
+ #' table_res2 <- build_table(lyt, airquality)
|
-
+
| 110 |
- 7x |
+ |
- lapply(blocks, function(b) private$block2md(b))
+ #' card2$append_table(table_res2)
|
| 111 |
|
- ),
+ #' card2$append_table(iris)
|
-
+
| 112 |
- 7x |
+ |
- collapse = "\n\n"
+ #'
|
| 113 |
|
- )
+ #' reporter <- Reporter$new()
|
| 114 |
|
-
+ #' reporter$append_cards(list(card1, card2))
|
-
+
| 115 |
- 7x |
+ |
- rmd_text <- paste0(yaml_header, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
+ #' reporter$get_blocks()
|
-
+
| 116 |
- 7x |
+ |
- tmp <- tempfile(fileext = ".Rmd")
+ #'
|
-
+
| 117 |
- 7x |
+ |
- input_path <- file.path(
+ get_blocks = function(sep = NewpageBlock$new()) {
|
| 118 |
- 7x |
+ 36x |
- private$output_dir,
+ blocks <- list()
|
| 119 |
- 7x |
+ 36x |
- sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
+ if (length(private$cards) > 0) {
|
-
+
| 120 |
- |
+ 33x |
- )
+ for (card_idx in head(seq_along(private$cards), -1)) {
|
| 121 |
- 7x |
+ 14x |
- cat(rmd_text, file = input_path)
+ blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
|
-
+
| 122 |
- 7x |
+ |
- input_path
+ }
|
-
+
| 123 |
- |
+ 33x |
- },
+ blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
|
| 124 |
|
- #' @description Renders the content of this `Report` to the output file
+ }
|
-
+
| 125 |
- |
+ 36x |
- #'
+ blocks
|
| 126 |
|
- #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
+ },
|
| 127 |
|
- #' @param yaml_header `character` an `rmarkdown` `yaml` header.
+ #' @description Resets the `Reporter`, removing all [`ReportCard`] objects and metadata.
|
| 128 |
|
- #' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
+ #'
|
| 129 |
|
- #' for customizing the rendering process.
+ #' @return `self`, invisibly.
|
| 130 |
|
- #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
+ #'
|
| 131 |
|
- #' @details `r global_knitr_details()`
+ reset = function() {
|
-
+
| 132 |
- |
+ 27x |
- #'
+ private$cards <- list()
|
-
+
| 133 |
- |
+ 27x |
- #' @return `character` path to the output
+ private$metadata <- list()
|
-
+
| 134 |
- |
+ 27x |
- #' @examples
+ private$reactive_add_card(0)
|
-
+
| 135 |
- |
+ 27x |
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ invisible(self)
|
| 136 |
|
- #' card1 <- ReportCard$new()
+ },
|
| 137 |
|
- #'
+ #' @description Removes specific `ReportCard` objects from the `Reporter` by their indices.
|
| 138 |
|
- #' card1$append_text("Header 2 text", "header2")
+ #'
|
| 139 |
|
- #' card1$append_text("A paragraph of default text")
+ #' @param ids (`integer(id)`) the indexes of cards
|
| 140 |
|
- #' card1$append_plot(
+ #' @return `self`, invisibly.
|
| 141 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ remove_cards = function(ids = NULL) {
|
-
+
| 142 |
- |
+ 1x |
- #' )
+ checkmate::assert(
|
-
+
| 143 |
- |
+ 1x |
- #'
+ checkmate::check_null(ids),
|
-
+
| 144 |
- |
+ 1x |
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
|
| 145 |
|
- #' card2 <- ReportCard$new()
+ )
|
-
+
| 146 |
- |
+ 1x |
- #'
+ if (!is.null(ids)) {
|
-
+
| 147 |
- |
+ 1x |
- #' card2$append_text("Header 2 text", "header2")
+ private$cards <- private$cards[-ids]
|
| 148 |
|
- #' card2$append_text("A paragraph of default text", "header2")
+ }
|
-
+
| 149 |
- |
+ 1x |
- #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
+ private$reactive_add_card(length(private$cards))
|
-
+
| 150 |
- |
+ 1x |
- #' table_res2 <- rtables::build_table(lyt, airquality)
+ invisible(self)
|
| 151 |
|
- #' card2$append_table(table_res2)
+ },
|
| 152 |
|
- #' card2$append_table(iris)
+ #' @description Swaps the positions of two `ReportCard` objects within the `Reporter`.
|
| 153 |
|
- #' card2$append_rcode("2+2", echo = FALSE)
+ #'
|
| 154 |
|
- #' Reporter <- getFromNamespace("Reporter", "teal.reporter")$new()
+ #' @param start (`integer`) the index of the first card
|
| 155 |
|
- #' Reporter$append_cards(list(card1, card2))
+ #' @param end (`integer`) the index of the second card
|
| 156 |
|
- #'
+ #' @return `self`, invisibly.
|
| 157 |
|
- #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
+ swap_cards = function(start, end) {
|
-
+
| 158 |
- |
+ 6x |
- #' yaml_l <- list(
+ checkmate::assert(
|
-
+
| 159 |
- |
+ 6x |
- #' author = yaml_quoted("NEST"),
+ checkmate::check_integer(start,
|
-
+
| 160 |
- |
+ 6x |
- #' title = yaml_quoted("Report"),
+ min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
|
| 161 |
|
- #' date = yaml_quoted("07/04/2019"),
+ ),
|
-
+
| 162 |
- |
+ 6x |
- #' output = list(html_document = list(toc = FALSE))
+ checkmate::check_integer(end,
|
-
+
| 163 |
- |
+ 6x |
- #' )
+ min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
|
| 164 |
|
- #'
+ ),
|
-
+
| 165 |
- |
+ 6x |
- #' md_header <- getFromNamespace("md_header", "teal.reporter")
+ combine = "and"
|
| 166 |
|
- #' yaml_header <- md_header(yaml::as.yaml(yaml_l))
+ )
|
-
+
| 167 |
- |
+ 6x |
- #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
+ start_val <- private$cards[[start]]$clone()
|
-
+
| 168 |
- |
+ 6x |
- #' result_path <- Renderer$new()$render(Reporter$get_blocks(), yaml_header)
+ end_val <- private$cards[[end]]$clone()
|
-
+
| 169 |
- |
+ 6x |
- #'
+ private$cards[[start]] <- end_val
|
-
+
| 170 |
- |
+ 6x |
- render = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
+ private$cards[[end]] <- start_val
|
| 171 |
6x |
- args <- list(...)
+ invisible(self)
|
-
+
| 172 |
- 6x |
+ |
- input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
+ },
|
-
+
| 173 |
- 6x |
+ |
- args <- append(args, list(
+ #' @description Gets the current value of the reactive variable for adding cards.
|
-
+
| 174 |
- 6x |
+ |
- input = input_path,
+ #'
|
-
+
| 175 |
- 6x |
+ |
- output_dir = private$output_dir,
+ #' @return `reactive_add_card` current `numeric` value of the reactive variable.
|
-
+
| 176 |
- 6x |
+ |
- output_format = "all",
+ #' @note The function has to be used in the shiny reactive context.
|
-
+
| 177 |
- 6x |
+ |
- quiet = TRUE
+ #' @examples
|
| 178 |
|
- ))
+ #' library(shiny)
|
-
+
| 179 |
- 6x |
+ |
- args_nams <- unique(names(args))
+ #'
|
-
+
| 180 |
- 6x |
+ |
- args <- lapply(args_nams, function(x) args[[x]])
+ #' isolate(Reporter$new()$get_reactive_add_card())
|
-
+
| 181 |
- 6x |
+ |
- names(args) <- args_nams
+ get_reactive_add_card = function() {
|
| 182 |
- 6x |
+ 23x |
- do.call(rmarkdown::render, args)
+ private$reactive_add_card()
|
@@ -4044,7 +4156,7 @@ teal.reporter coverage - 82.57%
184 |
|
- #' @description get `output_dir` field
+ #' @description Get the metadata associated with this `Reporter`.
|
@@ -4058,7 +4170,7 @@ teal.reporter coverage - 82.57%
186 |
|
- #' @return `character` a `output_dir` field path.
+ #' @return `named list` of metadata to be appended.
|
@@ -4072,14 +4184,14 @@ teal.reporter coverage - 82.57%
188 |
|
- #' Renderer <- getFromNamespace("Renderer", "teal.reporter")$new()
+ #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
|
| 189 |
|
- #' Renderer$get_output_dir()
+ #' reporter$get_metadata()
|
@@ -4093,2977 +4205,2894 @@ teal.reporter coverage - 82.57%
191 |
|
- get_output_dir = function() {
+ get_metadata = function() {
|
| 192 |
- 7x |
+ 17x |
- private$output_dir
+ private$metadata
|
| 193 |
|
- }
+ },
|
| 194 |
|
- ),
+ #' @description Appends metadata to this `Reporter`.
|
| 195 |
|
- private = list(
+ #'
|
| 196 |
|
- output_dir = character(0),
+ #' @param meta (`named list`) of metadata to be appended.
|
| 197 |
|
- report_type = NULL,
+ #' @return `self`, invisibly.
|
| 198 |
|
- # factory method
+ #' @examples
|
| 199 |
|
- block2md = function(block) {
+ #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
|
-
+
| 200 |
- 25x |
+ |
- if (inherits(block, "TextBlock")) {
+ #' reporter$get_metadata()
|
-
+
| 201 |
- 14x |
+ |
- private$textBlock2md(block)
+ #'
|
-
+
| 202 |
- 11x |
+ |
- } else if (inherits(block, "RcodeBlock")) {
+ append_metadata = function(meta) {
|
-
+
| 203 |
- ! |
+ 25x |
- private$rcodeBlock2md(block)
+ checkmate::assert_list(meta, names = "unique")
|
| 204 |
- 11x |
+ 22x |
- } else if (inherits(block, "PictureBlock")) {
+ checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata)))
|
| 205 |
- 7x |
+ 21x |
- private$pictureBlock2md(block)
+ private$metadata <- append(private$metadata, meta)
|
| 206 |
- 4x |
+ 21x |
- } else if (inherits(block, "TableBlock")) {
+ invisible(self)
|
-
+
| 207 |
- 2x |
+ |
- private$tableBlock2md(block)
+ },
|
-
+
| 208 |
- 2x |
+ |
- } else if (inherits(block, "NewpageBlock")) {
+ #' @description
|
-
+
| 209 |
- 2x |
+ |
- block$get_content()
+ #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
|
| 210 |
|
- } else {
+ #' @param reporter (`Reporter`) instance to copy from.
|
-
+
| 211 |
- ! |
+ |
- stop("Unknown block class")
+ #' @return `self`, invisibly.
|
| 212 |
|
- }
+ #' @examples
|
| 213 |
|
- },
+ #' reporter <- Reporter$new()
|
| 214 |
|
- # card specific methods
+ #' reporter$from_reporter(reporter)
|
| 215 |
|
- textBlock2md = function(block) {
+ from_reporter = function(reporter) {
|
| 216 |
- 14x |
+ 8x |
- text_style <- block$get_style()
+ checkmate::assert_class(reporter, "Reporter")
|
| 217 |
- 14x |
+ 8x |
- block_content <- block$get_content()
+ self$reset()
|
| 218 |
- 14x |
+ 8x |
- switch(text_style,
+ self$append_cards(reporter$get_cards())
|
| 219 |
- 2x |
+ 8x |
- "default" = block_content,
+ self$append_metadata(reporter$get_metadata())
|
-
+
| 220 |
- ! |
+ 8x |
- "verbatim" = sprintf("\n```\n%s\n```\n", block_content),
+ invisible(self)
|
-
+
| 221 |
- 12x |
+ |
- "header2" = paste0("## ", block_content),
+ },
|
-
+
| 222 |
- ! |
+ |
- "header3" = paste0("### ", block_content),
+ #' @description Convert a `Reporter` to a list and transfer any associated files to specified directory.
|
-
+
| 223 |
- ! |
+ |
- block_content
+ #' @param output_dir (`character(1)`) a path to the directory where files will be copied.
|
| 224 |
|
- )
+ #' @return `named list` representing the `Reporter` instance, including version information,
|
| 225 |
|
- },
+ #' metadata, and report cards.
|
| 226 |
|
- rcodeBlock2md = function(block) {
+ #'
|
-
+
| 227 |
- ! |
+ |
- params <- block$get_params()
+ #' @examples
|
-
+
| 228 |
- ! |
+ |
- params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
+ #' reporter <- Reporter$new()
|
-
+
| 229 |
- ! |
+ |
- if (identical(private$report_type, "powerpoint_presentation")) {
+ #' tmp_dir <- file.path(tempdir(), "testdir")
|
-
+
| 230 |
- ! |
+ |
- block_content_list <- split_text_block(block$get_content(), 30)
+ #' dir.create(tmp_dir)
|
-
+
| 231 |
- ! |
+ |
- paste(
+ #' reporter$to_list(tmp_dir)
|
-
+
| 232 |
- ! |
+ |
- sprintf(
+ to_list = function(output_dir) {
|
-
+
| 233 |
- ! |
+ 8x |
- "\\newpage\n\n---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
+ checkmate::assert_directory_exists(output_dir)
|
-
+
| 234 |
- ! |
+ 6x |
- shQuote(block_content_list, type = "cmd")
+ rlist <- list(version = "1", cards = list())
|
-
+
| 235 |
- |
+ 6x |
- ),
+ rlist[["metadata"]] <- self$get_metadata()
|
-
+
| 236 |
- ! |
+ 6x |
- collapse = "\n\n"
+ for (card in self$get_cards()) {
|
| 237 |
|
- )
+ # we want to have list names being a class names to indicate the class for $from_list
|
-
+
| 238 |
- |
+ 6x |
- } else {
+ card_class <- class(card)[1]
|
-
+
| 239 |
- ! |
+ 6x |
- sprintf(
+ u_card <- list()
|
-
+
| 240 |
- ! |
+ 6x |
- "\\newpage\n\n--- \n\n```{r, %s}\n%s\n```\n",
+ u_card[[card_class]] <- card$to_list(output_dir)
|
-
+
| 241 |
- ! |
+ 6x |
- paste(names(params), params, sep = "=", collapse = ", "),
+ rlist$cards <- c(rlist$cards, u_card)
|
-
+
| 242 |
- ! |
+ |
- block$get_content()
+ }
|
-
+
| 243 |
- |
+ 6x |
- )
+ rlist
|
| 244 |
|
- }
+ },
|
| 245 |
|
- },
+ #' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
|
| 246 |
|
- pictureBlock2md = function(block) {
+ #' @param rlist (`named list`) representing a `Reporter` instance.
|
-
+
| 247 |
- 7x |
+ |
- basename_pic <- basename(block$get_content())
+ #' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
|
-
+
| 248 |
- 7x |
+ |
- file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
+ #' @return `self`, invisibly.
|
-
+
| 249 |
- 7x |
+ |
- params <- c(
+ #' @examples
|
-
+
| 250 |
- 7x |
+ |
- `out.width` = "'100%'",
+ #' reporter <- Reporter$new()
|
-
+
| 251 |
- 7x |
+ |
- `out.height` = "'100%'"
+ #' tmp_dir <- file.path(tempdir(), "testdir")
|
| 252 |
|
- )
+ #' unlink(tmp_dir, recursive = TRUE)
|
-
+
| 253 |
- 7x |
+ |
- title <- block$get_title()
+ #' dir.create(tmp_dir)
|
-
+
| 254 |
- 7x |
+ |
- if (length(title)) params["fig.cap"] <- shQuote(title)
+ #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
|
-
+
| 255 |
- 7x |
+ |
- sprintf(
+ from_list = function(rlist, output_dir) {
|
| 256 |
- 7x |
+ 10x |
- "\n```{r, echo = FALSE, %s}\nknitr::include_graphics(path = '%s')\n```\n",
+ checkmate::assert_list(rlist)
|
| 257 |
- 7x |
+ 10x |
- paste(names(params), params, sep = "=", collapse = ", "),
+ checkmate::assert_directory_exists(output_dir)
|
| 258 |
- 7x |
+ 10x |
- basename_pic
+ if (rlist$version == "1") {
|
-
+
| 259 |
- |
+ 10x |
- )
+ new_cards <- list()
|
-
+
| 260 |
- |
+ 10x |
- },
+ cards_names <- names(rlist$cards)
|
-
+
| 261 |
- |
+ 10x |
- tableBlock2md = function(block) {
+ cards_names <- gsub("[.][0-9]*$", "", cards_names)
|
| 262 |
- 2x |
+ 10x |
- basename_table <- basename(block$get_content())
+ for (iter_c in seq_along(rlist$cards)) {
|
| 263 |
- 2x |
+ 16x |
- file.copy(block$get_content(), file.path(private$output_dir, basename_table))
+ card_class <- cards_names[iter_c]
|
| 264 |
- 2x |
+ 16x |
- sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
+ card <- rlist$cards[[iter_c]]
|
-
+
| 265 |
- |
+ 16x |
- }
+ new_card <- eval(str2lang(sprintf("%s$new()", card_class)))
|
-
+
| 266 |
- |
+ 16x |
- ),
+ new_card$from_list(card, output_dir)
|
-
+
| 267 |
- |
+ 16x |
- lock_objects = TRUE,
+ new_cards <- c(new_cards, new_card)
|
| 268 |
|
- lock_class = TRUE
+ }
|
| 269 |
|
- )
+ } else {
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 270 |
+ ! |
- #' @title `ReportCard`
+ stop("The provided version is not supported")
|
- | 2 |
+ 271 |
|
- #' @description `r lifecycle::badge("experimental")`
+ }
|
-
- | 3 |
- |
+
+ | 272 |
+ 10x |
- #' R6 class that supports creating a report card containing text, plot, table and
+ self$reset()
|
-
- | 4 |
- |
+
+ | 273 |
+ 10x |
- #' meta data blocks that can be appended and rendered to form a report output from a shiny app.
+ self$append_cards(new_cards)
|
-
- | 5 |
- |
+
+ | 274 |
+ 10x |
- #' @export
+ self$append_metadata(rlist$metadata)
|
-
- | 6 |
- |
+
+ | 275 |
+ 10x |
- #'
+ invisible(self)
|
- | 7 |
+ 276 |
|
- ReportCard <- R6::R6Class( # nolint: object_name_linter.
+ },
|
- | 8 |
+ 277 |
|
- classname = "ReportCard",
+ #' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory.
|
- | 9 |
+ 278 |
|
- public = list(
+ #' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics.
|
- | 10 |
+ 279 |
|
- #' @description Returns a `ReportCard` object.
+ #' @return `output_dir` argument.
|
- | 11 |
+ 280 |
|
- #'
+ #' @examples
|
- | 12 |
+ 281 |
|
- #' @return a `ReportCard` object
+ #' reporter <- Reporter$new()
|
- | 13 |
+ 282 |
|
- #' @examples
+ #' tmp_dir <- file.path(tempdir(), "jsondir")
|
- | 14 |
+ 283 |
|
- #' card <- ReportCard$new()
+ #' dir.create(tmp_dir)
|
- | 15 |
+ 284 |
|
- #'
+ #' reporter$to_jsondir(tmp_dir)
|
- | 16 |
+ 285 |
|
- initialize = function() {
+ to_jsondir = function(output_dir) {
|
- | 17 |
- 77x |
+ 286 |
+ 5x |
- private$content <- list()
+ checkmate::assert_directory_exists(output_dir)
|
- | 18 |
- 77x |
+ 287 |
+ 3x |
- private$metadata <- list()
+ json <- self$to_list(output_dir)
|
- | 19 |
- 77x |
+ 288 |
+ 3x |
- invisible(self)
+ cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
|
-
- | 20 |
- |
+
+ | 289 |
+ 3x |
- },
+ file = file.path(output_dir, "Report.json")
|
- | 21 |
+ 290 |
|
- #' @description Appends a table to this `ReportCard`.
+ )
|
-
- | 22 |
- |
+
+ | 291 |
+ 3x |
- #'
+ output_dir
|
- | 23 |
+ 292 |
|
- #' @param table the appended table
+ },
|
- | 24 |
+ 293 |
|
- #' @return invisibly self
+ #' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory.
|
- | 25 |
+ 294 |
|
- #' @examples
+ #' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics.
|
- | 26 |
+ 295 |
|
- #' card <- ReportCard$new()$append_table(iris)
+ #' @return `self`, invisibly.
|
- | 27 |
+ 296 |
|
- #'
+ #' @examples
|
- | 28 |
+ 297 |
|
- append_table = function(table) {
- |
-
-
- | 29 |
- 6x |
-
- self$append_content(TableBlock$new(table))
- |
-
-
- | 30 |
- 6x |
-
- invisible(self)
+ #' reporter <- Reporter$new()
|
- | 31 |
+ 298 |
|
- },
+ #' tmp_dir <- file.path(tempdir(), "jsondir")
|
- | 32 |
+ 299 |
|
- #' @description Appends a plot to this `ReportCard`.
+ #' dir.create(tmp_dir)
|
- | 33 |
+ 300 |
|
- #'
+ #' unlink(list.files(tmp_dir, recursive = TRUE))
|
- | 34 |
+ 301 |
|
- #' @param plot the appended plot
+ #' reporter$to_jsondir(tmp_dir)
|
- | 35 |
+ 302 |
|
- #' @param dim `integer vector` width and height in pixels.
+ #' reporter$from_jsondir(tmp_dir)
|
- | 36 |
+ 303 |
|
- #' @return invisibly self
+ from_jsondir = function(output_dir) {
|
-
- | 37 |
- |
+
+ | 304 |
+ 8x |
- #' @examples
+ checkmate::assert_directory_exists(output_dir)
|
-
- | 38 |
- |
+
+ | 305 |
+ 8x |
- #' card <- ReportCard$new()$append_plot(
+ checkmate::assert_true(length(list.files(output_dir)) > 0)
|
-
- | 39 |
- |
-
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
- |
-
-
- | 40 |
- |
+
+ | 306 |
+ 8x |
- #' )
+ dir_files <- list.files(output_dir)
|
-
- | 41 |
- |
+
+ | 307 |
+ 8x |
- #'
+ which_json <- grep("json$", dir_files)
|
-
- | 42 |
- |
+
+ | 308 |
+ 8x |
- append_plot = function(plot, dim = NULL) {
+ json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
|
- | 43 |
- 19x |
+ 309 |
+ 8x |
- pb <- PictureBlock$new()
+ self$reset()
|
- | 44 |
- 19x |
+ 310 |
+ 8x |
- if (!is.null(dim) && length(dim) == 2) {
+ self$from_list(json, output_dir)
|
- | 45 |
- 1x |
+ 311 |
+ 8x |
- pb$set_dim(dim)
+ invisible(self)
|
- | 46 |
+ 312 |
|
- }
- |
-
-
- | 47 |
- 19x |
-
- pb$set_content(plot)
+ }
|
-
- | 48 |
- 19x |
+
+ | 313 |
+ |
- self$append_content(pb)
+ ),
|
-
- | 49 |
- 19x |
+
+ | 314 |
+ |
- invisible(self)
+ private = list(
|
- | 50 |
+ 315 |
|
- },
+ cards = list(),
|
- | 51 |
+ 316 |
|
- #' @description Appends a paragraph of text to this `ReportCard`.
+ metadata = list(),
|
- | 52 |
+ 317 |
|
- #'
+ reactive_add_card = NULL,
|
- | 53 |
+ 318 |
|
- #' @param text (`character(0)` or `character(1)`) the text
+ # @description The copy constructor.
|
- | 54 |
+ 319 |
|
- #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
+ #
|
- | 55 |
+ 320 |
|
- #' @return invisibly self
+ # @param name the name of the field
|
- | 56 |
+ 321 |
|
- #' @examples
+ # @param value the value of the field
|
- | 57 |
+ 322 |
|
- #' card <- ReportCard$new()$append_text("A paragraph of default text")
+ # @return the new value of the field
|
- | 58 |
+ 323 |
|
- #'
+ #
|
- | 59 |
+ 324 |
|
- append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
+ deep_clone = function(name, value) {
|
- | 60 |
- 52x |
+ 325 |
+ 20x |
- self$append_content(TextBlock$new(text, style))
+ if (name == "cards") {
|
- | 61 |
- 52x |
+ 326 |
+ 1x |
- invisible(self)
+ lapply(value, function(card) card$clone(deep = TRUE))
|
- | 62 |
+ 327 |
|
- },
+ } else {
|
-
- | 63 |
- |
+
+ | 328 |
+ 19x |
- #' @description Appends an `rmarkdown` R chunk to this `ReportCard`.
+ value
|
- | 64 |
+ 329 |
|
- #'
+ }
|
- | 65 |
+ 330 |
|
- #' @param text (`character(0)` or `character(1)`) the text
+ }
|
- | 66 |
+ 331 |
|
- #' @param ... any `rmarkdown` R chunk parameter and its value.
+ ),
|
- | 67 |
+ 332 |
|
- #' @return invisibly self
+ lock_objects = TRUE,
|
- | 68 |
+ 333 |
|
- #' @examples
+ lock_class = TRUE
|
- | 69 |
+ 334 |
|
- #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
+ )
|
+
+
+
+
+
+
- | 70 |
+ 1 |
|
- #'
+ #' @title `ReportCard`: An `R6` class for building report elements
|
- | 71 |
+ 2 |
|
- append_rcode = function(text, ...) {
- |
-
-
- | 72 |
- 4x |
-
- self$append_content(RcodeBlock$new(text, ...))
- |
-
-
- | 73 |
- 4x |
-
- invisible(self)
+ #' @docType class
|
- | 74 |
+ 3 |
|
- },
+ #'
|
- | 75 |
+ 4 |
|
- #' @description Appends a `ContentBlock` to this `ReportCard`.
+ #' @description `r lifecycle::badge("experimental")`
|
- | 76 |
+ 5 |
|
- #'
+ #'
|
- | 77 |
+ 6 |
|
- #' @param content (`ContentBlock`)
+ #' This `R6` class that supports creating a report card containing text, plot, table and
|
- | 78 |
+ 7 |
|
- #' @return invisibly self
+ #' metadata blocks that can be appended and rendered to form a report output from a `shiny` app.
|
- | 79 |
+ 8 |
|
- #' @examples
+ #'
|
- | 80 |
+ 9 |
|
- #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
+ #' @export
|
- | 81 |
+ 10 |
|
- #' card <- ReportCard$new()$append_content(NewpageBlock$new())
+ #'
|
- | 82 |
+ 11 |
|
- #'
+ ReportCard <- R6::R6Class( # nolint: object_name_linter.
|
- | 83 |
+ 12 |
|
- append_content = function(content) {
- |
-
-
- | 84 |
- 141x |
-
- checkmate::assert_class(content, "ContentBlock")
- |
-
-
- | 85 |
- 141x |
-
- private$content <- append(private$content, content)
- |
-
-
- | 86 |
- 141x |
-
- invisible(self)
+ classname = "ReportCard",
|
- | 87 |
+ 13 |
|
- },
+ public = list(
|
- | 88 |
+ 14 |
|
- #' @description Returns the content of this `ReportCard`.
+ #' @description Initialize a `ReportCard` object.
|
- | 89 |
+ 15 |
|
#'
|
- | 90 |
+ 16 |
|
- #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
+ #' @return Object of class `ReportCard`, invisibly.
|
- | 91 |
+ 17 |
|
#' @examples
|
- | 92 |
+ 18 |
|
- #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
+ #' card <- ReportCard$new()
|
- | 93 |
+ 19 |
|
#'
|
- | 94 |
+ 20 |
|
- #' card$get_content()
+ initialize = function() {
|
-
- | 95 |
- |
+
+ | 21 |
+ 77x |
- #'
+ private$content <- list()
+ |
+
+
+ | 22 |
+ 77x |
+
+ private$metadata <- list()
+ |
+
+
+ | 23 |
+ 77x |
+
+ invisible(self)
|
- | 96 |
+ 24 |
|
- #'
+ },
|
- | 97 |
+ 25 |
|
- get_content = function() {
+ #' @description Appends a table to this `ReportCard`.
|
-
- | 98 |
- 85x |
+
+ | 26 |
+ |
- private$content
+ #'
|
- | 99 |
+ 27 |
|
- },
+ #' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
|
- | 100 |
+ 28 |
|
- #' @description Removes all objects added to this `ReportCard`.
+ #' that can be coerced into a table.
|
- | 101 |
+ 29 |
|
- #'
+ #' @return `self`, invisibly.
|
- | 102 |
+ 30 |
|
- #' @return invisibly self
+ #' @examples
|
- | 103 |
+ 31 |
|
- #'
+ #' card <- ReportCard$new()$append_table(iris)
|
- | 104 |
+ 32 |
|
- reset = function() {
+ #'
|
-
- | 105 |
- 17x |
+
+ | 33 |
+ |
- private$content <- list()
+ append_table = function(table) {
|
- | 106 |
- 17x |
+ 34 |
+ 6x |
- private$metadata <- list()
+ self$append_content(TableBlock$new(table))
|
- | 107 |
- 17x |
+ 35 |
+ 6x |
invisible(self)
|
- | 108 |
+ 36 |
|
},
|
- | 109 |
+ 37 |
|
- #' @description Returns the metadata of this `ReportCard`.
+ #' @description Appends a plot to this `ReportCard`.
|
- | 110 |
+ 38 |
|
#'
|
- | 111 |
+ 39 |
|
- #' @return `named list` list of elements.
+ #' @param plot (`ggplot` or `grob` or `trellis`) plot object.
|
- | 112 |
+ 40 |
|
- #' @examples
+ #' @param dim (`numeric(2)`) width and height in pixels.
|
- | 113 |
+ 41 |
|
- #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
+ #' @return `self`, invisibly.
|
- | 114 |
+ 42 |
|
- #'
+ #' @examples
|
- | 115 |
+ 43 |
|
- #' card$get_metadata()
+ #' library(ggplot2)
|
- | 116 |
+ 44 |
|
#'
|
- | 117 |
+ 45 |
|
- get_metadata = function() {
- |
-
-
- | 118 |
- 11x |
-
- private$metadata
+ #' card <- ReportCard$new()$append_plot(
|
- | 119 |
+ 46 |
|
- },
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
- | 120 |
+ 47 |
|
- #' @description Appends metadata to this `ReportCard`.
+ #' )
|
- | 121 |
+ 48 |
|
#'
|
- | 122 |
+ 49 |
|
- #' @param key (`character(1)`) name of meta data.
+ append_plot = function(plot, dim = NULL) {
|
-
- | 123 |
- |
+
+ | 50 |
+ 19x |
- #' @param value value of meta data.
+ pb <- PictureBlock$new()
|
-
- | 124 |
- |
+
+ | 51 |
+ 19x |
- #' @return invisibly self
+ if (!is.null(dim) && length(dim) == 2) {
|
-
- | 125 |
- |
+
+ | 52 |
+ 1x |
- #' @examples
+ pb$set_dim(dim)
|
- | 126 |
+ 53 |
|
- #' card <- ReportCard$new()$append_text("Some text")$append_plot(
+ }
|
-
- | 127 |
- |
+
+ | 54 |
+ 19x |
+
+ pb$set_content(plot)
+ |
+
+
+ | 55 |
+ 19x |
+
+ self$append_content(pb)
+ |
+
+
+ | 56 |
+ 19x |
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ invisible(self)
|
- | 128 |
+ 57 |
|
- #' )$append_text("Some text")$append_metadata(key = "lm",
+ },
|
- | 129 |
+ 58 |
|
- #' value = lm(Ozone ~ Solar.R, airquality))
+ #' @description Appends a text paragraph to this `ReportCard`.
|
- | 130 |
+ 59 |
|
- #' card$get_content()
+ #'
|
- | 131 |
+ 60 |
|
- #' card$get_metadata()
+ #' @param text (`character`) The text content to add.
|
- | 132 |
+ 61 |
|
- #'
+ #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
|
- | 133 |
+ 62 |
|
- append_metadata = function(key, value) {
+ #' @return `self`, invisibly.
|
-
- | 134 |
- 16x |
+
+ | 63 |
+ |
- checkmate::assert_character(key, min.len = 0, max.len = 1)
+ #' @examples
|
-
- | 135 |
- 13x |
+
+ | 64 |
+ |
- checkmate::assert_false(key %in% names(private$metadata))
+ #' card <- ReportCard$new()$append_text("A paragraph of default text")
|
-
- | 136 |
- 12x |
+
+ | 65 |
+ |
- meta_list <- list()
+ #'
|
-
- | 137 |
- 12x |
+
+ | 66 |
+ |
- meta_list[[key]] <- value
+ append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
|
- | 138 |
- 11x |
+ 67 |
+ 52x |
- private$metadata <- append(private$metadata, meta_list)
+ self$append_content(TextBlock$new(text, style))
|
- | 139 |
- 11x |
+ 68 |
+ 52x |
invisible(self)
|
- | 140 |
+ 69 |
|
},
|
- | 141 |
+ 70 |
|
- #' @description get the Card name
+ #' @description Appends an `R` code chunk to `ReportCard`.
|
- | 142 |
+ 71 |
|
#'
|
- | 143 |
+ 72 |
|
- #' @return `character` a Card name
+ #' @param text (`character`) The `R` code to include.
|
- | 144 |
+ 73 |
|
- #' @examples
+ #' @param ... Additional `rmarkdown` parameters for formatting the `R` code chunk.
|
- | 145 |
+ 74 |
|
- #' ReportCard$new()$set_name("NAME")$get_name()
+ #' @return `self`, invisibly.
|
- | 146 |
+ 75 |
|
- get_name = function() {
+ #' @examples
|
-
- | 147 |
- 16x |
+
+ | 76 |
+ |
- private$name
+ #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
|
- | 148 |
+ 77 |
+ |
+
+ #'
+ |
+
+
+ | 78 |
+ |
+
+ append_rcode = function(text, ...) {
+ |
+
+
+ | 79 |
+ 4x |
+
+ self$append_content(RcodeBlock$new(text, ...))
+ |
+
+
+ | 80 |
+ 4x |
+
+ invisible(self)
+ |
+
+
+ | 81 |
|
},
|
- | 149 |
+ 82 |
|
- #' @description set the Card name
+ #' @description Appends a generic `ContentBlock` to this `ReportCard`.
|
- | 150 |
+ 83 |
|
#'
|
- | 151 |
+ 84 |
|
- #' @param name `character` a Card name
+ #' @param content (`ContentBlock`) object.
|
- | 152 |
+ 85 |
|
- #' @return invisibly self
+ #' @return `self`, invisibly.
|
- | 153 |
+ 86 |
|
#' @examples
|
- | 154 |
+ 87 |
|
- #' ReportCard$new()$set_name("NAME")$get_name()
+ #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
|
- | 155 |
+ 88 |
|
- set_name = function(name) {
+ #' card <- ReportCard$new()$append_content(NewpageBlock$new())
+ |
+
+
+ | 89 |
+ |
+
+ #'
+ |
+
+
+ | 90 |
+ |
+
+ append_content = function(content) {
|
- | 156 |
- 1x |
+ 91 |
+ 141x |
- checkmate::assert_string(name)
+ checkmate::assert_class(content, "ContentBlock")
|
- | 157 |
- 1x |
+ 92 |
+ 141x |
- private$name <- name
+ private$content <- append(private$content, content)
|
- | 158 |
- 1x |
+ 93 |
+ 141x |
invisible(self)
|
- | 159 |
+ 94 |
|
},
|
- | 160 |
+ 95 |
|
- #' @description Convert the `ReportCard` to a list.
+ #' @description Get all content blocks from this `ReportCard`.
|
- | 161 |
+ 96 |
|
- #' @param output_dir `character` with a path to the directory where files will be copied.
+ #'
|
- | 162 |
+ 97 |
|
- #' @return `named list` a `ReportCard` representation.
+ #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
|
- | 163 |
+ 98 |
|
#' @examples
|
- | 164 |
+ 99 |
|
- #' card <- ReportCard$new()$append_text("Some text")$append_plot(
+ #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
|
- | 165 |
+ 100 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ #'
|
- | 166 |
+ 101 |
|
- #' )$append_text("Some text")$append_metadata(key = "lm",
+ #' card$get_content()
|
- | 167 |
+ 102 |
|
- #' value = lm(Ozone ~ Solar.R, airquality))
+ #'
|
- | 168 |
+ 103 |
|
- #' card$get_content()
+ #'
|
- | 169 |
+ 104 |
|
- #'
+ get_content = function() {
+ |
+
+
+ | 105 |
+ 85x |
+
+ private$content
|
- | 170 |
+ 106 |
|
- #' card$to_list(tempdir())
+ },
|
- | 171 |
+ 107 |
|
- #'
+ #' @description Clears all content and metadata from `ReportCard`.
|
- | 172 |
+ 108 |
|
- to_list = function(output_dir) {
+ #'
|
-
- | 173 |
- 7x |
+
+ | 109 |
+ |
- new_blocks <- list()
+ #' @return `self`, invisibly.
|
-
- | 174 |
- 7x |
+
+ | 110 |
+ |
- for (block in self$get_content()) {
+ #'
|
-
- | 175 |
- 25x |
+
+ | 111 |
+ |
- block_class <- class(block)[1]
+ reset = function() {
|
- | 176 |
- 25x |
+ 112 |
+ 17x |
- cblock <- if (inherits(block, "FileBlock")) {
+ private$content <- list()
|
- | 177 |
- 10x |
+ 113 |
+ 17x |
- block$to_list(output_dir)
+ private$metadata <- list()
|
- | 178 |
- 25x |
+ 114 |
+ 17x |
- } else if (inherits(block, "ContentBlock")) {
+ invisible(self)
|
-
- | 179 |
- 15x |
+
+ | 115 |
+ |
- block$to_list()
+ },
|
- | 180 |
+ 116 |
|
- } else {
+ #' @description Get the metadata associated with `ReportCard`.
|
-
- | 181 |
- ! |
+
+ | 117 |
+ |
- list()
+ #'
|
- | 182 |
+ 118 |
|
- }
+ #' @return `named list` list of elements.
|
-
- | 183 |
- 25x |
+
+ | 119 |
+ |
- new_block <- list()
+ #' @examples
|
-
- | 184 |
- 25x |
+
+ | 120 |
+ |
- new_block[[block_class]] <- cblock
+ #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
|
-
- | 185 |
- 25x |
+
+ | 121 |
+ |
- new_blocks <- c(new_blocks, new_block)
+ #'
|
- | 186 |
+ 122 |
|
- }
+ #' card$get_metadata()
|
-
- | 187 |
- 7x |
+
+ | 123 |
+ |
- new_card <- list()
+ #'
|
-
- | 188 |
- 7x |
+
+ | 124 |
+ |
- new_card[["blocks"]] <- new_blocks
+ get_metadata = function() {
|
- | 189 |
- 7x |
+ 125 |
+ 11x |
- new_card[["metadata"]] <- self$get_metadata()
+ private$metadata
|
-
- | 190 |
- 7x |
-
- new_card
+ |
+ | 126 |
+ |
+
+ },
|
- | 191 |
+ 127 |
|
- },
+ #' @description Appends metadata to this `ReportCard`.
|
- | 192 |
+ 128 |
|
- #' @description Create the `ReportCard` from a list.
+ #'
|
- | 193 |
+ 129 |
|
- #' @param card `named list` a `ReportCard` representation.
+ #' @param key (`character(1)`) string specifying the metadata key.
|
- | 194 |
+ 130 |
|
- #' @param output_dir `character` with a path to the directory where a file will be copied.
+ #' @param value value associated with the metadata key.
|
- | 195 |
+ 131 |
|
- #' @return invisibly self
+ #' @return `self`, invisibly.
|
- | 196 |
+ 132 |
|
#' @examples
|
- | 197 |
+ 133 |
|
- #' card <- ReportCard$new()$append_text("Some text")$append_plot(
+ #' library(ggplot2)
|
- | 198 |
+ 134 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ #'
|
- | 199 |
+ 135 |
|
- #' )$append_text("Some text")$append_metadata(key = "lm",
+ #' card <- ReportCard$new()$append_text("Some text")$append_plot(
|
- | 200 |
+ 136 |
|
- #' value = lm(Ozone ~ Solar.R, airquality))
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
- | 201 |
+ 137 |
|
- #' card$get_content()
+ #' )$append_text("Some text")$append_metadata(key = "lm",
|
- | 202 |
+ 138 |
|
- #'
+ #' value = lm(Ozone ~ Solar.R, airquality))
|
- | 203 |
+ 139 |
|
- #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
+ #' card$get_content()
|
- | 204 |
+ 140 |
+ |
+
+ #' card$get_metadata()
+ |
+
+
+ | 141 |
|
#'
|
- | 205 |
+ 142 |
|
- from_list = function(card, output_dir) {
+ append_metadata = function(key, value) {
|
- | 206 |
- 17x |
+ 143 |
+ 16x |
- self$reset()
+ checkmate::assert_character(key, min.len = 0, max.len = 1)
|
- | 207 |
- 17x |
+ 144 |
+ 13x |
- blocks <- card$blocks
+ checkmate::assert_false(key %in% names(private$metadata))
|
- | 208 |
- 17x |
+ 145 |
+ 12x |
- metadata <- card$metadata
+ meta_list <- list()
|
- | 209 |
- 17x |
+ 146 |
+ 12x |
- blocks_names <- names(blocks)
+ meta_list[[key]] <- value
|
- | 210 |
- 17x |
+ 147 |
+ 11x |
- blocks_names <- gsub("[.][0-9]*$", "", blocks_names)
+ private$metadata <- append(private$metadata, meta_list)
|
- | 211 |
- 17x |
+ 148 |
+ 11x |
- for (iter_b in seq_along(blocks)) {
+ invisible(self)
|
-
- | 212 |
- 60x |
+
+ | 149 |
+ |
- block_class <- blocks_names[iter_b]
+ },
|
-
- | 213 |
- 60x |
+
+ | 150 |
+ |
- block <- blocks[[iter_b]]
+ #' @description Get the name of the `ReportCard`.
|
-
- | 214 |
- 60x |
+
+ | 151 |
+ |
- cblock <- eval(str2lang(sprintf("%s$new()", block_class)))
+ #'
|
-
- | 215 |
- 60x |
+
+ | 152 |
+ |
- if (inherits(cblock, "FileBlock")) {
+ #' @return `character` a card name.
|
-
- | 216 |
- 25x |
+
+ | 153 |
+ |
- cblock$from_list(block, output_dir)
+ #' @examples
|
-
- | 217 |
- 35x |
+
+ | 154 |
+ |
- } else if (inherits(cblock, "ContentBlock")) {
+ #' ReportCard$new()$set_name("NAME")$get_name()
+ |
+
+
+ | 155 |
+ |
+
+ get_name = function() {
|
- | 218 |
- 35x |
+ 156 |
+ 16x |
- cblock$from_list(block)
+ private$name
|
- | 219 |
+ 157 |
|
- } else {
+ },
|
-
- | 220 |
- ! |
+
+ | 158 |
+ |
- NULL
+ #' @description Set the name of the `ReportCard`.
|
- | 221 |
+ 159 |
|
- }
+ #'
|
-
- | 222 |
- 60x |
+
+ | 160 |
+ |
- self$append_content(cblock)
+ #' @param name (`character(1)`) a card name.
|
- | 223 |
+ 161 |
|
- }
+ #' @return `self`, invisibly.
|
-
- | 224 |
- 17x |
+
+ | 162 |
+ |
- for (meta in names(metadata)) {
+ #' @examples
|
-
- | 225 |
- ! |
+
+ | 163 |
+ |
- self$append_metadata(meta, metadata[[meta]])
+ #' ReportCard$new()$set_name("NAME")$get_name()
|
- | 226 |
+ 164 |
|
- }
+ set_name = function(name) {
|
- | 227 |
- 17x |
+ 165 |
+ 1x |
- invisible(self)
+ checkmate::assert_string(name)
|
-
- | 228 |
- |
+
+ | 166 |
+ 1x |
- }
+ private$name <- name
|
-
- | 229 |
- |
+
+ | 167 |
+ 1x |
- ),
+ invisible(self)
|
- | 230 |
+ 168 |
|
- private = list(
+ },
|
- | 231 |
+ 169 |
|
- content = list(),
+ #' @description Convert the `ReportCard` to a list, including content and metadata.
|
- | 232 |
+ 170 |
|
- metadata = list(),
+ #' @param output_dir (`character`) with a path to the directory where files will be copied.
|
- | 233 |
+ 171 |
|
- name = character(0),
+ #' @return (`named list`) a `ReportCard` representation.
|
- | 234 |
+ 172 |
|
- # @description The copy constructor.
+ #' @examples
|
- | 235 |
+ 173 |
|
- #
+ #' library(ggplot2)
|
- | 236 |
+ 174 |
|
- # @param name the name of the field
+ #'
|
- | 237 |
+ 175 |
|
- # @param value the value of the field
+ #' card <- ReportCard$new()$append_text("Some text")$append_plot(
|
- | 238 |
+ 176 |
|
- # @return the new value of the field
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
- | 239 |
+ 177 |
|
- #
+ #' )$append_text("Some text")$append_metadata(key = "lm",
|
- | 240 |
+ 178 |
|
- deep_clone = function(name, value) {
- |
-
-
- | 241 |
- 57x |
-
- if (name == "content") {
- |
-
-
- | 242 |
- 3x |
-
- lapply(value, function(content_block) {
- |
-
-
- | 243 |
- 5x |
-
- if (inherits(content_block, "R6")) {
- |
-
-
- | 244 |
- 5x |
-
- content_block$clone(deep = TRUE)
+ #' value = lm(Ozone ~ Solar.R, airquality))
|
- | 245 |
+ 179 |
|
- } else {
+ #' card$get_content()
|
-
- | 246 |
- ! |
+
+ | 180 |
+ |
- content_block
+ #'
|
- | 247 |
+ 181 |
|
- }
+ #' card$to_list(tempdir())
|
- | 248 |
+ 182 |
|
- })
+ #'
|
- | 249 |
+ 183 |
|
- } else {
+ to_list = function(output_dir) {
|
- | 250 |
- 54x |
+ 184 |
+ 7x |
- value
+ new_blocks <- list()
|
-
- | 251 |
- |
+
+ | 185 |
+ 7x |
- }
+ for (block in self$get_content()) {
|
-
- | 252 |
- |
+
+ | 186 |
+ 25x |
- }
+ block_class <- class(block)[1]
|
-
- | 253 |
- |
+
+ | 187 |
+ 25x |
- ),
+ cblock <- if (inherits(block, "FileBlock")) {
|
-
- | 254 |
- |
+
+ | 188 |
+ 10x |
- lock_objects = TRUE,
+ block$to_list(output_dir)
|
-
- | 255 |
- |
+
+ | 189 |
+ 25x |
- lock_class = TRUE
+ } else if (inherits(block, "ContentBlock")) {
|
-
- | 256 |
- |
+
+ | 190 |
+ 15x |
- )
+ block$to_list()
|
-
-
-
-
-
-
- | 1 |
+ 191 |
|
- #' @title `ContentBlock`
+ } else {
|
-
- | 2 |
- |
+
+ | 192 |
+ ! |
- #' @keywords internal
+ list()
|
- | 3 |
+ 193 |
|
- ContentBlock <- R6::R6Class( # nolint: object_name_linter.
+ }
|
-
- | 4 |
- |
+
+ | 194 |
+ 25x |
- classname = "ContentBlock",
+ new_block <- list()
|
-
- | 5 |
- |
+
+ | 195 |
+ 25x |
- public = list(
+ new_block[[block_class]] <- cblock
|
-
- | 6 |
- |
+
+ | 196 |
+ 25x |
- #' @description Returns a `ContentBlock` object.
+ new_blocks <- c(new_blocks, new_block)
|
- | 7 |
+ 197 |
|
- #'
+ }
|
-
- | 8 |
- |
+
+ | 198 |
+ 7x |
- #' @details Returns a `ContentBlock` object with no content and the default style.
+ new_card <- list()
|
-
- | 9 |
- |
+
+ | 199 |
+ 7x |
- #'
+ new_card[["blocks"]] <- new_blocks
|
-
- | 10 |
- |
+
+ | 200 |
+ 7x |
- #' @return `ContentBlock`
+ new_card[["metadata"]] <- self$get_metadata()
|
-
- | 11 |
- |
+
+ | 201 |
+ 7x |
- #' @examples
+ new_card
|
- | 12 |
+ 202 |
|
- #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
+ },
|
- | 13 |
+ 203 |
|
- #' ContentBlock$new()
+ #' @description Reconstructs the `ReportCard` from a list representation.
|
- | 14 |
+ 204 |
|
- #'
+ #' @param card (`named list`) a `ReportCard` representation.
|
- | 15 |
+ 205 |
|
- initialize = function() {
- |
-
-
- | 16 |
- 17x |
-
- private$content <- character(0)
+ #' @param output_dir (`character`) with a path to the directory where a file will be copied.
|
-
- | 17 |
- 17x |
+
+ | 206 |
+ |
- invisible(self)
+ #' @return `self`, invisibly.
|
- | 18 |
+ 207 |
|
- },
+ #' @examples
|
- | 19 |
+ 208 |
|
- #' @description Sets content of this `ContentBlock`.
+ #' library(ggplot2)
|
- | 20 |
+ 209 |
|
#'
|
- | 21 |
+ 210 |
|
- #' @param content (`character(0)` or `character(1)`) a string literal or a file path assigned to this `ContentBlock`
+ #' card <- ReportCard$new()$append_text("Some text")$append_plot(
|
- | 22 |
+ 211 |
|
- #'
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
- | 23 |
+ 212 |
|
- #' @return invisibly self
+ #' )$append_text("Some text")$append_metadata(key = "lm",
|
- | 24 |
+ 213 |
|
- #' @examples
+ #' value = lm(Ozone ~ Solar.R, airquality))
|
- | 25 |
+ 214 |
|
- #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
+ #' card$get_content()
|
- | 26 |
+ 215 |
|
- #' block <- ContentBlock$new()
+ #'
|
- | 27 |
+ 216 |
|
- #' block$set_content("Base64 encoded picture")
+ #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
|
- | 28 |
+ 217 |
|
#'
|
- | 29 |
+ 218 |
|
- set_content = function(content) {
+ from_list = function(card, output_dir) {
|
- | 30 |
- 361x |
+ 219 |
+ 17x |
- checkmate::assert_character(content, min.len = 0, max.len = 1)
+ self$reset()
|
- | 31 |
- 358x |
+ 220 |
+ 17x |
- private$content <- content
+ blocks <- card$blocks
|
- | 32 |
- 358x |
-
- invisible(self)
- |
-
-
- | 33 |
- |
-
- },
- |
-
-
- | 34 |
- |
-
- #' @description Returns the absolute path to content of this `ContentBlock`
- |
-
-
- | 35 |
- |
+ 221 |
+ 17x |
- #'
+ metadata <- card$metadata
|
-
- | 36 |
- |
+
+ | 222 |
+ 17x |
- #' @return `character` content of this `ContentBlock`
+ blocks_names <- names(blocks)
|
-
- | 37 |
- |
+
+ | 223 |
+ 17x |
- #' @examples
+ blocks_names <- gsub("[.][0-9]*$", "", blocks_names)
|
-
- | 38 |
- |
+
+ | 224 |
+ 17x |
- #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
+ for (iter_b in seq_along(blocks)) {
|
-
- | 39 |
- |
+
+ | 225 |
+ 60x |
- #' block <- ContentBlock$new()
+ block_class <- blocks_names[iter_b]
|
-
- | 40 |
- |
+
+ | 226 |
+ 60x |
- #' block$get_content()
+ block <- blocks[[iter_b]]
|
-
- | 41 |
- |
+
+ | 227 |
+ 60x |
- #'
+ cblock <- eval(str2lang(sprintf("%s$new()", block_class)))
|
-
- | 42 |
- |
+
+ | 228 |
+ 60x |
- get_content = function() {
+ if (inherits(cblock, "FileBlock")) {
|
- | 43 |
- 266x |
+ 229 |
+ 25x |
- private$content
+ cblock$from_list(block, output_dir)
|
-
- | 44 |
- |
+
+ | 230 |
+ 35x |
- },
+ } else if (inherits(cblock, "ContentBlock")) {
|
-
- | 45 |
- |
+
+ | 231 |
+ 35x |
- #' @description Create the `ContentBlock` from a list.
+ cblock$from_list(block)
|
- | 46 |
+ 232 |
|
- #'
+ } else {
|
-
- | 47 |
- |
+
+ | 233 |
+ ! |
- #' @param x `named list` with two fields `c("text", "style")`.
+ NULL
|
- | 48 |
+ 234 |
|
- #' Use the `get_available_styles` method to get all possible styles.
+ }
|
-
- | 49 |
- |
+
+ | 235 |
+ 60x |
- #'
+ self$append_content(cblock)
|
- | 50 |
+ 236 |
|
- #' @return invisibly self
+ }
|
-
- | 51 |
- |
+
+ | 237 |
+ 17x |
- from_list = function(x) {
+ for (meta in names(metadata)) {
|
- | 52 |
+ 238 |
! |
- invisible(self)
- |
-
-
- | 53 |
- |
-
- },
+ self$append_metadata(meta, metadata[[meta]])
|
- | 54 |
+ 239 |
|
- #' @description Convert the `ContentBlock` to a list.
+ }
|
-
- | 55 |
- |
+
+ | 240 |
+ 17x |
- #'
+ invisible(self)
|
- | 56 |
+ 241 |
|
- #' @return `named list` with a text and style.
+ }
|
- | 57 |
+ 242 |
|
- to_list = function() {
- |
-
-
- | 58 |
- ! |
-
- list()
+ ),
|
- | 59 |
+ 243 |
|
- }
+ private = list(
|
- | 60 |
+ 244 |
|
- ),
+ content = list(),
|
- | 61 |
+ 245 |
|
- private = list(
+ metadata = list(),
|
- | 62 |
+ 246 |
|
- content = character(0),
+ name = character(0),
|
- | 63 |
+ 247 |
|
# @description The copy constructor.
|
- | 64 |
+ 248 |
|
#
|
- | 65 |
+ 249 |
|
- # @param name `character(1)` the name of the field
+ # @param name the name of the field
|
- | 66 |
+ 250 |
|
- # @param value the value assigned to the field
+ # @param value the value of the field
|
- | 67 |
+ 251 |
|
- #
+ # @return the new value of the field
|
- | 68 |
+ 252 |
|
- # @return the value of the copied field
+ #
|
- | 69 |
+ 253 |
|
deep_clone = function(name, value) {
|
- | 70 |
- 168x |
+ 254 |
+ 57x |
- if (name == "content" && checkmate::test_file_exists(value)) {
+ if (name == "content") {
|
- | 71 |
- 7x |
+ 255 |
+ 3x |
- extension <- ""
+ lapply(value, function(content_block) {
|
- | 72 |
- 7x |
+ 256 |
+ 5x |
- split <- strsplit(basename(value), split = "\\.")
+ if (inherits(content_block, "R6")) {
|
-
- | 73 |
- |
+
+ | 257 |
+ 5x |
- # The below ensures no extension is found for files such as this: .gitignore but is found for files like
+ content_block$clone(deep = TRUE)
|
- | 74 |
+ 258 |
|
- # .gitignore.txt
+ } else {
|
-
- | 75 |
- 7x |
-
- if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
- |
-
-
- | 76 |
- 5x |
-
- extension <- split[[1]][length(split[[1]])]
- |
-
-
- | 77 |
- 5x |
+
+ | 259 |
+ ! |
- extension <- paste0(".", extension)
+ content_block
|
- | 78 |
+ 260 |
|
- }
- |
-
-
- | 79 |
- 7x |
-
- copied_file <- tempfile(fileext = extension)
- |
-
-
- | 80 |
- 7x |
-
- file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
+ }
|
-
- | 81 |
- 7x |
+
+ | 261 |
+ |
- copied_file
+ })
|
- | 82 |
+ 262 |
|
} else {
|
- | 83 |
- 161x |
+ 263 |
+ 54x |
value
|
- | 84 |
+ 264 |
|
}
|
- | 85 |
+ 265 |
|
}
|
- | 86 |
+ 266 |
|
),
|
- | 87 |
+ 267 |
|
lock_objects = TRUE,
|
- | 88 |
+ 268 |
|
lock_class = TRUE
|
- | 89 |
+ 269 |
|
)
@@ -7072,10935 +7101,10660 @@ teal.reporter coverage - 82.57%
|
-
+
| 1 |
|
- #' @title `RcodeBlock`
+ #' Get bootstrap current version
|
| 2 |
|
- #' @keywords internal
+ #' @note will work properly mainly inside a tag `.renderHook`
|
| 3 |
|
- RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
+ #' @keywords internal
|
| 4 |
|
- classname = "RcodeBlock",
+ get_bs_version <- function() {
|
-
+
| 5 |
- |
+ 15x |
- inherit = ContentBlock,
+ theme <- bslib::bs_current_theme()
|
-
+
| 6 |
- |
+ 15x |
- public = list(
+ if (bslib::is_bs_theme(theme)) {
|
-
+
| 7 |
- |
+ ! |
- #' @description Returns a `RcodeBlock` object.
+ bslib::theme_version(theme)
|
| 8 |
|
- #'
+ } else {
|
-
+
| 9 |
- |
+ 15x |
- #' @details Returns a `RcodeBlock` object with no content and no parameters.
+ "3"
|
| 10 |
|
- #'
+ }
|
| 11 |
|
- #' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock`
+ }
|
| 12 |
|
- #' @param ... any `rmarkdown` R chunk parameter and it value.
+
|
| 13 |
|
- #'
+ #' Panel group widget
|
| 14 |
|
- #' @return `RcodeBlock`
+ #'
|
| 15 |
|
- #' @examples
+ #' `r lifecycle::badge("experimental")`
|
| 16 |
|
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ #'
|
| 17 |
|
- #' block <- RcodeBlock$new()
+ #' @param title (`character`) title of panel
|
| 18 |
|
- #'
+ #' @param ... content of panel
|
| 19 |
|
- initialize = function(content = character(0), ...) {
+ #' @param collapsed (`logical`, optional)
|
-
+
| 20 |
- 74x |
+ |
- super$set_content(content)
+ #' whether to initially collapse panel
|
-
+
| 21 |
- 74x |
+ |
- self$set_params(list(...))
+ #' @param input_id (`character`, optional)
|
-
+
| 22 |
- 74x |
+ |
- invisible(self)
+ #' name of the panel item element. If supplied, this will register a shiny input variable that
|
| 23 |
|
- },
+ #' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
|
| 24 |
|
- #' @description Sets the parameters of this `RcodeBlock`.
+ #'
|
| 25 |
|
- #'
+ #' @return `shiny.tag`.
|
| 26 |
|
- #' @details The parameters has bearing on the rendering of this block.
+ #'
|
| 27 |
|
- #'
+ #' @keywords internal
|
| 28 |
|
- #' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
+ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
|
-
+
| 29 |
- |
+ 1x |
- #'
+ stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
|
-
+
| 30 |
- |
+ 1x |
- #' @return invisibly self
+ checkmate::assert_flag(collapsed)
|
-
+
| 31 |
- |
+ 1x |
- #' @examples
+ checkmate::assert_string(input_id, null.ok = TRUE)
|
| 32 |
|
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+
|
-
+
| 33 |
- |
+ 1x |
- #' block <- RcodeBlock$new()
+ div_id <- paste0(input_id, "_div")
|
-
+
| 34 |
- |
+ 1x |
- #' block$set_params(list(echo = TRUE))
+ panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))
|
| 35 |
|
- #'
+
|
| 36 |
|
- set_params = function(params) {
+
|
| 37 |
- 132x |
+ 1x |
- checkmate::assert_list(params, names = "named")
+ shiny::tags$div(.renderHook = function(res_tag) {
|
-
+
| 38 |
- 132x |
+ ! |
- checkmate::assert_subset(names(params), self$get_available_params())
+ bs_version <- get_bs_version()
|
-
+
| 39 |
- 132x |
+ |
- private$params <- params
+
|
-
+
| 40 |
- 132x |
+ |
- invisible(self)
+ # alter tag structure
|
-
+
| 41 |
- |
+ ! |
- },
+ if (bs_version == "3") {
|
-
+
| 42 |
- |
+ ! |
- #' @description Returns the parameters of this `RcodeBlock`.
+ res_tag$children <- list(
|
-
+
| 43 |
- |
+ ! |
- #'
+ shiny::tags$div(
|
-
+
| 44 |
- |
+ ! |
- #' @return `character` the parameters of this `RcodeBlock`
+ class = "panel panel-default",
|
-
+
| 45 |
- |
+ ! |
- #' @examples
+ shiny::tags$div(
|
-
+
| 46 |
- |
+ ! |
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ id = div_id,
|
-
+
| 47 |
- |
+ ! |
- #' block <- RcodeBlock$new()
+ class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
|
-
+
| 48 |
- |
+ ! |
- #' block$get_params()
+ `data-toggle` = "collapse",
|
-
+
| 49 |
- |
+ ! |
- #'
+ href = paste0("#", panel_id),
|
-
+
| 50 |
- |
+ ! |
- get_params = function() {
+ `aria-expanded` = ifelse(collapsed, "false", "true"),
|
-
+
| 51 |
- 3x |
+ ! |
- private$params
+ shiny::icon("angle-down", class = "dropdown-icon"),
|
-
+
| 52 |
- |
+ ! |
- },
+ shiny::tags$label(
|
-
+
| 53 |
- |
+ ! |
- #' @description Returns an array of parameters available to this `RcodeBlock`.
+ class = "panel-title inline",
|
-
+
| 54 |
- |
+ ! |
- #'
+ title,
|
| 55 |
|
- #' @return a `character` array of parameters
+ )
|
| 56 |
|
- #' @examples
+ ),
|
-
+
| 57 |
- |
+ ! |
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ shiny::tags$div(
|
-
+
| 58 |
- |
+ ! |
- #' block <- RcodeBlock$new()
+ class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
|
-
+
| 59 |
- |
+ ! |
- #' block$get_available_params()
+ id = panel_id,
|
-
+
| 60 |
- |
+ ! |
- #'
+ shiny::tags$div(
|
-
+
| 61 |
- |
+ ! |
- get_available_params = function() {
+ class = "panel-body",
|
-
+
| 62 |
- 5x |
+ |
- names(knitr::opts_chunk$get())
+ ...
|
| 63 |
|
- },
+ )
|
| 64 |
|
- #' @description Create the `RcodeBlock` from a list.
+ )
|
| 65 |
|
- #'
+ )
|
| 66 |
|
- #' @param x `named list` with two fields `c("text", "params")`.
+ )
|
-
+
| 67 |
- |
+ ! |
- #' Use the `get_available_params` method to get all possible parameters.
+ } else if (bs_version %in% c("4", "5")) {
|
-
+
| 68 |
- |
+ ! |
- #'
+ res_tag$children <- list(
|
-
+
| 69 |
- |
+ ! |
- #' @return invisibly self
+ shiny::tags$div(
|
-
+
| 70 |
- |
+ ! |
- #' @examples
+ class = "card my-2",
|
-
+
| 71 |
- |
+ ! |
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ shiny::tags$div(
|
-
+
| 72 |
- |
+ ! |
- #' block <- RcodeBlock$new()
+ class = "card-header",
|
-
+
| 73 |
- |
+ ! |
- #' block$from_list(list(text = "sth", params = list()))
+ shiny::tags$div(
|
-
+
| 74 |
- |
+ ! |
- #'
+ class = ifelse(collapsed, "collapsed", ""),
|
| 75 |
|
- from_list = function(x) {
+ # bs4
|
-
+
| 76 |
- 3x |
+ ! |
- checkmate::assert_list(x)
+ `data-toggle` = "collapse",
|
-
+
| 77 |
- 3x |
+ |
- checkmate::assert_names(names(x), must.include = c("text", "params"))
+ # bs5
|
-
+
| 78 |
- 3x |
+ ! |
- self$set_content(x$text)
+ `data-bs-toggle` = "collapse",
|
-
+
| 79 |
- 3x |
+ ! |
- self$set_params(x$params)
+ href = paste0("#", panel_id),
|
-
+
| 80 |
- 3x |
+ ! |
- invisible(self)
+ `aria-expanded` = ifelse(collapsed, "false", "true"),
|
-
+
| 81 |
- |
+ ! |
- },
+ shiny::icon("angle-down", class = "dropdown-icon"),
|
-
+
| 82 |
- |
+ ! |
- #' @description Convert the `RcodeBlock` to a list.
+ shiny::tags$label(
|
-
+
| 83 |
- |
+ ! |
- #'
+ class = "card-title inline",
|
-
+
| 84 |
- |
+ ! |
- #' @return `named list` with a text and `params`.
+ title,
|
| 85 |
|
- #' @examples
+ )
|
| 86 |
|
- #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ )
|
| 87 |
|
- #' block <- RcodeBlock$new()
+ ),
|
-
+
| 88 |
- |
+ ! |
- #' block$to_list()
+ shiny::tags$div(
|
-
+
| 89 |
- |
+ ! |
- #'
+ id = panel_id,
|
-
+
| 90 |
- |
+ ! |
- to_list = function() {
+ class = paste("collapse", ifelse(collapsed, "", "show")),
|
-
+
| 91 |
- 3x |
+ ! |
- list(text = self$get_content(), params = self$get_params())
+ shiny::tags$div(
|
-
+
| 92 |
- |
+ ! |
- }
+ class = "card-body",
|
| 93 |
|
- ),
+ ...
|
| 94 |
|
- private = list(
+ )
|
| 95 |
|
- params = list()
+ )
|
| 96 |
|
- ),
+ )
|
| 97 |
|
- lock_objects = TRUE,
+ )
|
| 98 |
|
- lock_class = TRUE
+ } else {
|
-
+
| 99 |
- |
+ ! |
- )
+ stop("Bootstrap 3, 4, and 5 are supported.")
|
-
-
-
-
-
-
- | 1 |
+ 100 |
|
- #' Get bootstrap current version
+ }
|
- | 2 |
+ 101 |
|
- #' @note will work properly mainly inside a tag `.renderHook`
+
|
-
- | 3 |
- |
+
+ | 102 |
+ ! |
- #' @keywords internal
+ shiny::tagList(
|
-
- | 4 |
- |
+
+ | 103 |
+ ! |
- get_bs_version <- function() {
+ shiny::singleton(
|
-
- | 5 |
- 15x |
-
- theme <- bslib::bs_current_theme()
- |
-
-
- | 6 |
- 15x |
+
+ | 104 |
+ ! |
- if (bslib::is_bs_theme(theme)) {
+ shiny::tags$head(
|
- | 7 |
+ 105 |
! |
- bslib::theme_version(theme)
+ shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter"))
|
- | 8 |
+ 106 |
|
- } else {
+ )
|
-
- | 9 |
- 15x |
+
+ | 107 |
+ |
- "3"
+ ),
|
-
- | 10 |
- |
+
+ | 108 |
+ ! |
- }
+ res_tag
|
- | 11 |
+ 109 |
|
- }
+ )
|
- | 12 |
+ 110 |
|
-
+ })
|
- | 13 |
+ 111 |
|
- #' Panel group widget
+ }
|
- | 14 |
+ 112 |
|
- #' @md
+
|
- | 15 |
+ 113 |
|
- #'
+ #' Convert content into a `flextable`
|
- | 16 |
+ 114 |
|
- #' @description `r lifecycle::badge("experimental")`
+ #'
|
- | 17 |
+ 115 |
|
- #' @param title (`character`)\cr title of panel
+ #' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
|
- | 18 |
+ 116 |
|
- #' @param ... content of panel
+ #'
|
- | 19 |
+ 117 |
|
- #' @param collapsed (`logical`, optional)\cr
+ #' Function merges cells with `colspan` > 1,
|
- | 20 |
+ 118 |
|
- #' whether to initially collapse panel
+ #' aligns columns to the center and row names to the left,
|
- | 21 |
+ 119 |
|
- #' @param input_id (`character`, optional)\cr
+ #' indents the row names by 10 times indentation.
|
- | 22 |
+ 120 |
|
- #' name of the panel item element. If supplied, this will register a shiny input variable that
+ #'
|
- | 23 |
+ 121 |
|
- #' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
+ #' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
|
- | 24 |
+ 122 |
|
#'
|
- | 25 |
+ 123 |
|
- #' @return (`shiny.tag`)
+ #' @return `flextable`.
|
- | 26 |
+ 124 |
|
#'
|
- | 27 |
+ 125 |
|
#' @keywords internal
|
- | 28 |
+ 126 |
|
- panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
+ to_flextable <- function(content) {
|
- | 29 |
- 1x |
+ 127 |
+ 16x |
- stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
+ if (inherits(content, c("rtables", "TableTree", "ElementaryTable", "listing_df"))) {
|
- | 30 |
- 1x |
+ 128 |
+ 3x |
- checkmate::assert_flag(collapsed)
+ mf <- rtables::matrix_form(content)
|
- | 31 |
- 1x |
+ 129 |
+ 3x |
- checkmate::assert_string(input_id, null.ok = TRUE)
+ nr_header <- attr(mf, "nrow_header")
|
-
- | 32 |
- |
+
+ | 130 |
+ 3x |
-
+ non_total_coln <- c(TRUE, !grepl("All Patients", names(content)))
|
- | 33 |
- 1x |
+ 131 |
+ 3x |
- div_id <- paste0(input_id, "_div")
+ df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
|
- | 34 |
- 1x |
+ 132 |
+ 3x |
- panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))
+ header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
|
- | 35 |
+ 133 |
|
|
-
- | 36 |
- |
+
+ | 134 |
+ 3x |
-
+ ft <- flextable::flextable(df)
|
- | 37 |
- 1x |
+ 135 |
+ 3x |
- shiny::tags$div(.renderHook = function(res_tag) {
+ ft <- flextable::delete_part(ft, part = "header")
|
-
- | 38 |
- ! |
+
+ | 136 |
+ 3x |
- bs_version <- get_bs_version()
+ ft <- flextable::add_header(ft, values = header_df)
|
- | 39 |
+ 137 |
|
|
- | 40 |
+ 138 |
|
- # alter tag structure
+ # Add titles
|
-
- | 41 |
- ! |
+
+ | 139 |
+ 3x |
- if (bs_version == "3") {
+ ft <- flextable::set_caption(ft, flextable::as_paragraph(
|
-
- | 42 |
- ! |
+
+ | 140 |
+ 3x |
- res_tag$children <- list(
+ flextable::as_b(mf$main_title), "\n", paste(mf$subtitles, collapse = "\n")
|
-
- | 43 |
- ! |
+
+ | 141 |
+ |
- shiny::tags$div(
+ ),
|
-
- | 44 |
- ! |
+
+ | 142 |
+ 3x |
- class = "panel panel-default",
+ align_with_table = FALSE
|
-
- | 45 |
- ! |
+
+ | 143 |
+ |
- shiny::tags$div(
+ )
|
-
- | 46 |
- ! |
+
+ | 144 |
+ |
- id = div_id,
+
|
-
- | 47 |
- ! |
+
+ | 145 |
+ 3x |
- class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
+ merge_index_body <- get_merge_index(mf$spans[seq(nr_header + 1, nrow(mf$spans)), , drop = FALSE])
|
-
- | 48 |
- ! |
+
+ | 146 |
+ 3x |
- `data-toggle` = "collapse",
+ merge_index_header <- get_merge_index(mf$spans[seq_len(nr_header), , drop = FALSE])
|
-
- | 49 |
- ! |
+
+ | 147 |
+ |
- href = paste0("#", panel_id),
+
|
-
- | 50 |
- ! |
+
+ | 148 |
+ 3x |
- `aria-expanded` = ifelse(collapsed, "false", "true"),
+ ft <- merge_at_indice(ft, lst = merge_index_body, part = "body")
|
-
- | 51 |
- ! |
+
+ | 149 |
+ 3x |
- shiny::icon("angle-down", class = "dropdown-icon"),
+ ft <- merge_at_indice(ft, lst = merge_index_header, part = "header")
|
-
- | 52 |
- ! |
+
+ | 150 |
+ 3x |
- shiny::tags$label(
+ ft <- flextable::align_text_col(ft, align = "center", header = TRUE)
|
-
- | 53 |
- ! |
+
+ | 151 |
+ 3x |
- class = "panel-title inline",
+ ft <- flextable::align(ft, i = seq_len(nrow(content)), j = 1, align = "left")
|
-
- | 54 |
- ! |
+
+ | 152 |
+ 3x |
- title,
+ ft <- padding_lst(ft, mf$row_info$indent)
|
-
- | 55 |
- |
+
+ | 153 |
+ 3x |
- )
+ ft <- flextable::padding(ft, padding.top = 1, padding.bottom = 1, part = "all")
+ |
+
+
+ | 154 |
+ 3x |
+
+ ft <- flextable::autofit(ft, add_h = 0)
|
- | 56 |
+ 155 |
|
- ),
+
|
-
- | 57 |
- ! |
+
+ | 156 |
+ 3x |
- shiny::tags$div(
+ width_vector <- c(
|
-
- | 58 |
- ! |
+
+ | 157 |
+ 3x |
- class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
+ dim(ft)$widths[1],
|
-
- | 59 |
- ! |
+
+ | 158 |
+ 3x |
- id = panel_id,
+ rep(sum(dim(ft)$widths[-1]), length(dim(ft)$widths) - 1) / (ncol(mf$strings) - 1)
|
-
- | 60 |
- ! |
+
+ | 159 |
+ |
- shiny::tags$div(
+ )
|
-
- | 61 |
- ! |
+
+ | 160 |
+ 3x |
- class = "panel-body",
+ ft <- flextable::width(ft, width = width_vector)
|
-
- | 62 |
- |
+
+ | 161 |
+ 3x |
- ...
+ ft <- custom_theme(ft)
|
- | 63 |
+ 162 |
|
- )
+
|
- | 64 |
+ 163 |
|
- )
+ # Add footers
|
-
- | 65 |
- |
+
+ | 164 |
+ 3x |
- )
+ ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
|
-
- | 66 |
- |
+
+ | 165 |
+ 3x |
- )
+ flextable::as_chunk(mf$main_footer, props = flextable::fp_text_default(font.size = 8))
|
-
- | 67 |
- ! |
+
+ | 166 |
+ |
- } else if (bs_version %in% c("4", "5")) {
+ ))
|
- | 68 |
+ 167 |
! |
- res_tag$children <- list(
+ if (length(mf$main_footer) > 0 && length(mf$prov_footer) > 0) ft <- flextable::add_footer_lines(ft, c("\n"))
|
-
- | 69 |
- ! |
+
+ | 168 |
+ 3x |
- shiny::tags$div(
+ ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
|
-
- | 70 |
- ! |
+
+ | 169 |
+ 3x |
- class = "card my-2",
+ flextable::as_chunk(mf$prov_footer, props = flextable::fp_text_default(font.size = 8))
|
-
- | 71 |
- ! |
+
+ | 170 |
+ |
- shiny::tags$div(
+ ))
|
-
- | 72 |
- ! |
+
+ | 171 |
+ 13x |
- class = "card-header",
+ } else if (inherits(content, "data.frame")) {
|
-
- | 73 |
- ! |
+
+ | 172 |
+ 12x |
- shiny::tags$div(
+ ft <- flextable::flextable(content)
|
-
- | 74 |
- ! |
+
+ | 173 |
+ 12x |
- class = ifelse(collapsed, "collapsed", ""),
+ ft <- custom_theme(ft)
|
- | 75 |
+ 174 |
|
- # bs4
+ } else {
|
-
- | 76 |
- ! |
+
+ | 175 |
+ 1x |
- `data-toggle` = "collapse",
+ stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
|
- | 77 |
+ 176 |
|
- # bs5
+ }
|
-
- | 78 |
- ! |
+
+ | 177 |
+ |
- `data-bs-toggle` = "collapse",
+
|
-
- | 79 |
- ! |
+
+ | 178 |
+ 15x |
- href = paste0("#", panel_id),
+ if (flextable::flextable_dim(ft)$widths > 10) {
|
- | 80 |
+ 179 |
! |
- `aria-expanded` = ifelse(collapsed, "false", "true"),
+ pgwidth <- 10.5
|
- | 81 |
+ 180 |
! |
- shiny::icon("angle-down", class = "dropdown-icon"),
+ width_vector <- dim(ft)$widths * pgwidth / flextable::flextable_dim(ft)$widths
|
- | 82 |
+ 181 |
! |
- shiny::tags$label(
+ ft <- flextable::width(ft, width = width_vector)
|
-
- | 83 |
- ! |
+
+ | 182 |
+ |
- class = "card-title inline",
+ }
|
-
- | 84 |
- ! |
+
+ | 183 |
+ |
- title,
+
+ |
+
+
+ | 184 |
+ 15x |
+
+ ft
|
- | 85 |
+ 185 |
|
- )
+ }
|
- | 86 |
+ 186 |
|
- )
+
|
- | 87 |
+ 187 |
|
- ),
+ #' Apply a custom theme to a `flextable`
|
-
- | 88 |
- ! |
+
+ | 188 |
+ |
- shiny::tags$div(
+ #' @noRd
|
-
- | 89 |
- ! |
+
+ | 189 |
+ |
- id = panel_id,
+ #' @keywords internal
|
-
- | 90 |
- ! |
+
+ | 190 |
+ |
- class = paste("collapse", ifelse(collapsed, "", "show")),
+ custom_theme <- function(ft) {
|
-
- | 91 |
- ! |
+
+ | 191 |
+ 16x |
- shiny::tags$div(
+ checkmate::assert_class(ft, "flextable")
|
-
- | 92 |
- ! |
+
+ | 192 |
+ 16x |
- class = "card-body",
+ ft <- flextable::fontsize(ft, size = 8, part = "body")
|
-
- | 93 |
- |
+
+ | 193 |
+ 16x |
- ...
+ ft <- flextable::bold(ft, part = "header")
|
-
- | 94 |
- |
+
+ | 194 |
+ 16x |
- )
+ ft <- flextable::theme_booktabs(ft)
|
-
- | 95 |
- |
+
+ | 195 |
+ 16x |
- )
+ ft <- flextable::hline(ft, border = flextable::fp_border_default(width = 1, color = "grey"))
|
-
- | 96 |
- |
+
+ | 196 |
+ 16x |
- )
+ ft <- flextable::border_outer(ft)
|
-
- | 97 |
- |
+
+ | 197 |
+ 16x |
- )
+ ft
|
- | 98 |
+ 198 |
|
- } else {
- |
-
-
- | 99 |
- ! |
-
- stop("Bootstrap 3, 4, and 5 are supported.")
+ }
|
- | 100 |
+ 199 |
|
- }
+
|
- | 101 |
+ 200 |
|
-
+ #' Get the merge index for a single span.
|
-
- | 102 |
- ! |
+
+ | 201 |
+ |
- shiny::tagList(
+ #' This function retrieves the merge index for a single span,
|
-
- | 103 |
- ! |
+
+ | 202 |
+ |
- shiny::singleton(
+ #' which is used in merging cells.
|
-
- | 104 |
- ! |
+
+ | 203 |
+ |
- shiny::tags$head(
+ #' @noRd
|
-
- | 105 |
- ! |
+
+ | 204 |
+ |
- shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter"))
+ #' @keywords internal
|
- | 106 |
+ 205 |
|
- )
+ get_merge_index_single <- function(span) {
|
-
- | 107 |
- |
+
+ | 206 |
+ 134x |
- ),
+ ret <- list()
|
-
- | 108 |
- ! |
+
+ | 207 |
+ 134x |
- res_tag
+ j <- 1
|
-
- | 109 |
- |
+
+ | 208 |
+ 134x |
- )
+ while (j < length(span)) {
|
-
- | 110 |
- |
+
+ | 209 |
+ 141x |
- })
+ if (span[j] != 1) {
|
-
- | 111 |
- |
+
+ | 210 |
+ 3x |
- }
+ ret <- c(ret, list(seq(j, j + span[j] - 1)))
|
- | 112 |
+ 211 |
|
-
+ }
|
-
- | 113 |
- |
+
+ | 212 |
+ 141x |
- #' Convert content into a `flextable`, merge cells with `colspan` > 1
+ j <- j + span[j]
|
- | 114 |
+ 213 |
|
- #' align columns to the center, and row names to the left
+ }
|
-
- | 115 |
- |
+
+ | 214 |
+ 134x |
- #' Indent the row names by 10 times indentation
+ return(ret)
|
- | 116 |
+ 215 |
|
- #'
+ }
|
- | 117 |
+ 216 |
|
- #' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
+
|
- | 118 |
+ 217 |
|
- #'
+ #' Get the merge index for multiple spans.
|
- | 119 |
+ 218 |
|
- #' @return (`flextable`)
+ #' This function merges cells in a `flextable` at specified row and column indices.
|
- | 120 |
+ 219 |
|
- #'
+ #' @noRd
|
- | 121 |
+ 220 |
|
#' @keywords internal
|
- | 122 |
+ 221 |
|
- to_flextable <- function(content) {
+ get_merge_index <- function(spans) {
|
- | 123 |
- 16x |
+ 222 |
+ 7x |
- if (inherits(content, c("rtables", "TableTree", "ElementaryTable", "listing_df"))) {
+ ret <- lapply(seq_len(nrow(spans)), function(i) {
|
- | 124 |
- 3x |
+ 223 |
+ 133x |
- mf <- rtables::matrix_form(content)
+ ri <- spans[i, ]
|
- | 125 |
- 3x |
+ 224 |
+ 133x |
- nr_header <- attr(mf, "nrow_header")
+ r <- get_merge_index_single(ri)
|
- | 126 |
- 3x |
+ 225 |
+ 133x |
- non_total_coln <- c(TRUE, !grepl("All Patients", names(content)))
+ lapply(r, function(s) {
|
- | 127 |
- 3x |
+ 226 |
+ 2x |
- df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
+ list(j = s, i = i)
|
-
- | 128 |
- 3x |
+
+ | 227 |
+ |
- header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
+ })
|
- | 129 |
+ 228 |
|
-
+ })
|
- | 130 |
- 3x |
+ 229 |
+ 7x |
- ft <- flextable::flextable(df)
+ unlist(ret, recursive = FALSE, use.names = FALSE)
|
-
- | 131 |
- 3x |
+
+ | 230 |
+ |
- ft <- flextable::delete_part(ft, part = "header")
+ }
|
-
- | 132 |
- 3x |
+
+ | 231 |
+ |
- ft <- flextable::add_header(ft, values = header_df)
+
|
- | 133 |
+ 232 |
|
-
+ #' Merge cells in a `flextable` at specified indices
|
- | 134 |
+ 233 |
|
- # Add titles
+ #' @noRd
|
-
- | 135 |
- 3x |
+
+ | 234 |
+ |
- ft <- flextable::set_caption(ft, flextable::as_paragraph(
+ #' @keywords internal
+ |
+
+
+ | 235 |
+ |
+
+ merge_at_indice <- function(ft, lst, part) {
|
- | 136 |
- 3x |
+ 236 |
+ 7x |
- flextable::as_b(mf$main_title), "\n", paste(mf$subtitles, collapse = "\n")
+ Reduce(function(ft, ij) {
|
-
- | 137 |
- |
+
+ | 237 |
+ 2x |
- ),
+ flextable::merge_at(ft, i = ij$i, j = ij$j, part = part)
|
- | 138 |
- 3x |
+ 238 |
+ 7x |
- align_with_table = FALSE
+ }, lst, ft)
|
- | 139 |
+ 239 |
|
- )
+ }
|
- | 140 |
+ 240 |
|
|
-
- | 141 |
- 3x |
-
- merge_index_body <- get_merge_index(mf$spans[seq(nr_header + 1, nrow(mf$spans)), , drop = FALSE])
- |
-
-
- | 142 |
- 3x |
+
+ | 241 |
+ |
- merge_index_header <- get_merge_index(mf$spans[seq_len(nr_header), , drop = FALSE])
+ #' Apply padding to a `flextable` based on indentation levels.
|
- | 143 |
+ 242 |
|
-
+ #' This function applies padding to a `flextable` based on indentation levels provided as a vector.
|
-
- | 144 |
- 3x |
+
+ | 243 |
+ |
- ft <- merge_at_indice(ft, lst = merge_index_body, part = "body")
+ #' @noRd
|
-
- | 145 |
- 3x |
+
+ | 244 |
+ |
- ft <- merge_at_indice(ft, lst = merge_index_header, part = "header")
+ #' @keywords internal
|
-
- | 146 |
- 3x |
+
+ | 245 |
+ |
- ft <- flextable::align_text_col(ft, align = "center", header = TRUE)
+ padding_lst <- function(ft, indents) {
|
- | 147 |
- 3x |
+ 246 |
+ 4x |
- ft <- flextable::align(ft, i = seq_len(nrow(content)), j = 1, align = "left")
+ Reduce(function(ft, s) {
|
- | 148 |
- 3x |
+ 247 |
+ 131x |
- ft <- padding_lst(ft, mf$row_info$indent)
+ flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
|
- | 149 |
- 3x |
+ 248 |
+ 4x |
- ft <- flextable::padding(ft, padding.top = 1, padding.bottom = 1, part = "all")
+ }, seq_len(length(indents)), ft)
|
-
- | 150 |
- 3x |
+
+ | 249 |
+ |
- ft <- flextable::autofit(ft, add_h = 0)
+ }
|
- | 151 |
+ 250 |
|
|
-
- | 152 |
- 3x |
+
+ | 251 |
+ |
- width_vector <- c(
+ #' Divide text block into smaller blocks
|
-
- | 153 |
- 3x |
+
+ | 252 |
+ |
- dim(ft)$widths[1],
+ #'
|
-
- | 154 |
- 3x |
+
+ | 253 |
+ |
- rep(sum(dim(ft)$widths[-1]), length(dim(ft)$widths) - 1) / (ncol(mf$strings) - 1)
+ #' Split a text block into smaller blocks with a specified number of lines.
|
- | 155 |
+ 254 |
|
- )
+ #'
|
-
- | 156 |
- 3x |
+
+ | 255 |
+ |
- ft <- flextable::width(ft, width = width_vector)
+ #' A single character string containing a text block of multiple lines (separated by `\n`)
|
-
- | 157 |
- 3x |
+
+ | 256 |
+ |
- ft <- custom_theme(ft)
+ #' is split into multiple strings with n or less lines each.
|
- | 158 |
+ 257 |
|
-
+ #'
|
- | 159 |
+ 258 |
|
- # Add footers
+ #' @param block_text (`character`) string containing the input block of text
|
-
- | 160 |
- 3x |
+
+ | 259 |
+ |
- ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
+ #' @param n (`integer`) number of lines per block
|
-
- | 161 |
- 3x |
+
+ | 260 |
+ |
- flextable::as_chunk(mf$main_footer, props = flextable::fp_text_default(font.size = 8))
+ #'
|
- | 162 |
+ 261 |
|
- ))
+ #' @return
|
-
- | 163 |
- ! |
+
+ | 262 |
+ |
- if (length(mf$main_footer) > 0 && length(mf$prov_footer) > 0) ft <- flextable::add_footer_lines(ft, c("\n"))
+ #' List of character strings with up to `n` lines in each element.
|
-
- | 164 |
- 3x |
+
+ | 263 |
+ |
- ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
+ #'
|
-
- | 165 |
- 3x |
+
+ | 264 |
+ |
- flextable::as_chunk(mf$prov_footer, props = flextable::fp_text_default(font.size = 8))
+ #' @keywords internal
|
- | 166 |
+ 265 |
|
- ))
+ split_text_block <- function(x, n) {
|
- | 167 |
- 13x |
+ 266 |
+ 2x |
- } else if (inherits(content, "data.frame")) {
+ checkmate::assert_string(x)
|
- | 168 |
- 12x |
+ 267 |
+ 2x |
- ft <- flextable::flextable(content)
+ checkmate::assert_integerish(n, lower = 1L, len = 1L)
|
-
- | 169 |
- 12x |
+
+ | 268 |
+ |
- ft <- custom_theme(ft)
+
+ |
+
+
+ | 269 |
+ 2x |
+
+ lines <- strsplit(x, "\n")[[1]]
|
- | 170 |
+ 270 |
|
- } else {
+
|
- | 171 |
+ 271 |
+ 2x |
+
+ if (length(lines) <= n) {
+ |
+
+
+ | 272 |
1x |
- stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
+ return(list(x))
|
- | 172 |
+ 273 |
|
}
|
- | 173 |
+ 274 |
|
|
- | 174 |
- 15x |
-
- if (flextable::flextable_dim(ft)$widths > 10) {
- |
-
-
- | 175 |
- ! |
+ 275 |
+ 1x |
- pgwidth <- 10.5
+ nblocks <- ceiling(length(lines) / n)
|
-
- | 176 |
- ! |
+
+ | 276 |
+ 1x |
- width_vector <- dim(ft)$widths * pgwidth / flextable::flextable_dim(ft)$widths
+ ind <- rep(1:nblocks, each = n)[seq_along(lines)]
|
-
- | 177 |
- ! |
+
+ | 277 |
+ 1x |
- ft <- flextable::width(ft, width = width_vector)
+ unname(lapply(split(lines, ind), paste, collapse = "\n"))
|
- | 178 |
+ 278 |
|
- }
+ }
|
- | 179 |
+ 279 |
|
|
-
- | 180 |
- 15x |
-
- ft
- |
-
- | 181 |
+ 280 |
|
- }
+ #' Retrieve text details for global_knitr options
|
- | 182 |
+ 281 |
|
-
+ #' This function returns a character string describing the default settings for the global_knitr options.
|
- | 183 |
+ 282 |
|
- #' Apply a custom theme to a `flextable`
+ #' @noRd
|
- | 184 |
+ 283 |
|
- #' @noRd
+ #' @keywords internal
|
- | 185 |
+ 284 |
|
- #'
+ global_knitr_details <- function() {
|
-
- | 186 |
- |
+
+ | 285 |
+ ! |
- #' @keywords internal
+ paste0(
|
-
- | 187 |
- |
+
+ | 286 |
+ ! |
- custom_theme <- function(ft) {
+ c(
|
-
- | 188 |
- 16x |
+
+ | 287 |
+ ! |
- checkmate::assert_class(ft, "flextable")
+ " To access the default values for the `global_knitr` parameter,",
|
-
- | 189 |
- 16x |
+
+ | 288 |
+ ! |
- ft <- flextable::fontsize(ft, size = 8, part = "body")
+ " use `getOption('teal.reporter.global_knitr')`. These defaults include:",
|
-
- | 190 |
- 16x |
+
+ | 289 |
+ ! |
- ft <- flextable::bold(ft, part = "header")
+ " - `echo = TRUE`",
|
-
- | 191 |
- 16x |
+
+ | 290 |
+ ! |
- ft <- flextable::theme_booktabs(ft)
+ " - `tidy.opts = list(width.cutoff = 60)`",
|
-
- | 192 |
- 16x |
+
+ | 291 |
+ ! |
- ft <- flextable::hline(ft, border = flextable::fp_border_default(width = 1, color = "grey"))
+ " - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise"
|
-
- | 193 |
- 16x |
+
+ | 292 |
+ |
- ft <- flextable::border_outer(ft)
+ ),
|
-
- | 194 |
- 16x |
+
+ | 293 |
+ ! |
- ft
+ collapse = "\n"
|
- | 195 |
+ 294 |
|
- }
+ )
|
- | 196 |
+ 295 |
|
-
+ }
|
+
+
+
+
+
+
- | 197 |
+ 1 |
|
- #' Get the merge index for a single span.
+ #' @title `RcodeBlock`
|
- | 198 |
+ 2 |
|
- #' This function retrieves the merge index for a single span,
+ #' @docType class
|
- | 199 |
+ 3 |
|
- #' which is used in merging cells.
+ #' @description
|
- | 200 |
+ 4 |
|
- #' @noRd
+ #' Specialized `ContentBlock` designed to embed `R` code in reports.
|
- | 201 |
+ 5 |
|
#'
|
- | 202 |
+ 6 |
|
#' @keywords internal
|
- | 203 |
+ 7 |
|
- get_merge_index_single <- function(span) {
+ RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
|
-
- | 204 |
- 134x |
+
+ | 8 |
+ |
- ret <- list()
+ classname = "RcodeBlock",
|
-
- | 205 |
- 134x |
+
+ | 9 |
+ |
- j <- 1
+ inherit = ContentBlock,
|
-
- | 206 |
- 134x |
+
+ | 10 |
+ |
- while (j < length(span)) {
+ public = list(
|
-
- | 207 |
- 141x |
+
+ | 11 |
+ |
- if (span[j] != 1) {
+ #' @description Initialize a `RcodeBlock` object.
|
-
- | 208 |
- 3x |
+
+ | 12 |
+ |
- ret <- c(ret, list(seq(j, j + span[j] - 1)))
+ #'
|
- | 209 |
+ 13 |
|
- }
+ #' @details Returns a `RcodeBlock` object with no content and no parameters.
|
-
- | 210 |
- 141x |
+
+ | 14 |
+ |
- j <- j + span[j]
+ #'
|
- | 211 |
+ 15 |
|
- }
- |
-
-
- | 212 |
- 134x |
-
- return(ret)
+ #' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock`
|
- | 213 |
+ 16 |
|
- }
+ #' @param ... any `rmarkdown` `R` chunk parameter and it value.
|
- | 214 |
+ 17 |
|
-
+ #'
|
- | 215 |
+ 18 |
|
- #' Get the merge index for multiple spans.
+ #' @return Object of class `RcodeBlock`, invisibly.
|
- | 216 |
+ 19 |
|
- #' This function merges cells in a `flextable` at specified row and column indices.
+ #' @examples
|
- | 217 |
+ 20 |
|
- #' @noRd
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
|
- | 218 |
+ 21 |
|
- #'
+ #' block <- RcodeBlock$new()
|
- | 219 |
+ 22 |
|
- #' @keywords internal
+ #'
|
- | 220 |
+ 23 |
|
- get_merge_index <- function(spans) {
- |
-
-
- | 221 |
- 7x |
-
- ret <- lapply(seq_len(nrow(spans)), function(i) {
- |
-
-
- | 222 |
- 133x |
-
- ri <- spans[i, ]
+ initialize = function(content = character(0), ...) {
|
- | 223 |
- 133x |
+ 24 |
+ 74x |
- r <- get_merge_index_single(ri)
+ super$set_content(content)
|
- | 224 |
- 133x |
+ 25 |
+ 74x |
- lapply(r, function(s) {
+ self$set_params(list(...))
|
- | 225 |
- 2x |
+ 26 |
+ 74x |
- list(j = s, i = i)
+ invisible(self)
|
- | 226 |
+ 27 |
|
- })
+ },
|
- | 227 |
+ 28 |
|
- })
- |
-
-
- | 228 |
- 7x |
-
- unlist(ret, recursive = FALSE, use.names = FALSE)
+ #' @description Sets the parameters of this `RcodeBlock`.
|
- | 229 |
+ 29 |
|
- }
+ #'
|
- | 230 |
+ 30 |
|
-
+ #' @details Configures `rmarkdown` chunk parameters for the `R` code block,
|
- | 231 |
+ 31 |
|
- #' Merge cells in a `flextable` at specified indices
+ #' influencing its rendering and execution behavior.
|
- | 232 |
+ 32 |
|
- #' @noRd
+ #'
|
- | 233 |
+ 33 |
|
- #'
+ #' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
|
- | 234 |
+ 34 |
|
- #' @keywords internal
+ #'
|
- | 235 |
+ 35 |
|
- merge_at_indice <- function(ft, lst, part) {
- |
-
-
- | 236 |
- 7x |
-
- Reduce(function(ft, ij) {
- |
-
-
- | 237 |
- 2x |
-
- flextable::merge_at(ft, i = ij$i, j = ij$j, part = part)
- |
-
-
- | 238 |
- 7x |
-
- }, lst, ft)
+ #' @return `self`, invisibly.
|
- | 239 |
+ 36 |
|
- }
+ #' @examples
|
- | 240 |
+ 37 |
|
-
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
|
- | 241 |
+ 38 |
|
- #' Apply padding to a `flextable` based on indentation levels.
+ #' block <- RcodeBlock$new()
|
- | 242 |
+ 39 |
|
- #' This function applies padding to a `flextable` based on indentation levels provided as a vector.
+ #' block$set_params(list(echo = TRUE))
|
- | 243 |
+ 40 |
|
- #' @noRd
+ #'
|
- | 244 |
+ 41 |
|
- #'
+ set_params = function(params) {
|
-
- | 245 |
- |
+
+ | 42 |
+ 132x |
- #' @keywords internal
+ checkmate::assert_list(params, names = "named")
|
-
- | 246 |
- |
+
+ | 43 |
+ 132x |
- padding_lst <- function(ft, indents) {
+ checkmate::assert_subset(names(params), self$get_available_params())
|
- | 247 |
- 4x |
+ 44 |
+ 132x |
- Reduce(function(ft, s) {
+ private$params <- params
|
- | 248 |
- 131x |
+ 45 |
+ 132x |
- flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
+ invisible(self)
|
-
- | 249 |
- 4x |
+
+ | 46 |
+ |
- }, seq_len(length(indents)), ft)
+ },
|
- | 250 |
+ 47 |
|
- }
+ #' @description Get the parameters of this `RcodeBlock`.
|
- | 251 |
+ 48 |
|
-
+ #'
|
- | 252 |
+ 49 |
|
- #' Split a text block into smaller blocks with a specified number of lines.
+ #' @return `character` the parameters of this `RcodeBlock`.
|
- | 253 |
+ 50 |
|
- #'
+ #' @examples
|
- | 254 |
+ 51 |
|
- #' Divide text block into smaller blocks.
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
|
- | 255 |
+ 52 |
|
- #'
+ #' block <- RcodeBlock$new()
|
- | 256 |
+ 53 |
|
- #' A single character string containing a text block of multiple lines (separated by `\n`)
+ #' block$get_params()
|
- | 257 |
+ 54 |
|
- #' is split into multiple strings with n or less lines each.
+ #'
|
- | 258 |
+ 55 |
|
- #'
+ get_params = function() {
+ |
+
+
+ | 56 |
+ 3x |
+
+ private$params
|
- | 259 |
+ 57 |
|
- #' @param block_text `character` string containing the input block of text
+ },
|
- | 260 |
+ 58 |
|
- #' @param n `integer` number of lines per block
+ #' @description Get available array of parameters available to this `RcodeBlock`.
|
- | 261 |
+ 59 |
|
- #'
+ #'
|
- | 262 |
+ 60 |
|
- #' @return
+ #' @return A `character` array of parameters.
|
- | 263 |
+ 61 |
|
- #' List of character strings with up to `n` lines in each element.
+ #' @examples
|
- | 264 |
+ 62 |
|
- #'
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
|
- | 265 |
+ 63 |
|
- #' @keywords internal
+ #' block <- RcodeBlock$new()
|
- | 266 |
+ 64 |
|
- split_text_block <- function(x, n) {
+ #' block$get_available_params()
|
-
- | 267 |
- 2x |
+
+ | 65 |
+ |
- checkmate::assert_string(x)
+ #'
+ |
+
+
+ | 66 |
+ |
+
+ get_available_params = function() {
|
- | 268 |
- 2x |
+ 67 |
+ 5x |
- checkmate::assert_integerish(n, lower = 1L, len = 1L)
+ names(knitr::opts_chunk$get())
|
- | 269 |
+ 68 |
|
-
+ },
|
-
- | 270 |
- 2x |
+
+ | 69 |
+ |
- lines <- strsplit(x, "\n")[[1]]
+ #' @description Create the `RcodeBlock` from a list.
|
- | 271 |
+ 70 |
|
-
+ #'
|
-
- | 272 |
- 2x |
+
+ | 71 |
+ |
- if (length(lines) <= n) {
+ #' @param x (`named list`) with two fields `text` and `params`.
|
-
- | 273 |
- 1x |
+
+ | 72 |
+ |
- return(list(x))
+ #' Use the `get_available_params` method to get all possible parameters.
|
- | 274 |
+ 73 |
|
- }
+ #'
|
- | 275 |
+ 74 |
|
-
+ #' @return `self`, invisibly.
+ |
+
+
+ | 75 |
+ |
+
+ #' @examples
+ |
+
+
+ | 76 |
+ |
+
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
+ |
+
+
+ | 77 |
+ |
+
+ #' block <- RcodeBlock$new()
+ |
+
+
+ | 78 |
+ |
+
+ #' block$from_list(list(text = "sth", params = list()))
+ |
+
+
+ | 79 |
+ |
+
+ #'
+ |
+
+
+ | 80 |
+ |
+
+ from_list = function(x) {
|
- | 276 |
- 1x |
+ 81 |
+ 3x |
- nblocks <- ceiling(length(lines) / n)
+ checkmate::assert_list(x)
|
- | 277 |
- 1x |
+ 82 |
+ 3x |
- ind <- rep(1:nblocks, each = n)[seq_along(lines)]
+ checkmate::assert_names(names(x), must.include = c("text", "params"))
|
- | 278 |
- 1x |
+ 83 |
+ 3x |
- unname(lapply(split(lines, ind), paste, collapse = "\n"))
+ self$set_content(x$text)
+ |
+
+
+ | 84 |
+ 3x |
+
+ self$set_params(x$params)
+ |
+
+
+ | 85 |
+ 3x |
+
+ invisible(self)
|
- | 279 |
+ 86 |
|
- }
+ },
|
- | 280 |
+ 87 |
|
-
+ #' @description Convert the `RcodeBlock` to a list.
|
- | 281 |
+ 88 |
|
- #' Retrieve text details for global_knitr options
+ #'
|
- | 282 |
+ 89 |
|
- #' This function returns a character string describing the default settings for the global_knitr options.
+ #' @return `named list` with a text and `params`.
|
- | 283 |
+ 90 |
|
- #' @noRd
+ #' @examples
|
- | 284 |
+ 91 |
|
- #'
+ #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
|
- | 285 |
+ 92 |
|
- #' @keywords internal
+ #' block <- RcodeBlock$new()
|
- | 286 |
+ 93 |
|
- global_knitr_details <- function() {
+ #' block$to_list()
|
-
- | 287 |
- ! |
+
+ | 94 |
+ |
- paste0(
+ #'
|
-
- | 288 |
- ! |
+
+ | 95 |
+ |
- c(
+ to_list = function() {
|
-
- | 289 |
- ! |
+
+ | 96 |
+ 3x |
- " To access the default values for the `global_knitr` parameter,",
+ list(text = self$get_content(), params = self$get_params())
|
-
- | 290 |
- ! |
+
+ | 97 |
+ |
- " use `getOption('teal.reporter.global_knitr')`. These defaults include:",
+ }
|
-
- | 291 |
- ! |
+
+ | 98 |
+ |
- " - `echo = TRUE`",
+ ),
|
-
- | 292 |
- ! |
+
+ | 99 |
+ |
- " - `tidy.opts = list(width.cutoff = 60)`",
+ private = list(
|
-
- | 293 |
- ! |
+
+ | 100 |
+ |
- " - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise"
+ params = list()
|
- | 294 |
+ 101 |
|
- ),
+ ),
|
-
- | 295 |
- ! |
+
+ | 102 |
+ |
- collapse = "\n"
+ lock_objects = TRUE,
|
- | 296 |
+ 103 |
|
- )
+ lock_class = TRUE
|
- | 297 |
+ 104 |
|
- }
+ )
|
-
+
| 1 |
|
- #' @title quoted string for `yaml`
+ #' @title `ContentBlock`: A building block for report content
|
| 2 |
|
- #' @description add quoted attribute for `yaml` package
+ #' @docType class
|
| 3 |
|
- #' @param x `character`
+ #' @description This class represents a basic content unit in a report,
|
| 4 |
|
- #' @keywords internal
+ #' such as text, images, or other multimedia elements.
|
| 5 |
|
- #' @examples
+ #' It serves as a foundation for constructing complex report structures.
|
| 6 |
|
- #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
+ #'
|
| 7 |
|
- #' yaml <- list(
+ #' @keywords internal
|
| 8 |
|
- #' author = yaml_quoted("NEST"),
+ ContentBlock <- R6::R6Class( # nolint: object_name_linter.
|
| 9 |
|
- #' title = yaml_quoted("Report"),
+ classname = "ContentBlock",
|
| 10 |
|
- #' date = yaml_quoted("07/04/2019"),
+ public = list(
|
| 11 |
|
- #' output = list(pdf_document = list(keep_tex = TRUE))
+ #' @description Initialize a `ContentBlock` object.
|
| 12 |
|
- #' )
+ #'
|
| 13 |
|
- #' yaml::as.yaml(yaml)
+ #' @details Returns a `ContentBlock` object with no content and the default style.
|
| 14 |
|
- yaml_quoted <- function(x) {
+ #'
|
-
+
| 15 |
- 2x |
+ |
- attr(x, "quoted") <- TRUE
+ #' @return Object of class `ContentBlock`, invisibly.
|
-
+
| 16 |
- 2x |
+ |
- x
+ #' @examples
|
| 17 |
|
- }
+ #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
|
| 18 |
|
-
+ #' ContentBlock$new()
|
| 19 |
|
- #' @title wrap a `yaml` string to the `markdown` header
+ #'
|
| 20 |
|
- #' @description wrap a `yaml` string to the `markdown` header.
+ initialize = function() {
|
-
+
| 21 |
- |
+ 17x |
- #' @param x `character` `yaml` formatted string.
+ private$content <- character(0)
|
-
+
| 22 |
- |
+ 17x |
- #' @keywords internal
+ invisible(self)
|
| 23 |
|
- #' @examples
+ },
|
| 24 |
|
- #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
+ #' @description Sets content of this `ContentBlock`.
|
| 25 |
|
- #' yaml <- list(
+ #'
|
| 26 |
|
- #' author = yaml_quoted("NEST"),
+ #' @param content (`character(0)` or `character(1)`) string or file path assigned to this `ContentBlock`
|
| 27 |
|
- #' title = yaml_quoted("Report"),
+ #'
|
| 28 |
|
- #' date = yaml_quoted("07/04/2019"),
+ #' @return `self`, invisibly.
|
| 29 |
|
- #' output = list(pdf_document = list(keep_tex = TRUE))
+ #' @examples
|
| 30 |
|
- #' )
+ #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
|
| 31 |
|
- #' md_header <- getFromNamespace("md_header", "teal.reporter")
+ #' block <- ContentBlock$new()
|
| 32 |
|
- #' md_header(yaml::as.yaml(yaml))
+ #' block$set_content("Base64 encoded picture")
|
| 33 |
|
- md_header <- function(x) {
+ #'
|
-
+
| 34 |
- 14x |
+ |
- paste0("---\n", x, "---\n")
+ set_content = function(content) {
|
-
+
| 35 |
- |
+ 361x |
- }
+ checkmate::assert_character(content, min.len = 0, max.len = 1)
|
-
+
| 36 |
- |
+ 358x |
-
+ private$content <- content
|
-
+
| 37 |
- |
+ 358x |
- #' @title Convert a character of a `yaml` boolean to a logical value
+ invisible(self)
|
| 38 |
|
- #' @description convert a character of a `yaml` boolean to a logical value.
+ },
|
| 39 |
|
- #' @param input `character`
+ #' @description Retrieves the content assigned to this block.
|
| 40 |
|
- #' @param name `charcter`
+ #'
|
| 41 |
|
- #' @param pos_logi `character` vector of `yaml` values which should be treated as `TRUE`.
+ #' @return `character` string or file path assigned to this `ContentBlock`.
|
| 42 |
|
- #' @param neg_logi `character` vector of `yaml` values which should be treated as `FALSE`.
+ #' @examples
|
| 43 |
|
- #' @param silent `logical` if to suppress the messages and warnings.
+ #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
|
| 44 |
|
- #' @return `input` argument or the appropriate `logical` value.
+ #' block <- ContentBlock$new()
|
| 45 |
|
- #' @keywords internal
+ #' block$get_content()
|
| 46 |
|
- #' @examples
+ #'
|
| 47 |
|
- #'
+ get_content = function() {
|
-
+
| 48 |
- |
+ 266x |
- #' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter")
+ private$content
|
| 49 |
|
- #' conv_str_logi("TRUE")
+ },
|
| 50 |
|
- #' conv_str_logi("True")
+ #' @description Create the `ContentBlock` from a list.
|
| 51 |
|
- #'
+ #'
|
| 52 |
|
- #' conv_str_logi("off")
+ #' @param x (`named list`) with two fields `text` and `style`.
|
| 53 |
|
- #' conv_str_logi("n")
+ #' Use the `get_available_styles` method to get all possible styles.
|
| 54 |
|
- #'
+ #'
|
| 55 |
|
- #' conv_str_logi("sth")
+ #' @return `self`, invisibly.
|
| 56 |
|
- conv_str_logi <- function(input,
+ from_list = function(x) {
|
-
+
| 57 |
- |
+ ! |
- name = "",
+ invisible(self)
|
| 58 |
|
- pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"),
+ },
|
| 59 |
|
- neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"),
+ #' @description Convert the `ContentBlock` to a list.
|
| 60 |
|
- silent = TRUE) {
+ #'
|
-
+
| 61 |
- 18x |
+ |
- checkmate::assert_string(input)
+ #' @return `named list` with a text and style.
|
-
+
| 62 |
- 17x |
+ |
- checkmate::assert_string(name)
+ to_list = function() {
|
-
+
| 63 |
- 17x |
+ ! |
- checkmate::assert_character(pos_logi)
+ list()
|
-
+
| 64 |
- 17x |
+ |
- checkmate::assert_character(neg_logi)
+ }
|
-
+
| 65 |
- 17x |
+ |
- checkmate::assert_flag(silent)
+ ),
|
| 66 |
|
-
+ private = list(
|
-
+
| 67 |
- 17x |
+ |
- all_logi <- c(pos_logi, neg_logi)
+ content = character(0),
|
-
+
| 68 |
- 17x |
+ |
- if (input %in% all_logi) {
+ # @description The copy constructor.
|
-
+
| 69 |
- 15x |
+ |
- if (isFALSE(silent)) {
+ #
|
-
+
| 70 |
- ! |
+ |
- message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
+ # @param name (`character(1)`) the name of the field
|
| 71 |
|
- }
+ # @param value the value assigned to the field
|
-
+
| 72 |
- 15x |
+ |
- input %in% pos_logi
+ #
|
| 73 |
|
- } else {
+ # @return the value of the copied field
|
-
+
| 74 |
- 2x |
+ |
- input
+ deep_clone = function(name, value) {
|
-
+
| 75 |
- |
+ 168x |
- }
+ if (name == "content" && checkmate::test_file_exists(value)) {
|
-
+
| 76 |
- |
+ 7x |
- }
+ extension <- ""
|
-
+
| 77 |
- |
+ 7x |
-
+ split <- strsplit(basename(value), split = "\\.")
|
| 78 |
|
- #' @title Get document output types from the `rmarkdown` package
+ # The below ensures no extension is found for files such as this: .gitignore but is found for files like
|
| 79 |
|
- #'
+ # .gitignore.txt
|
-
+
| 80 |
- |
+ 7x |
- #' @description `r lifecycle::badge("experimental")`
+ if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
|
-
+
| 81 |
- |
+ 5x |
- #' get document output types from the `rmarkdown` package.
+ extension <- split[[1]][length(split[[1]])]
|
-
+
| 82 |
- |
+ 5x |
- #' @return `character` vector.
+ extension <- paste0(".", extension)
|
| 83 |
|
- #' @export
+ }
|
-
+
| 84 |
- |
+ 7x |
- #' @examples
+ copied_file <- tempfile(fileext = extension)
|
-
+
| 85 |
- |
+ 7x |
- #' rmd_outputs()
+ file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
|
-
+
| 86 |
- |
+ 7x |
- rmd_outputs <- function() {
+ copied_file
|
-
+
| 87 |
- 18x |
+ |
- rmarkdown_namespace <- asNamespace("rmarkdown")
+ } else {
|
| 88 |
- 18x |
+ 161x |
- ls(rmarkdown_namespace)[grep("_document|_presentation", ls(rmarkdown_namespace))]
+ value
|
| 89 |
|
- }
+ }
|
| 90 |
|
-
+ }
|
| 91 |
|
- #' @title Get document output arguments from the `rmarkdown` package
+ ),
|
| 92 |
|
- #'
+ lock_objects = TRUE,
|
| 93 |
|
- #' @description `r lifecycle::badge("experimental")`
+ lock_class = TRUE
|
| 94 |
|
- #' get document output arguments from the `rmarkdown` package
+ )
|
+
+
+
+
+
+
- | 95 |
+ 1 |
|
- #' @param output_name `character` `rmarkdown` output name.
+ #' @title `Archiver`: Base class for data archiving
|
- | 96 |
+ 2 |
|
- #' @param default_values `logical` if to return a default values for each argument.
+ #' @docType class
|
- | 97 |
+ 3 |
|
- #' @export
+ #' @description
|
- | 98 |
+ 4 |
|
- #' @examples
+ #' A base `R6` class for implementing data archiving functionality.
|
- | 99 |
+ 5 |
|
- #' rmd_output_arguments("pdf_document")
+ #'
|
- | 100 |
+ 6 |
|
- #' rmd_output_arguments("pdf_document", TRUE)
+ #' @keywords internal
|
- | 101 |
+ 7 |
|
- rmd_output_arguments <- function(output_name, default_values = FALSE) {
- |
-
-
- | 102 |
- 17x |
-
- checkmate::assert_string(output_name)
- |
-
-
- | 103 |
- 17x |
-
- checkmate::assert_subset(output_name, rmd_outputs())
+ Archiver <- R6::R6Class( # nolint: object_name_linter.
|
- | 104 |
+ 8 |
|
-
- |
-
-
- | 105 |
- 16x |
-
- rmarkdown_namespace <- asNamespace("rmarkdown")
+ classname = "Archiver",
|
-
- | 106 |
- 16x |
+
+ | 9 |
+ |
- if (default_values) {
+ public = list(
|
-
- | 107 |
- 14x |
+
+ | 10 |
+ |
- formals(rmarkdown_namespace[[output_name]])
+ #' @description Initialize an `Archiver` object.
|
- | 108 |
+ 11 |
|
- } else {
+ #'
|
-
- | 109 |
- 2x |
+
+ | 12 |
+ |
- names(formals(rmarkdown_namespace[[output_name]]))
+ #' @return Object of class `Archiver`, invisibly.
|
- | 110 |
+ 13 |
|
- }
+ #' @examples
|
- | 111 |
+ 14 |
|
- }
+ #' Archiver <- getFromNamespace("Archiver", "teal.reporter")
|
- | 112 |
+ 15 |
|
-
+ #' Archiver$new()
|
- | 113 |
+ 16 |
|
- #' @title Parse a Named List to the `Rmd` `yaml` Header
+ initialize = function() {
|
-
- | 114 |
- |
+
+ | 17 |
+ 3x |
- #' @description `r lifecycle::badge("experimental")`
+ invisible(self)
|
- | 115 |
+ 18 |
|
- #' parse a named list to the `Rmd` `yaml` header, so the developer gets automatically tabulated `Rmd` `yaml` header.
+ },
|
- | 116 |
+ 19 |
|
- #' Only a non nested (flat) list will be processed,
+ #' @description Finalizes an `Archiver` object.
|
- | 117 |
+ 20 |
|
- #' where as a nested list is directly processed with the [`yaml::as.yaml`] function.
+ finalize = function() {
|
- | 118 |
+ 21 |
|
- #' All `Rmd` `yaml` header fields from the vector are supported,
+ # destructor
|
- | 119 |
+ 22 |
|
- #' `c("author", "date", "title", "subtitle", "abstract", "keywords", "subject", "description", "category", "lang")`.
+ },
|
- | 120 |
+ 23 |
|
- #' Moreover all `output`field types in the `rmarkdown` package and their arguments are supported.
+ #' @description Reads data from the `Archiver`.
|
- | 121 |
+ 24 |
|
- #' @param input_list `named list` non nested with slots names and their values compatible with `Rmd` `yaml` header.
+ #' Pure virtual method that should be implemented by inherited classes.
|
- | 122 |
+ 25 |
|
- #' @param as_header `logical` optionally wrap with result with the internal `md_header()`, default `TRUE`.
+ read = function() {
|
- | 123 |
+ 26 |
|
- #' @param convert_logi `logical` convert a character values to logical,
+ # returns Reporter instance
|
-
- | 124 |
- |
+
+ | 27 |
+ 1x |
- #' if they are recognized as quoted `yaml` logical values , default `TRUE`.
+ stop("Pure virtual method.")
|
- | 125 |
+ 28 |
|
- #' @param multi_output `logical` multi `output` slots in the `input` argument, default `FALSE`.
+ },
|
- | 126 |
+ 29 |
|
- #' @param silent `logical` suppress messages and warnings, default `FALSE`.
+ #' @description Writes data to the `Archiver`.
|
- | 127 |
+ 30 |
|
- #' @return `character` with `rmd_yaml_header` class,
+ #' Pure virtual method that should be implemented by inherited classes.
|
- | 128 |
+ 31 |
|
- #' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`.
+ write = function() {
|
-
- | 129 |
- |
+
+ | 32 |
+ 1x |
- #' @export
+ stop("Pure virtual method.")
|
- | 130 |
+ 33 |
|
- #' @examples
+ }
|
- | 131 |
+ 34 |
|
- #' # nested so using yaml::as.yaml directly
+ ),
|
- | 132 |
+ 35 |
|
- #' as_yaml_auto(
+ lock_objects = TRUE,
|
- | 133 |
+ 36 |
|
- #' list(author = "", output = list(pdf_document = list(toc = TRUE)))
+ lock_class = TRUE
|
- | 134 |
+ 37 |
|
- #' )
+ )
|
- | 135 |
+ 38 |
|
- #'
+
|
- | 136 |
+ 39 |
|
- #' # auto parsing for a flat list, like shiny input
+ #' @title `FileArchiver`: A File-based `Archiver`
|
- | 137 |
+ 40 |
|
- #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
+ #' @docType class
|
- | 138 |
+ 41 |
|
- #' as_yaml_auto(input)
+ #' @description
|
- | 139 |
+ 42 |
|
- #'
+ #' Inherits from `Archiver` to provide file-based archiving functionality.
|
- | 140 |
+ 43 |
|
- #' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
+ #' Manages an output directory for storing archived data.
|
- | 141 |
+ 44 |
|
#'
|
- | 142 |
+ 45 |
|
- #' as_yaml_auto(list(
+ #' @keywords internal
|
- | 143 |
+ 46 |
|
- #' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
+ FileArchiver <- R6::R6Class( # nolint: object_name_linter.
|
- | 144 |
+ 47 |
|
- #' wrong = 2
+ classname = "FileArchiver",
|
- | 145 |
+ 48 |
|
- #' ))
+ inherit = Archiver,
|
- | 146 |
+ 49 |
|
- #'
+ public = list(
|
- | 147 |
+ 50 |
|
- #' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
+ #' @description Initialize a `FileArchiver` object with a unique output directory.
|
- | 148 |
+ 51 |
|
- #' silent = TRUE
+ #'
|
- | 149 |
+ 52 |
|
- #' )
+ #' @return Object of class `FileArchiver`, invisibly.
|
- | 150 |
+ 53 |
|
- #'
+ #' @examples
|
- | 151 |
+ 54 |
|
- #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
+ #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
|
- | 152 |
+ 55 |
|
- #' as_yaml_auto(input)
+ #' FileArchiver$new()
|
- | 153 |
+ 56 |
|
- #' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
+ initialize = function() {
|
-
- | 154 |
- |
-
- #' as_yaml_auto(input, silent = TRUE)
+ |
+ | 57 |
+ 10x |
+
+ tmp_dir <- tempdir()
|
-
- | 155 |
- |
+
+ | 58 |
+ 10x |
- #' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
+ output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
|
-
- | 156 |
- |
+
+ | 59 |
+ 10x |
- #'
+ dir.create(path = output_dir)
|
-
- | 157 |
- |
+
+ | 60 |
+ 10x |
- #' as_yaml_auto(
+ private$output_dir <- output_dir
|
-
- | 158 |
- |
+
+ | 61 |
+ 10x |
- #' list(
+ invisible(self)
|
- | 159 |
+ 62 |
|
- #' author = "", output = "pdf_document",
+ },
|
- | 160 |
+ 63 |
|
- #' output = "html_document", toc = TRUE, keep_tex = TRUE
+ #' @description Finalizes a `FileArchiver` object.
|
- | 161 |
+ 64 |
|
- #' ),
+ #' Cleans up by removing the output directory and its contents.
|
- | 162 |
+ 65 |
|
- #' multi_output = TRUE
+ finalize = function() {
|
-
- | 163 |
- |
+
+ | 66 |
+ 10x |
- #' )
+ unlink(private$output_dir, recursive = TRUE)
|
- | 164 |
+ 67 |
|
- #' as_yaml_auto(
+ },
|
- | 165 |
+ 68 |
|
- #' list(
+ #' @description Get `output_dir` field.
|
- | 166 |
+ 69 |
|
- #' author = "", output = "pdf_document",
+ #'
|
- | 167 |
+ 70 |
|
- #' output = "html_document", toc = "True", keep_tex = TRUE
+ #' @return `character` a `output_dir` field path.
|
- | 168 |
+ 71 |
|
- #' ),
+ #' @examples
|
- | 169 |
+ 72 |
|
- #' multi_output = TRUE
+ #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
|
- | 170 |
+ 73 |
|
- #' )
+ #' FileArchiver$new()$get_output_dir()
|
- | 171 |
+ 74 |
|
- as_yaml_auto <- function(input_list,
+ get_output_dir = function() {
+ |
+
+
+ | 75 |
+ 9x |
+
+ private$output_dir
|
- | 172 |
+ 76 |
|
- as_header = TRUE,
+ }
|
- | 173 |
+ 77 |
|
- convert_logi = TRUE,
+ ),
|
- | 174 |
+ 78 |
|
- multi_output = FALSE,
+ private = list(
|
- | 175 |
+ 79 |
|
- silent = FALSE) {
+ output_dir = character(0)
|
-
- | 176 |
- 16x |
+
+ | 80 |
+ |
- checkmate::assert_logical(as_header)
+ )
|
-
- | 177 |
- 16x |
+
+ | 81 |
+ |
- checkmate::assert_logical(convert_logi)
+ )
|
-
- | 178 |
- 16x |
+
+ | 82 |
+ |
- checkmate::assert_logical(silent)
+
|
-
- | 179 |
- 16x |
+
+ | 83 |
+ |
- checkmate::assert_logical(multi_output)
+ #' @title `JSONArchiver`: A `JSON`-based `Archiver`
|
- | 180 |
+ 84 |
|
-
+ #' @docType class
|
-
- | 181 |
- 16x |
+
+ | 85 |
+ |
- if (multi_output) {
+ #' @description
|
-
- | 182 |
- 1x |
+
+ | 86 |
+ |
- checkmate::assert_list(input_list, names = "named")
+ #' Inherits from `FileArchiver` to implement `JSON`-based archiving functionality.
|
- | 183 |
+ 87 |
|
- } else {
+ #' Convert `Reporter` instances to and from `JSON` format.
|
-
- | 184 |
- 15x |
+
+ | 88 |
+ |
- checkmate::assert_list(input_list, names = "unique")
+ #'
|
- | 185 |
+ 89 |
|
- }
+ #' @keywords internal
|
- | 186 |
+ 90 |
|
-
+ JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
|
-
- | 187 |
- 13x |
+
+ | 91 |
+ |
- is_nested <- function(x) any(unlist(lapply(x, is.list)))
+ classname = "JSONArchiver",
|
-
- | 188 |
- 13x |
+
+ | 92 |
+ |
- if (is_nested(input_list)) {
+ inherit = FileArchiver,
|
-
- | 189 |
- 2x |
+
+ | 93 |
+ |
- result <- input_list
+ public = list(
|
- | 190 |
+ 94 |
|
- } else {
+ #' @description Write a `Reporter` instance in `JSON` file.
|
-
- | 191 |
- 11x |
+
+ | 95 |
+ |
- result <- list()
+ #' Serializes a given `Reporter` instance and saves it in the `Archiver`'s output directory,
|
-
- | 192 |
- 11x |
+
+ | 96 |
+ |
- input_nams <- names(input_list)
+ #' to this `JSONArchiver` object.
|
- | 193 |
+ 97 |
|
-
+ #'
|
- | 194 |
+ 98 |
|
- # top fields
+ #' @param reporter (`Reporter`) instance.
|
-
- | 195 |
- 11x |
+
+ | 99 |
+ |
- top_fields <- c(
+ #'
|
-
- | 196 |
- 11x |
+
+ | 100 |
+ |
- "author", "date", "title", "subtitle", "abstract",
+ #' @return `self`.
|
-
- | 197 |
- 11x |
+
+ | 101 |
+ |
- "keywords", "subject", "description", "category", "lang"
+ #' @examples
|
- | 198 |
+ 102 |
|
- )
+ #' library(ggplot2)
|
-
- | 199 |
- 11x |
-
- for (itop in top_fields) {
- |
-
-
- | 200 |
- 110x |
-
- if (itop %in% input_nams) {
- |
-
-
- | 201 |
- 20x |
-
- result[[itop]] <- switch(itop,
- |
-
-
- | 202 |
- 20x |
+
+ | 103 |
+ |
- date = as.character(input_list[[itop]]),
+ #'
|
-
- | 203 |
- 20x |
+
+ | 104 |
+ |
- input_list[[itop]]
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
- | 204 |
+ 105 |
|
- )
+ #' card1 <- ReportCard$new()
|
- | 205 |
+ 106 |
|
- }
+ #'
|
- | 206 |
+ 107 |
|
- }
+ #' card1$append_text("Header 2 text", "header2")
|
- | 207 |
+ 108 |
|
-
+ #' card1$append_text("A paragraph of default text", "header2")
|
- | 208 |
+ 109 |
|
- # output field
+ #' card1$append_plot(
|
-
- | 209 |
- 11x |
+
+ | 110 |
+ |
- doc_types <- unlist(input_list[input_nams == "output"])
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
-
- | 210 |
- 11x |
+
+ | 111 |
+ |
- if (length(doc_types)) {
+ #' )
|
-
- | 211 |
- 11x |
+
+ | 112 |
+ |
- for (dtype in doc_types) {
+ #'
|
-
- | 212 |
- 12x |
+
+ | 113 |
+ |
- doc_type_args <- rmd_output_arguments(dtype, TRUE)
+ #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
|
-
- | 213 |
- 12x |
+
+ | 114 |
+ |
- doc_type_args_nams <- names(doc_type_args)
+ #' reporter <- Reporter$new()
|
-
- | 214 |
- 12x |
+
+ | 115 |
+ |
- any_output_arg <- any(input_nams %in% doc_type_args_nams)
+ #' reporter$append_cards(list(card1))
|
- | 215 |
+ 116 |
|
-
+ #'
|
-
- | 216 |
- 12x |
+
+ | 117 |
+ |
- not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
+ #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
|
-
- | 217 |
- 12x |
+
+ | 118 |
+ |
- if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
+ #' archiver <- JSONArchiver$new()
|
-
- | 218 |
- 1x |
+
+ | 119 |
+ |
- warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
+ #' archiver$write(reporter)
|
- | 219 |
+ 120 |
|
- }
+ #' archiver$get_output_dir()
|
- | 220 |
+ 121 |
|
-
+ write = function(reporter) {
|
- | 221 |
- 12x |
+ 122 |
+ 1x |
- if (any_output_arg) {
+ checkmate::assert_class(reporter, "Reporter")
|
- | 222 |
- 11x |
+ 123 |
+ 1x |
- doc_list <- list()
+ unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
|
- | 223 |
- 11x |
+ 124 |
+ 1x |
- doc_list[[dtype]] <- list()
+ reporter$to_jsondir(private$output_dir)
|
- | 224 |
- 11x |
+ 125 |
+ 1x |
- for (e in intersect(input_nams, doc_type_args_nams)) {
+ self
|
-
- | 225 |
- 17x |
+
+ | 126 |
+ |
- if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
+ },
|
-
- | 226 |
- 1x |
+
+ | 127 |
+ |
- pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
+ #' @description Read a `Reporter` instance from a `JSON` file.
|
-
- | 227 |
- 1x |
+
+ | 128 |
+ |
- neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
+ #' Converts a `Reporter` instance from the `JSON` file in the `JSONArchiver`'s output directory.
|
-
- | 228 |
- 1x |
+
+ | 129 |
+ |
- all_logi <- c(pos_logi, neg_logi)
+ #'
|
-
- | 229 |
- 1x |
+
+ | 130 |
+ |
- if (input_list[[e]] %in% all_logi && convert_logi) {
+ #' @param path (`character(1)`) a path to the directory with all proper files.
|
-
- | 230 |
- 1x |
+
+ | 131 |
+ |
- input_list[[e]] <- conv_str_logi(input_list[[e]], e,
+ #'
|
-
- | 231 |
- 1x |
+
+ | 132 |
+ |
- pos_logi = pos_logi,
+ #' @return `Reporter` instance.
|
-
- | 232 |
- 1x |
+
+ | 133 |
+ |
- neg_logi = neg_logi, silent = silent
+ #' @examples
|
- | 233 |
+ 134 |
|
- )
+ #' library(ggplot2)
|
- | 234 |
+ 135 |
|
- }
+ #'
|
- | 235 |
+ 136 |
|
- }
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
- | 236 |
+ 137 |
|
-
+ #' card1 <- ReportCard$new()
|
-
- | 237 |
- 17x |
+
+ | 138 |
+ |
- doc_list[[dtype]][[e]] <- input_list[[e]]
+ #'
|
- | 238 |
+ 139 |
|
- }
- |
-
-
- | 239 |
- 11x |
-
- result[["output"]] <- append(result[["output"]], doc_list)
+ #' card1$append_text("Header 2 text", "header2")
|
- | 240 |
+ 140 |
|
- } else {
+ #' card1$append_text("A paragraph of default text", "header2")
|
-
- | 241 |
- 1x |
+
+ | 141 |
+ |
- result[["output"]] <- append(result[["output"]], input_list[["output"]])
+ #' card1$append_plot(
|
- | 242 |
+ 142 |
|
- }
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
- | 243 |
+ 143 |
|
- }
+ #' )
|
- | 244 |
+ 144 |
|
- }
+ #'
|
- | 245 |
+ 145 |
|
- }
+ #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
|
- | 246 |
+ 146 |
|
-
+ #' reporter <- Reporter$new()
|
-
- | 247 |
- 13x |
+
+ | 147 |
+ |
- result <- yaml::as.yaml(result)
+ #' reporter$append_cards(list(card1))
|
-
- | 248 |
- 13x |
+
+ | 148 |
+ |
- if (as_header) {
+ #'
|
-
- | 249 |
- 12x |
+
+ | 149 |
+ |
- result <- md_header(result)
+ #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
|
- | 250 |
+ 150 |
|
- }
+ #' archiver <- JSONArchiver$new()
|
-
- | 251 |
- 13x |
+
+ | 151 |
+ |
- structure(result, class = "rmd_yaml_header")
+ #' archiver$write(reporter)
|
- | 252 |
+ 152 |
|
- }
+ #' archiver$get_output_dir()
|
- | 253 |
+ 153 |
|
-
+ #'
|
- | 254 |
+ 154 |
|
- #' @title Print method for the `yaml_header` class
+ #' archiver$read()$get_cards()[[1]]$get_content()
|
- | 255 |
+ 155 |
|
- #'
+ #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
|
- | 256 |
+ 156 |
|
- #' @description `r lifecycle::badge("experimental")`
+ #' blocks <- Reporter$new()
|
- | 257 |
+ 157 |
|
- #' Print method for the `yaml_header` class.
+ #' blocks <- blocks$from_reporter(archiver$read())$get_blocks()
|
- | 258 |
+ 158 |
|
- #' @param x `rmd_yaml_header` class object.
+ #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
|
- | 259 |
+ 159 |
|
- #' @param ... optional text.
+ #' doc <- Renderer$new()$render(blocks)
|
- | 260 |
+ 160 |
|
- #' @return NULL
+ read = function(path = NULL) {
|
-
- | 261 |
- |
+
+ | 161 |
+ 7x |
- #' @exportS3Method
+ checkmate::assert(
|
-
- | 262 |
- |
+
+ | 162 |
+ 7x |
- #' @examples
+ checkmate::check_null(path),
|
-
- | 263 |
- |
+
+ | 163 |
+ 7x |
- #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
+ checkmate::check_directory_exists(path)
|
- | 264 |
+ 164 |
|
- #' out <- as_yaml_auto(input)
+ )
|
- | 265 |
+ 165 |
|
- #' out
+
|
-
- | 266 |
- |
+
+ | 166 |
+ 7x |
- #' print(out)
+ if (!is.null(path) && !identical(path, private$output_dir)) {
|
-
- | 267 |
- |
+
+ | 167 |
+ 3x |
- print.rmd_yaml_header <- function(x, ...) {
+ unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
|
-
- | 268 |
- ! |
+
+ | 168 |
+ 3x |
- cat(x, ...)
+ file.copy(list.files(path, full.names = TRUE), private$output_dir)
|
- | 269 |
+ 169 |
|
- }
+ }
|
- | 270 |
+ 170 |
|
|
+
+ | 171 |
+ 7x |
+
+ if (length(list.files(private$output_dir))) {
+ |
+
+
+ | 172 |
+ 6x |
+
+ Reporter$new()$from_jsondir(private$output_dir)
+ |
+
- | 271 |
+ 173 |
|
- #' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
+ } else {
+ |
+
+
+ | 174 |
+ 1x |
+
+ warning("The directory provided to the Archiver is empty.")
+ |
+
+
+ | 175 |
+ 1x |
+
+ Reporter$new()
|
- | 272 |
+ 176 |
|
- #' otherwise, the field itself.
+ }
|
- | 273 |
+ 177 |
|
- #'
+ }
|
- | 274 |
+ 178 |
|
- #' @param yaml_text A character vector containing the `yaml` text.
+ ),
|
- | 275 |
+ 179 |
|
- #' @param field_name The name of the field to extract.
+ lock_objects = TRUE,
|
- | 276 |
+ 180 |
|
- #'
+ lock_class = TRUE
|
- | 277 |
+ 181 |
|
- #' @return if the field is a list, it returns the names of elements in the list; otherwise,
+ )
|
+
+
+
+
+
+
- | 278 |
+ 1 |
|
- #' it returns the extracted field.
+ #' Download report button module
|
- | 279 |
+ 2 |
|
#'
|
- | 280 |
+ 3 |
|
- #' @keywords internal
+ #' @description `r lifecycle::badge("experimental")`
|
- | 281 |
+ 4 |
|
- get_yaml_field <- function(yaml_text, field_name) {
+ #'
|
-
- | 282 |
- 8x |
+
+ | 5 |
+ |
- checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
+ #' Provides a button that triggers downloading a report.
|
-
- | 283 |
- 8x |
+
+ | 6 |
+ |
- checkmate::assert_string(field_name)
+ #'
|
- | 284 |
+ 7 |
|
-
- |
-
-
- | 285 |
- 8x |
-
- yaml_obj <- yaml::yaml.load(yaml_text)
+ #' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
|
- | 286 |
+ 8 |
|
-
- |
-
-
- | 287 |
- 8x |
-
- result <- yaml_obj[[field_name]]
- |
-
-
- | 288 |
- 8x |
-
- if (is.list(result)) {
+ #'
|
-
- | 289 |
- 5x |
+
+ | 9 |
+ |
- result <- names(result)
+ #' @details `r global_knitr_details()`
|
- | 290 |
+ 10 |
|
- }
+ #'
|
-
- | 291 |
- 8x |
+
+ | 11 |
+ |
- result
+ #' @name download_report_button
|
- | 292 |
+ 12 |
|
- }
+ #'
|
-
-
-
-
-
-
- | 1 |
+ 13 |
|
- #' Add Card Button User Interface
+ #' @param id (`character(1)`) this `shiny` module's id.
|
- | 2 |
+ 14 |
|
- #' @description `r lifecycle::badge("experimental")`
+ #' @param reporter (`Reporter`) instance.
|
- | 3 |
+ 15 |
|
- #' button for adding views/cards to the Report.
+ #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
|
- | 4 |
+ 16 |
|
- #'
+ #' for customizing the rendering process.
|
- | 5 |
+ 17 |
|
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ #' @inheritParams reporter_download_inputs
|
- | 6 |
+ 18 |
|
- #' @param id `character(1)` this `shiny` module's id.
+ #'
|
- | 7 |
+ 19 |
|
- #' @return `shiny::tagList`
+ #' @return `NULL`.
|
- | 8 |
+ 20 |
|
- #' @export
+ NULL
|
- | 9 |
+ 21 |
|
- add_card_button_ui <- function(id) {
+
|
-
- | 10 |
- 2x |
+
+ | 22 |
+ |
- ns <- shiny::NS(id)
+ #' @rdname download_report_button
|
- | 11 |
+ 23 |
|
-
+ #' @export
|
- | 12 |
+ 24 |
|
- # Buttons with custom css and
+ download_report_button_ui <- function(id) {
|
-
- | 13 |
- |
+
+ | 25 |
+ 2x |
- # js code to disable the add card button when clicked to prevent multi-clicks
+ ns <- shiny::NS(id)
|
- | 14 |
+ 26 |
2x |
shiny::tagList(
|
- | 15 |
+ 27 |
2x |
shiny::singleton(
|
- | 16 |
+ 28 |
2x |
shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
|
- | 17 |
+ 29 |
|
),
|
- | 18 |
+ 30 |
2x |
- shiny::singleton(
+ shiny::tags$button(
|
- | 19 |
+ 31 |
2x |
- shiny::tags$head(
+ id = ns("download_button"),
|
- | 20 |
+ 32 |
2x |
- shiny::tags$script(
+ type = "button",
|
- | 21 |
+ 33 |
2x |
- shiny::HTML(
+ class = "simple_report_button btn btn-primary action-button",
|
- | 22 |
+ 34 |
2x |
- sprintf(
+ title = "Download",
|
-
- | 23 |
- |
+
+ | 35 |
+ 2x |
- '
+ `data-val` = shiny::restoreInput(id = ns("download_button"), default = NULL),
|
- | 24 |
+ 36 |
2x |
- $(document).ready(function(event) {
+ NULL,
|
- | 25 |
+ 37 |
2x |
- $("body").on("click", "#%s", function() {
+ shiny::tags$span(
|
- | 26 |
+ 38 |
2x |
- $(this).addClass("disabled");
+ shiny::icon("download")
|
- | 27 |
+ 39 |
|
- })
+ )
|
- | 28 |
+ 40 |
|
- })',
- |
-
-
- | 29 |
- 2x |
-
- ns("add_card_ok")
+ )
|
- | 30 |
+ 41 |
|
- )
+ )
|
- | 31 |
+ 42 |
|
- )
+ }
|
- | 32 |
+ 43 |
|
- )
+
|
- | 33 |
+ 44 |
|
- )
+ #' @rdname download_report_button
|
- | 34 |
+ 45 |
|
- ),
+ #' @export
|
-
- | 35 |
- 2x |
+
+ | 46 |
+ |
- shiny::tags$button(
+ download_report_button_srv <- function(id,
|
-
- | 36 |
- 2x |
+
+ | 47 |
+ |
- id = ns("add_report_card_button"),
+ reporter,
|
-
- | 37 |
- 2x |
+
+ | 48 |
+ |
- type = "button",
+ global_knitr = getOption("teal.reporter.global_knitr"),
|
-
- | 38 |
- 2x |
+
+ | 49 |
+ |
- class = "simple_report_button btn btn-primary action-button",
+ rmd_output = c(
|
-
- | 39 |
- 2x |
+
+ | 50 |
+ |
- title = "Add Card",
+ "html" = "html_document", "pdf" = "pdf_document",
|
-
- | 40 |
- 2x |
+
+ | 51 |
+ |
- `data-val` = shiny::restoreInput(id = ns("add_report_card_button"), default = NULL),
+ "powerpoint" = "powerpoint_presentation", "word" = "word_document"
|
-
- | 41 |
- 2x |
+
+ | 52 |
+ |
- NULL,
+ ),
|
-
- | 42 |
- 2x |
+
+ | 53 |
+ |
- shiny::tags$span(
+ rmd_yaml_args = list(
|
-
- | 43 |
- 2x |
+
+ | 54 |
+ |
- shiny::icon("plus")
- |
-
-
- | 44 |
- |
-
- )
- |
-
-
- | 45 |
- |
-
- )
- |
-
-
- | 46 |
- |
-
- )
- |
-
-
- | 47 |
- |
-
- }
- |
-
-
- | 48 |
- |
-
-
- |
-
-
- | 49 |
- |
-
- #' Add Card Button Server
- |
-
-
- | 50 |
- |
-
- #' @description `r lifecycle::badge("experimental")`
- |
-
-
- | 51 |
- |
-
- #' server for adding views/cards to the Report.
- |
-
-
- | 52 |
- |
-
- #'
- |
-
-
- | 53 |
- |
-
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
- |
-
-
- | 54 |
- |
-
- #'
+ author = "NEST", title = "Report",
|
| 55 |
|
- #' @details
+ date = as.character(Sys.Date()), output = "html_document",
|
| 56 |
|
- #' This module allows using a child of [`ReportCard`] instead of [`ReportCard`].
+ toc = FALSE
|
| 57 |
|
- #' To properly support this, an instance of the child class must be passed
+ )) {
|
-
+
| 58 |
- |
+ 10x |
- #' as the default value of the `card` argument in the `card_fun` function.
+ checkmate::assert_class(reporter, "Reporter")
|
-
+
| 59 |
- |
+ 10x |
- #' See below:
+ checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
|
-
+
| 60 |
- |
+ 10x |
- #' ```{r}
+ checkmate::assert_subset(
|
-
+
| 61 |
- |
+ 10x |
- #' CustomReportCard <- R6::R6Class( # nolint: object_name_linter.
+ rmd_output,
|
-
+
| 62 |
- |
+ 10x |
- #' classname = "CustomReportCard",
+ c(
|
-
+
| 63 |
- |
+ 10x |
- #' inherit = teal.reporter::ReportCard
+ "html_document", "pdf_document",
|
-
+
| 64 |
- |
+ 10x |
- #' )
+ "powerpoint_presentation", "word_document"
|
| 65 |
|
- #'
+ ),
|
-
+
| 66 |
- |
+ 10x |
- #' custom_function <- function(card = CustomReportCard$new()) {
+ empty.ok = FALSE
|
| 67 |
|
- #' card
+ )
|
-
+
| 68 |
- |
+ 10x |
- #' }
+ checkmate::assert_list(rmd_yaml_args, names = "named")
|
-
+
| 69 |
- |
+ 10x |
- #' ```
+ checkmate::assert_names(
|
-
+
| 70 |
- |
+ 10x |
- #'
+ names(rmd_yaml_args),
|
-
+
| 71 |
- |
+ 10x |
- #' @param id `character(1)` this `shiny` module's id.
+ subset.of = c("author", "title", "date", "output", "toc"),
|
-
+
| 72 |
- |
+ 10x |
- #' @param reporter [`Reporter`] instance.
+ must.include = "output"
|
| 73 |
|
- #' @param card_fun `function` which returns a [`ReportCard`] instance. It can have optional `card`, `comment` and
+ )
|
-
+
| 74 |
- |
+ 8x |
- #' `label` parameters. If `card` parameter is added, then the `ReportCard` instance is created for the user.
+ checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
|
| 75 |
|
- #' Use `comment` parameter to pass it's value whenever you prefer with `card$append_text()` - if `card_fun` does not
+
|
-
+
| 76 |
- |
+ 7x |
- #' have `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the
+ shiny::moduleServer(
|
-
+
| 77 |
- |
+ 7x |
- #' card. If `label` parameter is provided, you can use it to customize appearance of the `card name` and use if to
+ id,
|
-
+
| 78 |
- |
+ 7x |
- #' specify `card` content with `card$append_text()` - if `card_fun` does not have `label` parameter, then `card name`
+ function(input, output, session) {
|
-
+
| 79 |
- |
+ 7x |
- #' will be set to the name passed in `Add Card UI` module, but no text will be added to the content of the `card`.
+ ns <- session$ns
|
| 80 |
|
- #'
+
|
-
+
| 81 |
- |
+ 7x |
- #' @return `shiny::moduleServer`
+ download_modal <- function() {
|
-
+
| 82 |
- |
+ 1x |
- #' @export
+ nr_cards <- length(reporter$get_cards())
|
-
+
| 83 |
- |
+ 1x |
- add_card_button_srv <- function(id, reporter, card_fun) {
+ downb <- shiny::tags$a(
|
| 84 |
- 13x |
+ 1x |
- checkmate::assert_function(card_fun)
+ id = ns("download_data"),
|
| 85 |
- 13x |
+ 1x |
- checkmate::assert_class(reporter, "Reporter")
+ class = paste("btn btn-primary shiny-download-link", if (nr_cards) NULL else "disabled"),
|
| 86 |
- 13x |
+ 1x |
- checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)
+ style = if (nr_cards) NULL else "pointer-events: none;",
|
-
+
| 87 |
- |
+ 1x |
-
+ href = "",
|
| 88 |
- 13x |
+ 1x |
- shiny::moduleServer(
+ target = "_blank",
|
| 89 |
- 13x |
+ 1x |
- id,
+ download = NA,
|
| 90 |
- 13x |
+ 1x |
- function(input, output, session) {
+ shiny::icon("download"),
|
| 91 |
- 13x |
+ 1x |
- ns <- session$ns
+ "Download"
|
-
+
| 92 |
- 13x |
+ |
- add_modal <- function() {
+ )
|
| 93 |
- 11x |
+ 1x |
shiny::modalDialog(
|
| 94 |
- 11x |
+ 1x |
easyClose = TRUE,
|
| 95 |
- 11x |
+ 1x |
- shiny::tags$h3("Add a Card to the Report"),
+ shiny::tags$h3("Download the Report"),
|
| 96 |
- 11x |
+ 1x |
shiny::tags$hr(),
|
| 97 |
- 11x |
+ 1x |
- shiny::textInput(
+ if (length(reporter$get_cards()) == 0) {
|
-
+
| 98 |
- 11x |
+ ! |
- ns("label"),
+ shiny::tags$div(
|
-
+
| 99 |
- 11x |
+ ! |
- "Card Name",
+ class = "mb-4",
|
-
+
| 100 |
- 11x |
+ ! |
- value = "",
+ shiny::tags$p(
|
-
+
| 101 |
- 11x |
+ ! |
- placeholder = "Add the card title here",
+ class = "text-danger",
|
-
+
| 102 |
- 11x |
+ ! |
- width = "100%"
+ shiny::tags$strong("No Cards Added")
|
| 103 |
|
- ),
+ )
|
-
+
| 104 |
- 11x |
+ |
- shiny::textAreaInput(
+ )
|
-
+
| 105 |
- 11x |
+ |
- ns("comment"),
+ } else {
|
| 106 |
- 11x |
+ 1x |
- "Comment",
+ shiny::tags$div(
|
| 107 |
- 11x |
+ 1x |
- value = "",
+ class = "mb-4",
|
| 108 |
- 11x |
+ 1x |
- placeholder = "Add a comment here...",
+ shiny::tags$p(
|
| 109 |
- 11x |
+ 1x |
- width = "100%"
+ class = "text-success",
|
-
+
| 110 |
- |
+ 1x |
- ),
+ shiny::tags$strong(paste("Number of cards: ", nr_cards))
|
-
+
| 111 |
- 11x |
+ |
- shiny::tags$script(
+ ),
|
-
+
| 112 |
- 11x |
+ |
- shiny::HTML(
+ )
|
-
+
| 113 |
- 11x |
+ |
- sprintf(
+ },
|
-
+
| 114 |
- |
+ 1x |
- "
+ reporter_download_inputs(
|
| 115 |
- 11x |
+ 1x |
- $('#shiny-modal').on('shown.bs.modal', () => {
+ rmd_yaml_args = rmd_yaml_args,
|
| 116 |
- 11x |
+ 1x |
- $('#%s').focus()
+ rmd_output = rmd_output,
|
-
+
| 117 |
- |
+ 1x |
- })
+ showrcode = any_rcode_block(reporter),
|
-
+
| 118 |
- |
+ 1x |
- ",
+ session = session
|
-
+
| 119 |
- 11x |
+ |
- ns("label")
+ ),
|
-
+
| 120 |
- |
+ 1x |
- )
+ footer = shiny::tagList(
|
-
+
| 121 |
- |
+ 1x |
- )
+ shiny::tags$button(
|
-
+
| 122 |
- |
+ 1x |
- ),
+ type = "button",
|
| 123 |
- 11x |
+ 1x |
- footer = shiny::div(
+ class = "btn btn-secondary",
|
| 124 |
- 11x |
+ 1x |
- shiny::tags$button(
+ `data-dismiss` = "modal",
|
| 125 |
- 11x |
+ 1x |
- type = "button",
+ `data-bs-dismiss` = "modal",
|
| 126 |
- 11x |
+ 1x |
- class = "btn btn-secondary",
+ NULL,
|
| 127 |
- 11x |
+ 1x |
- `data-dismiss` = "modal",
+ "Cancel"
|
-
+
| 128 |
- 11x |
+ |
- `data-bs-dismiss` = "modal",
+ ),
|
| 129 |
- 11x |
+ 1x |
- NULL,
+ downb
|
-
+
| 130 |
- 11x |
+ |
- "Cancel"
+ )
|
| 131 |
|
- ),
+ )
|
-
+
| 132 |
- 11x |
+ |
- shiny::tags$button(
+ }
|
-
+
| 133 |
- 11x |
+ |
- id = ns("add_card_ok"),
+
|
| 134 |
- 11x |
+ 7x |
- type = "button",
+ shiny::observeEvent(input$download_button, {
|
| 135 |
- 11x |
+ 1x |
- class = "btn btn-primary action-button",
+ shiny::showModal(download_modal())
|
-
+
| 136 |
- 11x |
+ |
- `data-val` = shiny::restoreInput(id = ns("add_card_ok"), default = NULL),
+ })
|
-
+
| 137 |
- 11x |
+ |
- NULL,
+
|
| 138 |
- 11x |
+ 7x |
- "Add Card"
+ output$download_data <- shiny::downloadHandler(
|
-
+
| 139 |
- |
+ 7x |
- )
+ filename = function() {
|
-
+
| 140 |
- |
+ 2x |
- )
+ paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
|
| 141 |
|
- )
+ },
|
-
+
| 142 |
- |
+ 7x |
- }
+ content = function(file) {
|
-
+
| 143 |
- |
+ 2x |
-
+ shiny::showNotification("Rendering and Downloading the document.")
|
| 144 |
- 13x |
+ 2x |
- shiny::observeEvent(input$add_report_card_button, {
+ input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
|
| 145 |
- 11x |
+ 2x |
- shiny::showModal(add_modal())
+ names(input_list) <- names(rmd_yaml_args)
|
-
+
| 146 |
- |
+ ! |
- })
+ if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
|
-
+
| 147 |
- |
+ 2x |
-
+ report_render_and_compress(reporter, input_list, global_knitr, file)
|
| 148 |
|
- # the add card button is disabled when clicked to prevent multi-clicks
+ },
|
-
+
| 149 |
- |
+ 7x |
- # please check the ui part for more information
+ contentType = "application/zip"
|
-
+
| 150 |
- 13x |
+ |
- shiny::observeEvent(input$add_card_ok, {
+ )
|
-
+
| 151 |
- 11x |
+ |
- card_fun_args_nams <- names(formals(card_fun))
+ }
|
-
+
| 152 |
- 11x |
+ |
- has_card_arg <- "card" %in% card_fun_args_nams
+ )
|
-
+
| 153 |
- 11x |
+ |
- has_comment_arg <- "comment" %in% card_fun_args_nams
+ }
|
-
+
| 154 |
- 11x |
+ |
- has_label_arg <- "label" %in% card_fun_args_nams
+
|
| 155 |
|
-
+ #' Render the report
|
-
+
| 156 |
- 11x |
+ |
- arg_list <- list()
+ #'
|
| 157 |
|
-
+ #' Render the report and zip the created directory.
|
-
+
| 158 |
- 11x |
+ |
- if (has_comment_arg) {
+ #'
|
-
+
| 159 |
- 4x |
+ |
- arg_list <- c(arg_list, list(comment = input$comment))
+ #' @param reporter (`Reporter`) instance.
|
| 160 |
|
- }
+ #' @param input_list (`list`) like `shiny` input converted to a regular named list.
|
-
+
| 161 |
- 11x |
+ |
- if (has_label_arg) {
+ #' @param global_knitr (`list`) a global `knitr` parameters, like echo.
|
-
+
| 162 |
- ! |
+ |
- arg_list <- c(arg_list, list(label = input$label))
+ #' But if local parameter is set it will have priority.
|
| 163 |
|
- }
+ #' @param file (`character(1)`) where to copy the returned directory.
|
| 164 |
|
-
+ #'
|
-
+
| 165 |
- 11x |
+ |
- if (has_card_arg) {
+ #' @return `file` argument, invisibly.
|
| 166 |
|
- # The default_card is defined here because formals() returns a pairedlist object
+ #'
|
| 167 |
|
- # of formal parameter names and their default values. The values are missing
+ #' @keywords internal
|
| 168 |
|
- # if not defined and the missing check does not work if supplied formals(card_fun)[[1]]
+ report_render_and_compress <- function(reporter, input_list, global_knitr, file = tempdir()) {
|
| 169 |
8x |
- default_card <- formals(card_fun)$card
+ checkmate::assert_class(reporter, "Reporter")
|
| 170 |
8x |
- card <- `if`(
+ checkmate::assert_list(input_list, names = "named")
|
| 171 |
- 8x |
+ 7x |
- missing(default_card),
+ checkmate::assert_string(file)
|
-
+
| 172 |
- 8x |
+ |
- ReportCard$new(),
+
|
-
+
| 173 |
- 8x |
+ |
- eval(default_card, envir = environment(card_fun))
+ if (
|
-
+
| 174 |
- |
+ 5x |
- )
+ identical("pdf_document", input_list$output) &&
|
| 175 |
- 8x |
+ 5x |
- arg_list <- c(arg_list, list(card = card))
+ inherits(try(system2("pdflatex", "--version", stdout = TRUE), silent = TRUE), "try-error")
|
| 176 |
|
- }
+ ) {
|
-
+
| 177 |
- |
+ ! |
-
+ shiny::showNotification(
|
-
+
| 178 |
- 11x |
+ ! |
- card <- try(do.call(card_fun, arg_list))
+ ui = "pdflatex is not available so the pdf_document could not be rendered. Please use other output type.",
|
-
+
| 179 |
- |
+ ! |
-
+ action = "Please contact app developer",
|
-
+
| 180 |
- 11x |
+ ! |
- if (inherits(card, "try-error")) {
+ type = "error"
|
-
+
| 181 |
- 3x |
+ |
- msg <- paste0(
+ )
|
-
+
| 182 |
- 3x |
+ ! |
- "The card could not be added to the report. ",
+ stop("pdflatex is not available so the pdf_document could not be rendered.")
|
-
+
| 183 |
- 3x |
+ |
- "Have the outputs for the report been created yet? If not please try again when they ",
+ }
|
-
+
| 184 |
- 3x |
+ |
- "are ready. Otherwise contact your application developer"
+
|
-
+
| 185 |
- |
+ 5x |
- )
+ yaml_header <- as_yaml_auto(input_list)
|
| 186 |
- 3x |
+ 5x |
- warning(msg)
+ renderer <- Renderer$new()
|
-
+
| 187 |
- 3x |
+ |
- shiny::showNotification(
+
|
| 188 |
- 3x |
+ 5x |
- msg,
+ tryCatch(
|
| 189 |
- 3x |
+ 5x |
- type = "error"
+ renderer$render(reporter$get_blocks(), yaml_header, global_knitr),
|
-
+
| 190 |
- |
+ 5x |
- )
+ warning = function(cond) {
|
-
+
| 191 |
- |
+ ! |
- } else {
+ shiny::showNotification(
|
-
+
| 192 |
- 8x |
+ ! |
- checkmate::assert_class(card, "ReportCard")
+ ui = "Render document warning!",
|
-
+
| 193 |
- 8x |
+ ! |
- if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
+ action = "Please contact app developer",
|
-
+
| 194 |
- 1x |
+ ! |
- card$append_text("Comment", "header3")
+ type = "warning"
|
-
+
| 195 |
- 1x |
+ |
- card$append_text(input$comment)
+ )
|
| 196 |
|
- }
+ },
|
-
+
| 197 |
- |
+ 5x |
-
+ error = function(cond) {
|
-
+
| 198 |
- 8x |
+ ! |
- if (!has_label_arg && length(input$label) == 1 && input$label != "") {
+ shiny::showNotification(
|
| 199 |
! |
- card$set_name(input$label)
+ ui = "Render document error!",
|
-
+
| 200 |
- |
+ ! |
- }
+ action = "Please contact app developer",
|
-
+
| 201 |
- |
+ ! |
-
+ type = "error"
|
-
+
| 202 |
- 8x |
+ |
- reporter$append_cards(list(card))
+ )
|
-
+
| 203 |
- 8x |
+ |
- shiny::showNotification(sprintf("The card added successfully."), type = "message")
+ }
|
-
+
| 204 |
- 8x |
+ |
- shiny::removeModal()
+ )
|
| 205 |
|
- }
+
|
-
+
| 206 |
- |
+ 5x |
- })
+ temp_zip_file <- tempfile(fileext = ".zip")
|
-
+
| 207 |
- |
+ 5x |
- }
+ tryCatch(
|
-
+
| 208 |
- |
+ 5x |
- )
+ expr = zip::zipr(temp_zip_file, renderer$get_output_dir()),
|
-
+
| 209 |
- |
+ 5x |
- }
+ warning = function(cond) {
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 210 |
+ ! |
- #' @title `Reporter`
+ shiny::showNotification(
|
-
- | 2 |
- |
+
+ | 211 |
+ ! |
- #' @description `r lifecycle::badge("experimental")`
+ ui = "Zipping folder warning!",
|
-
- | 3 |
- |
+
+ | 212 |
+ ! |
- #' R6 class that stores and manages report cards.
+ action = "Please contact app developer",
|
-
- | 4 |
- |
+
+ | 213 |
+ ! |
- #' @export
+ type = "warning"
|
- | 5 |
+ 214 |
|
- #'
+ )
|
- | 6 |
+ 215 |
|
- Reporter <- R6::R6Class( # nolint: object_name_linter.
+ },
|
-
- | 7 |
- |
+
+ | 216 |
+ 5x |
- classname = "Reporter",
+ error = function(cond) {
|
-
- | 8 |
- |
+
+ | 217 |
+ ! |
- public = list(
+ shiny::showNotification(
|
-
- | 9 |
- |
+
+ | 218 |
+ ! |
- #' @description Returns a `Reporter` object.
+ ui = "Zipping folder error!",
|
-
- | 10 |
- |
+
+ | 219 |
+ ! |
- #'
+ action = "Please contact app developer",
|
-
- | 11 |
- |
+
+ | 220 |
+ ! |
- #' @return a `Reporter` object
+ type = "error"
|
- | 12 |
+ 221 |
|
- #' @examples
+ )
|
- | 13 |
+ 222 |
|
- #' reporter <- teal.reporter::Reporter$new()
+ }
|
- | 14 |
+ 223 |
|
- #'
+ )
|
- | 15 |
+ 224 |
|
- initialize = function() {
+
|
- | 16 |
- 44x |
+ 225 |
+ 5x |
- private$cards <- list()
+ tryCatch(
|
- | 17 |
- 44x |
+ 226 |
+ 5x |
- private$reactive_add_card <- shiny::reactiveVal(0)
+ expr = file.copy(temp_zip_file, file),
|
- | 18 |
- 44x |
+ 227 |
+ 5x |
- invisible(self)
+ warning = function(cond) {
|
-
- | 19 |
- |
+
+ | 228 |
+ ! |
- },
+ shiny::showNotification(
|
-
- | 20 |
- |
+
+ | 229 |
+ ! |
- #' @description Appends a table to this `Reporter`.
+ ui = "Copying file warning!",
|
-
- | 21 |
- |
+
+ | 230 |
+ ! |
- #'
+ action = "Please contact app developer",
|
-
- | 22 |
- |
+
+ | 231 |
+ ! |
- #' @param cards [`ReportCard`] or a list of such objects
+ type = "warning"
|
- | 23 |
+ 232 |
|
- #' @return invisibly self
+ )
|
- | 24 |
+ 233 |
|
- #' @examples
+ },
|
-
- | 25 |
- |
+
+ | 234 |
+ 5x |
- #' card1 <- teal.reporter::ReportCard$new()
+ error = function(cond) {
|
-
- | 26 |
- |
+
+ | 235 |
+ ! |
- #'
+ shiny::showNotification(
|
-
- | 27 |
- |
+
+ | 236 |
+ ! |
- #' card1$append_text("Header 2 text", "header2")
+ ui = "Copying file error!",
|
-
- | 28 |
- |
+
+ | 237 |
+ ! |
- #' card1$append_text("A paragraph of default text", "header2")
+ action = "Please contact app developer",
|
-
- | 29 |
- |
+
+ | 238 |
+ ! |
- #' card1$append_plot(
+ type = "error"
|
- | 30 |
+ 239 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ )
|
- | 31 |
+ 240 |
|
- #' )
+ }
|
- | 32 |
+ 241 |
|
- #'
+ )
|
- | 33 |
+ 242 |
|
- #' card2 <- teal.reporter::ReportCard$new()
+
|
-
- | 34 |
- |
+
+ | 243 |
+ 5x |
- #'
+ rm(renderer)
|
-
- | 35 |
- |
+
+ | 244 |
+ 5x |
- #' card2$append_text("Header 2 text", "header2")
+ invisible(file)
|
- | 36 |
+ 245 |
|
- #' card2$append_text("A paragraph of default text", "header2")
+ }
|
- | 37 |
+ 246 |
|
- #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
+
|
- | 38 |
+ 247 |
|
- #' table_res2 <- rtables::build_table(lyt, airquality)
+ #' Get the custom list of UI inputs
|
- | 39 |
+ 248 |
|
- #' card2$append_table(table_res2)
+ #'
|
- | 40 |
+ 249 |
|
- #' card2$append_table(iris)
+ #' @param rmd_output (`character`) vector with `rmarkdown` output types,
|
- | 41 |
+ 250 |
|
- #'
+ #' by default all possible `pdf_document`, `html_document`, `powerpoint_presentation`, and `word_document`.
|
- | 42 |
+ 251 |
|
- #' reporter <- teal.reporter::Reporter$new()
+ #' If vector is named then those names will appear in the `UI`.
|
- | 43 |
+ 252 |
|
- #' reporter$append_cards(list(card1, card2))
+ #' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their default values.
|
- | 44 |
+ 253 |
|
- #'
+ #' This `list` will result in the custom subset of UI inputs for the download reporter functionality.
|
- | 45 |
+ 254 |
|
- append_cards = function(cards) {
- |
-
-
- | 46 |
- 41x |
-
- checkmate::assert_list(cards, "ReportCard")
- |
-
-
- | 47 |
- 41x |
-
- private$cards <- append(private$cards, cards)
- |
-
-
- | 48 |
- 41x |
-
- private$reactive_add_card(length(private$cards))
- |
-
-
- | 49 |
- 41x |
-
- invisible(self)
+ #' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`.
|
- | 50 |
+ 255 |
|
- },
+ #' The `list` must include at least `"output"` field.
|
- | 51 |
+ 256 |
|
- #' @description Returns cards of this `Reporter`.
+ #' The default value for `"output"` has to be in the `rmd_output` argument.
|
- | 52 |
+ 257 |
|
- #'
+ #'
|
- | 53 |
+ 258 |
|
- #' @return `list()` list of [`ReportCard`]
+ #' @keywords internal
|
- | 54 |
+ 259 |
|
- #' @examples
+ reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) {
|
-
- | 55 |
- |
+
+ | 260 |
+ 8x |
- #' card1 <- teal.reporter::ReportCard$new()
+ shiny::tagList(
|
-
- | 56 |
- |
+
+ | 261 |
+ 8x |
- #'
+ lapply(names(rmd_yaml_args), function(e) {
|
-
- | 57 |
- |
+
+ | 262 |
+ 40x |
- #' card1$append_text("Header 2 text", "header2")
+ switch(e,
|
-
- | 58 |
- |
+
+ | 263 |
+ 8x |
- #' card1$append_text("A paragraph of default text", "header2")
+ author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author),
|
-
- | 59 |
- |
+
+ | 264 |
+ 8x |
- #' card1$append_plot(
+ title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title),
|
-
- | 60 |
- |
+
+ | 265 |
+ 8x |
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date),
|
-
- | 61 |
- |
+
+ | 266 |
+ 8x |
- #' )
+ output = shiny::tags$div(
|
-
- | 62 |
- |
+
+ | 267 |
+ 8x |
- #'
+ shinyWidgets::pickerInput(
|
-
- | 63 |
- |
+
+ | 268 |
+ 8x |
- #' card2 <- teal.reporter::ReportCard$new()
+ inputId = session$ns("output"),
|
-
- | 64 |
- |
+
+ | 269 |
+ 8x |
- #'
+ label = "Choose a document type: ",
|
-
- | 65 |
- |
+
+ | 270 |
+ 8x |
- #' card2$append_text("Header 2 text", "header2")
+ choices = rmd_output,
|
-
- | 66 |
- |
+
+ | 271 |
+ 8x |
- #' card2$append_text("A paragraph of default text", "header2")
+ selected = rmd_yaml_args$output
|
- | 67 |
+ 272 |
|
- #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
+ )
|
- | 68 |
+ 273 |
|
- #' table_res2 <- rtables::build_table(lyt, airquality)
+ ),
|
-
- | 69 |
- |
+
+ | 274 |
+ 8x |
- #' card2$append_table(table_res2)
+ toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc)
|
- | 70 |
+ 275 |
|
- #' card2$append_table(iris)
+ )
|
- | 71 |
+ 276 |
|
- #'
+ }),
|
-
- | 72 |
- |
+
+ | 277 |
+ 8x |
- #' reporter <- teal.reporter::Reporter$new()
+ if (showrcode) {
|
-
- | 73 |
- |
+
+ | 278 |
+ ! |
- #' reporter$append_cards(list(card1, card2))
+ shiny::checkboxInput(
|
-
- | 74 |
- |
+
+ | 279 |
+ ! |
- #' reporter$get_cards()
+ session$ns("showrcode"),
|
-
- | 75 |
- |
+
+ | 280 |
+ ! |
- get_cards = function() {
+ label = "Include R Code",
|
-
- | 76 |
- 72x |
+
+ | 281 |
+ ! |
- private$cards
+ value = FALSE
|
- | 77 |
+ 282 |
|
- },
+ )
|
- | 78 |
+ 283 |
|
- #' @description Returns blocks of all [`ReportCard`] of this `Reporter`.
+ }
|
- | 79 |
+ 284 |
|
- #'
+ )
|
- | 80 |
+ 285 |
|
- #' @param sep the element inserted between each content element in this `Reporter`.
+ }
|
- | 81 |
+ 286 |
|
- #' Pass `NULL` to return content without any additional elements. Default: `NewpageBlock$new()`
+
|
- | 82 |
+ 287 |
|
- #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`
+ #' @noRd
|
- | 83 |
+ 288 |
|
- #' @examples
+ #' @keywords internal
|
- | 84 |
+ 289 |
|
- #' card1 <- teal.reporter::ReportCard$new()
+ any_rcode_block <- function(reporter) {
+ |
+
+
+ | 290 |
+ 10x |
+
+ any(
+ |
+
+
+ | 291 |
+ 10x |
+
+ vapply(
+ |
+
+
+ | 292 |
+ 10x |
+
+ reporter$get_blocks(),
+ |
+
+
+ | 293 |
+ 10x |
+
+ function(e) inherits(e, "RcodeBlock"),
+ |
+
+
+ | 294 |
+ 10x |
+
+ logical(1)
|
- | 85 |
+ 295 |
|
- #'
+ )
|
- | 86 |
+ 296 |
|
- #' card1$append_text("Header 2 text", "header2")
+ )
|
- | 87 |
+ 297 |
|
- #' card1$append_text("A paragraph of default text", "header2")
+ }
|
+
+
+
+
+
+
- | 88 |
+ 1 |
|
- #' card1$append_plot(
+ #' Mark strings for quotation in `yaml` serialization
|
- | 89 |
+ 2 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ #'
|
- | 90 |
+ 3 |
|
- #' )
+ #' This function is designed for use with the `yaml` package to explicitly,
|
- | 91 |
+ 4 |
|
- #'
+ #' It adds an attribute to character strings, indicating that they should be serialized with double quotes.
|
- | 92 |
+ 5 |
|
- #' card2 <- teal.reporter::ReportCard$new()
+ #'
|
- | 93 |
+ 6 |
|
- #'
+ #' @param x (`character`)
|
- | 94 |
+ 7 |
|
- #' card2$append_text("Header 2 text", "header2")
+ #' @keywords internal
|
- | 95 |
+ 8 |
|
- #' card2$append_text("A paragraph of default text", "header2")
+ #' @examples
|
- | 96 |
+ 9 |
|
- #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
+ #' library(yaml)
|
- | 97 |
+ 10 |
|
- #' table_res2 <- rtables::build_table(lyt, airquality)
+ #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
|
- | 98 |
+ 11 |
|
- #' card2$append_table(table_res2)
+ #' yaml <- list(
|
- | 99 |
+ 12 |
|
- #' card2$append_table(iris)
+ #' author = yaml_quoted("NEST"),
|
- | 100 |
+ 13 |
|
- #'
+ #' title = yaml_quoted("Report"),
|
- | 101 |
+ 14 |
|
- #' reporter <- teal.reporter::Reporter$new()
+ #' date = yaml_quoted("07/04/2019"),
|
- | 102 |
+ 15 |
|
- #' reporter$append_cards(list(card1, card2))
+ #' output = list(pdf_document = list(keep_tex = TRUE))
|
- | 103 |
+ 16 |
|
- #' reporter$get_blocks()
+ #' )
|
- | 104 |
+ 17 |
|
- #'
+ #' as.yaml(yaml)
|
- | 105 |
+ 18 |
|
- get_blocks = function(sep = NewpageBlock$new()) {
+ yaml_quoted <- function(x) {
|
- | 106 |
- 36x |
+ 19 |
+ 2x |
- blocks <- list()
+ attr(x, "quoted") <- TRUE
|
- | 107 |
- 36x |
+ 20 |
+ 2x |
- if (length(private$cards) > 0) {
+ x
|
-
- | 108 |
- 33x |
+
+ | 21 |
+ |
- for (card_idx in head(seq_along(private$cards), -1)) {
+ }
|
-
- | 109 |
- 14x |
+
+ | 22 |
+ |
- blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
+
|
- | 110 |
+ 23 |
|
- }
+ #' Create `markdown` header from `yaml` string
|
-
- | 111 |
- 33x |
+
+ | 24 |
+ |
- blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
+ #'
|
- | 112 |
+ 25 |
|
- }
+ #' This function wraps a `yaml`-formatted string in Markdown header delimiters.
|
-
- | 113 |
- 36x |
+
+ | 26 |
+ |
- blocks
+ #'
|
- | 114 |
+ 27 |
|
- },
+ #' @param x (`character`) `yaml` formatted string.
|
- | 115 |
+ 28 |
|
- #' @description Removes all [`ReportCard`] objects added to this `Reporter`.
+ #' @keywords internal
|
- | 116 |
+ 29 |
|
- #' Additionally all metadata are removed.
+ #' @examples
|
- | 117 |
+ 30 |
|
- #'
+ #' library(yaml)
|
- | 118 |
+ 31 |
|
- #' @return invisibly self
+ #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
|
- | 119 |
+ 32 |
|
- #'
+ #' yaml <- list(
|
- | 120 |
+ 33 |
|
- reset = function() {
+ #' author = yaml_quoted("NEST"),
|
-
- | 121 |
- 27x |
+
+ | 34 |
+ |
- private$cards <- list()
+ #' title = yaml_quoted("Report"),
|
-
- | 122 |
- 27x |
+
+ | 35 |
+ |
- private$metadata <- list()
+ #' date = yaml_quoted("07/04/2019"),
|
-
- | 123 |
- 27x |
+
+ | 36 |
+ |
- private$reactive_add_card(0)
+ #' output = list(pdf_document = list(keep_tex = TRUE))
|
-
- | 124 |
- 27x |
+
+ | 37 |
+ |
- invisible(self)
+ #' )
|
- | 125 |
+ 38 |
|
- },
+ #' md_header <- getFromNamespace("md_header", "teal.reporter")
|
- | 126 |
+ 39 |
|
- #' @description remove a specific Card in the Reporter
+ #' md_header(as.yaml(yaml))
|
- | 127 |
+ 40 |
|
- #'
+ md_header <- function(x) {
+ |
+
+
+ | 41 |
+ 14x |
+
+ paste0("---\n", x, "---\n")
|
- | 128 |
+ 42 |
|
- #' @param ids `integer` the indexes of cards
+ }
|
- | 129 |
+ 43 |
|
- #' @return invisibly self
+
|
- | 130 |
+ 44 |
|
- remove_cards = function(ids = NULL) {
+ #' Convert `yaml` representation of a boolean strings to logical Values
|
-
- | 131 |
- 1x |
+
+ | 45 |
+ |
- checkmate::assert(
+ #'
|
-
- | 132 |
- 1x |
+
+ | 46 |
+ |
- checkmate::check_null(ids),
+ #' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`.
|
-
- | 133 |
- 1x |
+
+ | 47 |
+ |
- checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
+ #'
|
- | 134 |
+ 48 |
|
- )
+ #' @param input (`character(1)`)
|
-
- | 135 |
- 1x |
+
+ | 49 |
+ |
- if (!is.null(ids)) {
+ #' @param name (`charcter(1)`)
|
-
- | 136 |
- 1x |
+
+ | 50 |
+ |
- private$cards <- private$cards[-ids]
+ #' @param pos_logi (`character`) vector of `yaml` values which should be treated as `TRUE`.
|
- | 137 |
+ 51 |
|
- }
+ #' @param neg_logi (`character`) vector of `yaml` values which should be treated as `FALSE`.
|
-
- | 138 |
- 1x |
+
+ | 52 |
+ |
- private$reactive_add_card(length(private$cards))
+ #' @param silent (`logical(1)`) if to suppress the messages and warnings.
|
-
- | 139 |
- 1x |
+
+ | 53 |
+ |
- invisible(self)
+ #' @return `input` argument or the appropriate `logical` value.
|
- | 140 |
+ 54 |
|
- },
+ #' @keywords internal
|
- | 141 |
+ 55 |
|
- #' @description swap two cards in the Reporter
+ #' @examples
|
- | 142 |
+ 56 |
|
- #'
+ #'
|
- | 143 |
+ 57 |
|
- #' @param start `integer` the index of the first card
+ #' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter")
|
- | 144 |
+ 58 |
|
- #' @param end `integer` the index of the second card
+ #' conv_str_logi("TRUE")
|
- | 145 |
+ 59 |
|
- #' @return invisibly self
+ #' conv_str_logi("True")
|
- | 146 |
+ 60 |
|
- swap_cards = function(start, end) {
+ #'
|
-
- | 147 |
- 6x |
+
+ | 61 |
+ |
- checkmate::assert(
+ #' conv_str_logi("off")
|
-
- | 148 |
- 6x |
+
+ | 62 |
+ |
- checkmate::check_integer(start,
+ #' conv_str_logi("n")
|
-
- | 149 |
- 6x |
+
+ | 63 |
+ |
- min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
+ #'
|
- | 150 |
+ 64 |
|
- ),
+ #' conv_str_logi("sth")
|
-
- | 151 |
- 6x |
+
+ | 65 |
+ |
- checkmate::check_integer(end,
+ conv_str_logi <- function(input,
|
-
- | 152 |
- 6x |
+
+ | 66 |
+ |
- min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
+ name = "",
|
- | 153 |
+ 67 |
|
- ),
+ pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"),
|
-
- | 154 |
- 6x |
+
+ | 68 |
+ |
- combine = "and"
+ neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"),
|
- | 155 |
+ 69 |
|
- )
+ silent = TRUE) {
|
- | 156 |
- 6x |
+ 70 |
+ 18x |
- start_val <- private$cards[[start]]$clone()
+ checkmate::assert_string(input)
|
- | 157 |
- 6x |
+ 71 |
+ 17x |
- end_val <- private$cards[[end]]$clone()
+ checkmate::assert_string(name)
|
- | 158 |
- 6x |
+ 72 |
+ 17x |
- private$cards[[start]] <- end_val
+ checkmate::assert_character(pos_logi)
|
- | 159 |
- 6x |
+ 73 |
+ 17x |
- private$cards[[end]] <- start_val
+ checkmate::assert_character(neg_logi)
|
- | 160 |
- 6x |
+ 74 |
+ 17x |
- invisible(self)
+ checkmate::assert_flag(silent)
|
- | 161 |
+ 75 |
|
- },
+
|
-
- | 162 |
- |
+
+ | 76 |
+ 17x |
- #' @description get a value for the reactive value for the add card
+ all_logi <- c(pos_logi, neg_logi)
|
-
- | 163 |
- |
+
+ | 77 |
+ 17x |
- #'
+ if (input %in% all_logi) {
|
-
- | 164 |
- |
+
+ | 78 |
+ 15x |
- #' @return `reactive_add_card` field value
+ if (isFALSE(silent)) {
|
-
- | 165 |
- |
+
+ | 79 |
+ ! |
- #' @note The function has to be used in the shiny reactive context.
+ message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
|
- | 166 |
+ 80 |
|
- #' @examples
+ }
|
-
- | 167 |
- |
+
+ | 81 |
+ 15x |
- #' shiny::isolate(Reporter$new()$get_reactive_add_card())
+ input %in% pos_logi
|
- | 168 |
+ 82 |
|
- get_reactive_add_card = function() {
+ } else {
|
- | 169 |
- 23x |
+ 83 |
+ 2x |
- private$reactive_add_card()
+ input
|
- | 170 |
+ 84 |
|
- },
+ }
|
- | 171 |
+ 85 |
|
- #' @description get metadata of this `Reporter`.
+ }
|
- | 172 |
+ 86 |
|
- #'
+
|
- | 173 |
+ 87 |
|
- #' @return metadata
+ #' Get document output types from the `rmarkdown` package
|
- | 174 |
+ 88 |
|
- #' @examples
+ #'
|
- | 175 |
+ 89 |
|
- #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
+ #' @description `r lifecycle::badge("experimental")`
|
- | 176 |
+ 90 |
|
- #' reporter$get_metadata()
+ #'
|
- | 177 |
+ 91 |
|
- #'
+ #' Retrieves vector of available document output types from the `rmarkdown` package,
|
- | 178 |
+ 92 |
|
- get_metadata = function() {
+ #' such as `pdf_document`, `html_document`, etc.
|
-
- | 179 |
- 17x |
+
+ | 93 |
+ |
- private$metadata
+ #'
|
- | 180 |
+ 94 |
|
- },
+ #' @return `character` vector.
|
- | 181 |
+ 95 |
|
- #' @description Appends metadata to this `Reporter`.
+ #' @export
|
- | 182 |
+ 96 |
|
- #'
+ #' @examples
|
- | 183 |
+ 97 |
|
- #' @param meta (`list`) of metadata.
+ #' rmd_outputs()
|
- | 184 |
+ 98 |
|
- #' @return invisibly self
+ rmd_outputs <- function() {
|
-
- | 185 |
- |
+
+ | 99 |
+ 18x |
- #' @examples
+ rmarkdown_namespace <- asNamespace("rmarkdown")
|
-
- | 186 |
- |
+
+ | 100 |
+ 18x |
- #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
+ ls(rmarkdown_namespace)[grep("_document|_presentation", ls(rmarkdown_namespace))]
|
- | 187 |
+ 101 |
|
- #' reporter$get_metadata()
+ }
|
- | 188 |
+ 102 |
|
- #'
+
|
- | 189 |
+ 103 |
|
- append_metadata = function(meta) {
+ #' Get document output arguments from the `rmarkdown` package
|
-
- | 190 |
- 25x |
+
+ | 104 |
+ |
- checkmate::assert_list(meta, names = "unique")
+ #'
|
-
- | 191 |
- 22x |
+
+ | 105 |
+ |
- checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata)))
+ #' @description `r lifecycle::badge("experimental")`
|
-
- | 192 |
- 21x |
+
+ | 106 |
+ |
- private$metadata <- append(private$metadata, meta)
+ #'
|
-
- | 193 |
- 21x |
+
+ | 107 |
+ |
- invisible(self)
+ #' Retrieves the arguments for a specified document output type from the `rmarkdown` package.
|
- | 194 |
+ 108 |
|
- },
+ #'
|
- | 195 |
+ 109 |
|
- #' @description Create/Recreate a Reporter from another Reporter
+ #' @param output_name (`character`) `rmarkdown` output name.
|
- | 196 |
+ 110 |
|
- #' @param reporter `Reporter` instance.
+ #' @param default_values (`logical(1)`) if to return a default values for each argument.
|
- | 197 |
+ 111 |
|
- #' @return invisibly self
+ #' @export
|
- | 198 |
+ 112 |
|
- #' @examples
+ #' @examples
|
- | 199 |
+ 113 |
|
- #' reporter <- Reporter$new()
+ #' rmd_output_arguments("pdf_document")
|
- | 200 |
+ 114 |
|
- #' reporter$from_reporter(reporter)
+ #' rmd_output_arguments("pdf_document", TRUE)
|
- | 201 |
+ 115 |
|
- from_reporter = function(reporter) {
+ rmd_output_arguments <- function(output_name, default_values = FALSE) {
|
- | 202 |
- 8x |
+ 116 |
+ 17x |
- checkmate::assert_class(reporter, "Reporter")
+ checkmate::assert_string(output_name)
|
- | 203 |
- 8x |
+ 117 |
+ 17x |
- self$reset()
+ checkmate::assert_subset(output_name, rmd_outputs())
+ |
+
+
+ | 118 |
+ |
+
+
|
- | 204 |
- 8x |
+ 119 |
+ 16x |
- self$append_cards(reporter$get_cards())
+ rmarkdown_namespace <- asNamespace("rmarkdown")
|
- | 205 |
- 8x |
+ 120 |
+ 16x |
- self$append_metadata(reporter$get_metadata())
+ if (default_values) {
|
- | 206 |
- 8x |
+ 121 |
+ 14x |
- invisible(self)
+ formals(rmarkdown_namespace[[output_name]])
|
- | 207 |
+ 122 |
|
- },
+ } else {
|
-
- | 208 |
- |
+
+ | 123 |
+ 2x |
- #' @description Convert a Reporter to a list and transfer files
+ names(formals(rmarkdown_namespace[[output_name]]))
|
- | 209 |
+ 124 |
|
- #' @param output_dir `character(1)` a path to the directory where files will be copied.
+ }
|
- | 210 |
+ 125 |
|
- #' @return `named list` `Reporter` representation
+ }
|
- | 211 |
+ 126 |
|
- #' @examples
+
|
- | 212 |
+ 127 |
|
- #' reporter <- Reporter$new()
+ #' Parse a named list to `yaml` header for an `Rmd` file
|
- | 213 |
+ 128 |
|
- #' tmp_dir <- file.path(tempdir(), "testdir")
+ #'
|
- | 214 |
+ 129 |
|
- #' dir.create(tmp_dir)
+ #' @description `r lifecycle::badge("experimental")`
|
- | 215 |
+ 130 |
|
- #' reporter$to_list(tmp_dir)
+ #'
|
- | 216 |
+ 131 |
|
- to_list = function(output_dir) {
+ #' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments
|
-
- | 217 |
- 8x |
+
+ | 132 |
+ |
- checkmate::assert_directory_exists(output_dir)
+ #' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers.
|
-
- | 218 |
- 6x |
+
+ | 133 |
+ |
- rlist <- list(version = "1", cards = list())
+ #'
|
-
- | 219 |
- 6x |
+
+ | 134 |
+ |
- rlist[["metadata"]] <- self$get_metadata()
+ #' @details
|
-
- | 220 |
- 6x |
+
+ | 135 |
+ |
- for (card in self$get_cards()) {
+ #' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document.
|
- | 221 |
+ 136 |
|
- # we want to have list names being a class names to indicate the class for $from_list
+ #' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`,
|
-
- | 222 |
- 6x |
+
+ | 137 |
+ |
- card_class <- class(card)[1]
+ #' `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`.
|
-
- | 223 |
- 6x |
+
+ | 138 |
+ |
- u_card <- list()
+ #' Additionally, it handles `output` field types and arguments as defined in the `rmarkdown` package.
|
-
- | 224 |
- 6x |
+
+ | 139 |
+ |
- u_card[[card_class]] <- card$to_list(output_dir)
+ #'
|
-
- | 225 |
- 6x |
+
+ | 140 |
+ |
- rlist$cards <- c(rlist$cards, u_card)
+ #' @note Only non-nested lists are automatically parsed.
|
- | 226 |
+ 141 |
|
- }
+ #' Nested lists require direct processing with `yaml::as.yaml`.
|
-
- | 227 |
- 6x |
+
+ | 142 |
+ |
- rlist
+ #'
|
- | 228 |
+ 143 |
|
- },
+ #' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header.
|
- | 229 |
+ 144 |
|
- #' @description Create/Recreate a Reporter from a list and directory with files
+ #' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`.
|
- | 230 |
+ 145 |
|
- #' @param rlist `named list` `Reporter` representation.
+ #' @param convert_logi (`logical(1)`) convert a character values to logical,
|
- | 231 |
+ 146 |
|
- #' @param output_dir `character(1)` a path to the directory from which files will be copied.
+ #' if they are recognized as quoted `yaml` logical values , default `TRUE`.
|
- | 232 |
+ 147 |
|
- #' @return invisibly self
+ #' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`.
|
- | 233 |
+ 148 |
|
- #' @examples
+ #' @param silent (`logical(1)`) suppress messages and warnings, default `FALSE`.
|
- | 234 |
+ 149 |
|
- #' reporter <- Reporter$new()
+ #' @return `character` with `rmd_yaml_header` class,
|
- | 235 |
+ 150 |
|
- #' tmp_dir <- file.path(tempdir(), "testdir")
+ #' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`.
|
- | 236 |
+ 151 |
|
- #' unlink(tmp_dir, recursive = TRUE)
+ #' @export
|
- | 237 |
+ 152 |
|
- #' dir.create(tmp_dir)
+ #' @examples
|
- | 238 |
+ 153 |
|
- #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
+ #' # nested so using yaml::as.yaml directly
|
- | 239 |
+ 154 |
|
- from_list = function(rlist, output_dir) {
+ #' as_yaml_auto(
|
-
- | 240 |
- 10x |
+
+ | 155 |
+ |
- checkmate::assert_list(rlist)
+ #' list(author = "", output = list(pdf_document = list(toc = TRUE)))
|
-
- | 241 |
- 10x |
+
+ | 156 |
+ |
- checkmate::assert_directory_exists(output_dir)
+ #' )
|
-
- | 242 |
- 10x |
+
+ | 157 |
+ |
- if (rlist$version == "1") {
+ #'
|
-
- | 243 |
- 10x |
+
+ | 158 |
+ |
- new_cards <- list()
+ #' # auto parsing for a flat list, like shiny input
|
-
- | 244 |
- 10x |
+
+ | 159 |
+ |
- cards_names <- names(rlist$cards)
+ #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
|
-
- | 245 |
- 10x |
+
+ | 160 |
+ |
- cards_names <- gsub("[.][0-9]*$", "", cards_names)
+ #' as_yaml_auto(input)
|
-
- | 246 |
- 10x |
+
+ | 161 |
+ |
- for (iter_c in seq_along(rlist$cards)) {
+ #'
|
-
- | 247 |
- 16x |
+
+ | 162 |
+ |
- card_class <- cards_names[iter_c]
+ #' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
|
-
- | 248 |
- 16x |
+
+ | 163 |
+ |
- card <- rlist$cards[[iter_c]]
+ #'
|
-
- | 249 |
- 16x |
+
+ | 164 |
+ |
- new_card <- eval(str2lang(sprintf("%s$new()", card_class)))
+ #' as_yaml_auto(list(
|
-
- | 250 |
- 16x |
+
+ | 165 |
+ |
- new_card$from_list(card, output_dir)
+ #' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
|
-
- | 251 |
- 16x |
+
+ | 166 |
+ |
- new_cards <- c(new_cards, new_card)
+ #' wrong = 2
|
- | 252 |
+ 167 |
|
- }
+ #' ))
|
- | 253 |
+ 168 |
|
- } else {
+ #'
|
-
- | 254 |
- ! |
+
+ | 169 |
+ |
- stop("The provided version is not supported")
+ #' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
|
- | 255 |
+ 170 |
|
- }
+ #' silent = TRUE
|
-
- | 256 |
- 10x |
+
+ | 171 |
+ |
- self$reset()
+ #' )
|
-
- | 257 |
- 10x |
+
+ | 172 |
+ |
- self$append_cards(new_cards)
+ #'
|
-
- | 258 |
- 10x |
+
+ | 173 |
+ |
- self$append_metadata(rlist$metadata)
+ #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
|
-
- | 259 |
- 10x |
+
+ | 174 |
+ |
- invisible(self)
+ #' as_yaml_auto(input)
|
- | 260 |
+ 175 |
|
- },
+ #' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
|
- | 261 |
+ 176 |
|
- #' @description Create/Recreate a Reporter to a directory with `JSON` file and static files
+ #' as_yaml_auto(input, silent = TRUE)
|
- | 262 |
+ 177 |
|
- #' @param output_dir `character(1)` a path to the directory where files will be copied, `JSON` and statics.
+ #' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
|
- | 263 |
+ 178 |
|
- #' @return invisibly self
+ #'
|
- | 264 |
+ 179 |
|
- #' @examples
+ #' as_yaml_auto(
|
- | 265 |
+ 180 |
|
- #' reporter <- Reporter$new()
+ #' list(
|
- | 266 |
+ 181 |
|
- #' tmp_dir <- file.path(tempdir(), "jsondir")
+ #' author = "", output = "pdf_document",
|
- | 267 |
+ 182 |
|
- #' dir.create(tmp_dir)
+ #' output = "html_document", toc = TRUE, keep_tex = TRUE
|
- | 268 |
+ 183 |
|
- #' reporter$to_jsondir(tmp_dir)
+ #' ),
|
- | 269 |
+ 184 |
|
- to_jsondir = function(output_dir) {
+ #' multi_output = TRUE
|
-
- | 270 |
- 5x |
+
+ | 185 |
+ |
- checkmate::assert_directory_exists(output_dir)
+ #' )
|
-
- | 271 |
- 3x |
+
+ | 186 |
+ |
- json <- self$to_list(output_dir)
+ #' as_yaml_auto(
|
-
- | 272 |
- 3x |
+
+ | 187 |
+ |
- cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
+ #' list(
|
-
- | 273 |
- 3x |
+
+ | 188 |
+ |
- file = file.path(output_dir, "Report.json")
+ #' author = "", output = "pdf_document",
|
- | 274 |
+ 189 |
|
- )
+ #' output = "html_document", toc = "True", keep_tex = TRUE
|
-
- | 275 |
- 3x |
+
+ | 190 |
+ |
- output_dir
+ #' ),
|
- | 276 |
+ 191 |
|
- },
+ #' multi_output = TRUE
|
- | 277 |
+ 192 |
|
- #' @description Create/Recreate a Reporter from a directory with `JSON` file and static files
+ #' )
|
- | 278 |
+ 193 |
|
- #' @param output_dir `character(1)` a path to the directory with files, `JSON` and statics.
+ as_yaml_auto <- function(input_list,
|
- | 279 |
+ 194 |
|
- #' @return invisibly self
+ as_header = TRUE,
|
- | 280 |
+ 195 |
|
- #' @examples
+ convert_logi = TRUE,
|
- | 281 |
+ 196 |
|
- #' reporter <- Reporter$new()
+ multi_output = FALSE,
|
- | 282 |
+ 197 |
|
- #' tmp_dir <- file.path(tempdir(), "jsondir")
+ silent = FALSE) {
|
-
- | 283 |
- |
+
+ | 198 |
+ 16x |
- #' dir.create(tmp_dir)
+ checkmate::assert_logical(as_header)
|
-
- | 284 |
- |
+
+ | 199 |
+ 16x |
- #' unlink(list.files(tmp_dir, recursive = TRUE))
+ checkmate::assert_logical(convert_logi)
|
-
- | 285 |
- |
+
+ | 200 |
+ 16x |
- #' reporter$to_jsondir(tmp_dir)
+ checkmate::assert_logical(silent)
|
-
- | 286 |
- |
+
+ | 201 |
+ 16x |
- #' reporter$from_jsondir(tmp_dir)
+ checkmate::assert_logical(multi_output)
|
- | 287 |
+ 202 |
|
- from_jsondir = function(output_dir) {
+
|
- | 288 |
- 8x |
+ 203 |
+ 16x |
- checkmate::assert_directory_exists(output_dir)
+ if (multi_output) {
|
- | 289 |
- 8x |
+ 204 |
+ 1x |
- checkmate::assert_true(length(list.files(output_dir)) > 0)
+ checkmate::assert_list(input_list, names = "named")
|
-
- | 290 |
- 8x |
+
+ | 205 |
+ |
- dir_files <- list.files(output_dir)
+ } else {
|
- | 291 |
- 8x |
+ 206 |
+ 15x |
- which_json <- grep("json$", dir_files)
+ checkmate::assert_list(input_list, names = "unique")
|
-
- | 292 |
- 8x |
+
+ | 207 |
+ |
- json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
+ }
|
-
- | 293 |
- 8x |
+
+ | 208 |
+ |
- self$reset()
+
|
- | 294 |
- 8x |
+ 209 |
+ 13x |
- self$from_list(json, output_dir)
+ is_nested <- function(x) any(unlist(lapply(x, is.list)))
|
- | 295 |
- 8x |
+ 210 |
+ 13x |
- invisible(self)
+ if (is_nested(input_list)) {
|
-
- | 296 |
- |
+
+ | 211 |
+ 2x |
- }
+ result <- input_list
|
- | 297 |
+ 212 |
|
- ),
+ } else {
|
-
- | 298 |
- |
+
+ | 213 |
+ 11x |
- private = list(
+ result <- list()
|
-
- | 299 |
- |
+
+ | 214 |
+ 11x |
- cards = list(),
+ input_nams <- names(input_list)
|
- | 300 |
+ 215 |
|
- metadata = list(),
+
|
- | 301 |
+ 216 |
|
- reactive_add_card = NULL,
+ # top fields
|
-
- | 302 |
- |
+
+ | 217 |
+ 11x |
- # @description The copy constructor.
+ top_fields <- c(
|
-
- | 303 |
- |
+
+ | 218 |
+ 11x |
- #
+ "author", "date", "title", "subtitle", "abstract",
|
-
- | 304 |
- |
+
+ | 219 |
+ 11x |
- # @param name the name of the field
+ "keywords", "subject", "description", "category", "lang"
|
- | 305 |
+ 220 |
|
- # @param value the value of the field
+ )
|
-
- | 306 |
- |
+
+ | 221 |
+ 11x |
- # @return the new value of the field
+ for (itop in top_fields) {
|
-
- | 307 |
- |
+
+ | 222 |
+ 110x |
- #
+ if (itop %in% input_nams) {
|
-
- | 308 |
- |
+
+ | 223 |
+ 20x |
- deep_clone = function(name, value) {
+ result[[itop]] <- switch(itop,
|
- | 309 |
+ 224 |
20x |
- if (name == "cards") {
+ date = as.character(input_list[[itop]]),
|
- | 310 |
- 1x |
+ 225 |
+ 20x |
- lapply(value, function(card) card$clone(deep = TRUE))
+ input_list[[itop]]
|
- | 311 |
+ 226 |
|
- } else {
- |
-
-
- | 312 |
- 19x |
-
- value
+ )
|
- | 313 |
+ 227 |
|
}
|
- | 314 |
+ 228 |
|
}
|
- | 315 |
+ 229 |
|
- ),
+
|
- | 316 |
+ 230 |
|
- lock_objects = TRUE,
+ # output field
|
-
- | 317 |
- |
+
+ | 231 |
+ 11x |
- lock_class = TRUE
+ doc_types <- unlist(input_list[input_nams == "output"])
|
-
- | 318 |
- |
+
+ | 232 |
+ 11x |
- )
+ if (length(doc_types)) {
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 233 |
+ 11x |
- #' Download Button Reporter User Interface
+ for (dtype in doc_types) {
|
-
- | 2 |
- |
+
+ | 234 |
+ 12x |
- #' @description `r lifecycle::badge("experimental")`
+ doc_type_args <- rmd_output_arguments(dtype, TRUE)
|
-
- | 3 |
- |
+
+ | 235 |
+ 12x |
- #' button for downloading the Report.
+ doc_type_args_nams <- names(doc_type_args)
|
-
- | 4 |
- |
+
+ | 236 |
+ 12x |
- #'
+ any_output_arg <- any(input_nams %in% doc_type_args_nams)
|
- | 5 |
+ 237 |
|
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+
|
-
- | 6 |
- |
+
+ | 238 |
+ 12x |
- #' @param id `character(1)` this `shiny` module's id.
+ not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
|
-
- | 7 |
- |
+
+ | 239 |
+ 12x |
- #' @return `shiny::tagList`
+ if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
|
-
- | 8 |
- |
+
+ | 240 |
+ 1x |
- #' @export
+ warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
|
- | 9 |
+ 241 |
|
- download_report_button_ui <- function(id) {
+ }
|
-
- | 10 |
- 2x |
+
+ | 242 |
+ |
- ns <- shiny::NS(id)
+
|
- | 11 |
- 2x |
+ 243 |
+ 12x |
- shiny::tagList(
+ if (any_output_arg) {
|
- | 12 |
- 2x |
+ 244 |
+ 11x |
- shiny::singleton(
+ doc_list <- list()
|
- | 13 |
- 2x |
-
- shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
- |
-
-
- | 14 |
- |
+ 245 |
+ 11x |
- ),
+ doc_list[[dtype]] <- list()
|
- | 15 |
- 2x |
+ 246 |
+ 11x |
- shiny::tags$button(
+ for (e in intersect(input_nams, doc_type_args_nams)) {
|
- | 16 |
- 2x |
+ 247 |
+ 17x |
- id = ns("download_button"),
+ if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
|
- | 17 |
- 2x |
+ 248 |
+ 1x |
- type = "button",
+ pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
|
- | 18 |
- 2x |
+ 249 |
+ 1x |
- class = "simple_report_button btn btn-primary action-button",
+ neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
|
- | 19 |
- 2x |
+ 250 |
+ 1x |
- title = "Download",
+ all_logi <- c(pos_logi, neg_logi)
|
- | 20 |
- 2x |
+ 251 |
+ 1x |
- `data-val` = shiny::restoreInput(id = ns("download_button"), default = NULL),
+ if (input_list[[e]] %in% all_logi && convert_logi) {
|
- | 21 |
- 2x |
+ 252 |
+ 1x |
- NULL,
+ input_list[[e]] <- conv_str_logi(input_list[[e]], e,
|
- | 22 |
- 2x |
+ 253 |
+ 1x |
- shiny::tags$span(
+ pos_logi = pos_logi,
|
- | 23 |
- 2x |
-
- shiny::icon("download")
- |
-
-
- | 24 |
- |
+ 254 |
+ 1x |
- )
+ neg_logi = neg_logi, silent = silent
|
- | 25 |
+ 255 |
|
- )
+ )
|
- | 26 |
+ 256 |
|
- )
+ }
|
- | 27 |
+ 257 |
|
- }
+ }
|
- | 28 |
+ 258 |
|
|
-
- | 29 |
- |
+
+ | 259 |
+ 17x |
- #' Download Button Server
+ doc_list[[dtype]][[e]] <- input_list[[e]]
|
- | 30 |
+ 260 |
|
- #' @description `r lifecycle::badge("experimental")`
+ }
|
-
- | 31 |
- |
+
+ | 261 |
+ 11x |
- #' server for downloading the Report.
+ result[["output"]] <- append(result[["output"]], doc_list)
|
- | 32 |
+ 262 |
|
- #'
+ } else {
|
-
- | 33 |
- |
+
+ | 263 |
+ 1x |
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ result[["output"]] <- append(result[["output"]], input_list[["output"]])
|
- | 34 |
+ 264 |
|
- #' @param id `character(1)` this `shiny` module's id.
+ }
|
- | 35 |
+ 265 |
|
- #' @param reporter [`Reporter`] instance.
+ }
|
- | 36 |
+ 266 |
|
- #' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
+ }
|
- | 37 |
+ 267 |
|
- #' for customizing the rendering process.
+ }
|
- | 38 |
+ 268 |
|
- #' @inheritParams reporter_download_inputs
+
|
-
- | 39 |
- |
+
+ | 269 |
+ 13x |
- #' @return `shiny::moduleServer`
+ result <- yaml::as.yaml(result)
|
-
- | 40 |
- |
+
+ | 270 |
+ 13x |
- #' @details `r global_knitr_details()`
+ if (as_header) {
|
-
- | 41 |
- |
+
+ | 271 |
+ 12x |
- #'
+ result <- md_header(result)
|
- | 42 |
+ 272 |
|
- #' @export
+ }
|
-
- | 43 |
+
+ | 273 |
+ 13x |
+
+ structure(result, class = "rmd_yaml_header")
+ |
+
+
+ | 274 |
|
- download_report_button_srv <- function(id,
+ }
|
- | 44 |
+ 275 |
|
- reporter,
+
|
- | 45 |
+ 276 |
|
- global_knitr = getOption("teal.reporter.global_knitr"),
+ #' Print method for the `yaml_header` class
|
- | 46 |
+ 277 |
|
- rmd_output = c(
+ #'
|
- | 47 |
+ 278 |
|
- "html" = "html_document", "pdf" = "pdf_document",
+ #' `r lifecycle::badge("experimental")`
|
- | 48 |
+ 279 |
|
- "powerpoint" = "powerpoint_presentation", "word" = "word_document"
+ #'
|
- | 49 |
+ 280 |
|
- ),
+ #' @param x (`rmd_yaml_header`) class object.
|
- | 50 |
+ 281 |
|
- rmd_yaml_args = list(
+ #' @param ... optional text.
|
- | 51 |
+ 282 |
|
- author = "NEST", title = "Report",
+ #' @return `NULL`.
|
- | 52 |
+ 283 |
|
- date = as.character(Sys.Date()), output = "html_document",
+ #' @exportS3Method
|
- | 53 |
+ 284 |
|
- toc = FALSE
+ #' @examples
|
- | 54 |
+ 285 |
|
- )) {
+ #' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
|
-
- | 55 |
- 10x |
+
+ | 286 |
+ |
- checkmate::assert_class(reporter, "Reporter")
+ #' out <- as_yaml_auto(input)
|
-
- | 56 |
- 10x |
+
+ | 287 |
+ |
- checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
+ #' out
|
-
- | 57 |
- 10x |
+
+ | 288 |
+ |
- checkmate::assert_subset(
+ #' print(out)
|
-
- | 58 |
- 10x |
+
+ | 289 |
+ |
- rmd_output,
+ print.rmd_yaml_header <- function(x, ...) {
|
-
- | 59 |
- 10x |
+
+ | 290 |
+ ! |
- c(
+ cat(x, ...)
|
-
- | 60 |
- 10x |
+
+ | 291 |
+ |
- "html_document", "pdf_document",
+ }
|
-
- | 61 |
- 10x |
+
+ | 292 |
+ |
- "powerpoint_presentation", "word_document"
+
|
- | 62 |
+ 293 |
|
- ),
+ #' Extract field from `yaml` text
|
-
- | 63 |
- 10x |
+
+ | 294 |
+ |
- empty.ok = FALSE
+ #'
|
- | 64 |
+ 295 |
|
- )
+ #' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
|
-
- | 65 |
- 10x |
+
+ | 296 |
+ |
- checkmate::assert_list(rmd_yaml_args, names = "named")
+ #' otherwise, the field itself.
|
-
- | 66 |
- 10x |
+
+ | 297 |
+ |
- checkmate::assert_names(
+ #'
|
-
- | 67 |
- 10x |
+
+ | 298 |
+ |
- names(rmd_yaml_args),
+ #' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text.
|
-
- | 68 |
- 10x |
+
+ | 299 |
+ |
- subset.of = c("author", "title", "date", "output", "toc"),
+ #' @param field_name (`character`) the name of the field to extract.
|
-
- | 69 |
- 10x |
+
+ | 300 |
+ |
- must.include = "output"
+ #'
|
- | 70 |
+ 301 |
|
- )
+ #' @return If the field is a list, it returns the names of elements in the list; otherwise,
|
-
- | 71 |
- 8x |
+
+ | 302 |
+ |
- checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
+ #' it returns the extracted field.
|
- | 72 |
+ 303 |
|
-
+ #'
|
-
- | 73 |
- 7x |
+
+ | 304 |
+ |
- shiny::moduleServer(
+ #' @keywords internal
|
-
- | 74 |
- 7x |
+
+ | 305 |
+ |
- id,
+ get_yaml_field <- function(yaml_text, field_name) {
|
- | 75 |
- 7x |
+ 306 |
+ 8x |
- function(input, output, session) {
+ checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
|
- | 76 |
- 7x |
+ 307 |
+ 8x |
- ns <- session$ns
+ checkmate::assert_string(field_name)
|
- | 77 |
+ 308 |
|
|
- | 78 |
- 7x |
+ 309 |
+ 8x |
- download_modal <- function() {
+ yaml_obj <- yaml::yaml.load(yaml_text)
|
-
- | 79 |
- 1x |
+
+ | 310 |
+ |
- nr_cards <- length(reporter$get_cards())
+
|
- | 80 |
- 1x |
+ 311 |
+ 8x |
- downb <- shiny::tags$a(
+ result <- yaml_obj[[field_name]]
|
- | 81 |
- 1x |
+ 312 |
+ 8x |
- id = ns("download_data"),
+ if (is.list(result)) {
|
- | 82 |
- 1x |
+ 313 |
+ 5x |
- class = paste("btn btn-primary shiny-download-link", if (nr_cards) NULL else "disabled"),
+ result <- names(result)
|
-
- | 83 |
- 1x |
+
+ | 314 |
+ |
- style = if (nr_cards) NULL else "pointer-events: none;",
+ }
|
- | 84 |
- 1x |
+ 315 |
+ 8x |
- href = "",
- |
-
-
- | 85 |
- 1x |
-
- target = "_blank",
- |
-
-
- | 86 |
- 1x |
-
- download = NA,
- |
-
-
- | 87 |
- 1x |
-
- shiny::icon("download"),
- |
-
-
- | 88 |
- 1x |
-
- "Download"
+ result
|
- | 89 |
+ 316 |
|
- )
- |
-
-
- | 90 |
- 1x |
-
- shiny::modalDialog(
+ }
|
-
- | 91 |
- 1x |
+
+
+
+
+
+
+
+ | 1 |
+ |
- easyClose = TRUE,
+ #' Reset report button module
|
-
- | 92 |
- 1x |
+
+ | 2 |
+ |
- shiny::tags$h3("Download the Report"),
+ #'
|
-
- | 93 |
- 1x |
+
+ | 3 |
+ |
- shiny::tags$hr(),
+ #' @description `r lifecycle::badge("experimental")`
|
-
- | 94 |
- 1x |
+
+ | 4 |
+ |
- if (length(reporter$get_cards()) == 0) {
+ #'
|
-
- | 95 |
- ! |
+
+ | 5 |
+ |
- shiny::tags$div(
+ #' Provides a button that triggers resetting the report content.
|
-
- | 96 |
- ! |
+
+ | 6 |
+ |
- class = "mb-4",
+ #'
|
-
- | 97 |
- ! |
+
+ | 7 |
+ |
- shiny::tags$p(
+ #' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
|
-
- | 98 |
- ! |
+
+ | 8 |
+ |
- class = "text-danger",
+ #'
|
-
- | 99 |
- ! |
+
+ | 9 |
+ |
- shiny::tags$strong("No Cards Added")
+ #' @name reset_report_button
|
- | 100 |
+ 10 |
|
- )
+ #'
|
- | 101 |
+ 11 |
|
- )
+ #' @param id (`character(1)`) `shiny` module instance id.
|
- | 102 |
+ 12 |
|
- } else {
+ #' @param label (`character(1)`) label before the icon.
|
-
- | 103 |
- 1x |
+
+ | 13 |
+ |
- shiny::tags$div(
+ #' By default `NULL`.
|
-
- | 104 |
- 1x |
+
+ | 14 |
+ |
- class = "mb-4",
+ #' @param reporter (`Reporter`) instance.
|
-
- | 105 |
- 1x |
+
+ | 15 |
+ |
- shiny::tags$p(
+ #' @return `NULL`.
|
-
- | 106 |
- 1x |
+
+ | 16 |
+ |
- class = "text-success",
+ NULL
|
-
- | 107 |
- 1x |
+
+ | 17 |
+ |
- shiny::tags$strong(paste("Number of cards: ", nr_cards))
+
|
- | 108 |
+ 18 |
|
- ),
+ #' @rdname reset_report_button
|
- | 109 |
+ 19 |
|
- )
+ #' @export
|
- | 110 |
+ 20 |
|
- },
+ reset_report_button_ui <- function(id, label = NULL) {
|
- | 111 |
- 1x |
+ 21 |
+ 8x |
- reporter_download_inputs(
+ checkmate::assert_string(label, null.ok = TRUE)
+ |
+
+
+ | 22 |
+ |
+
+
|
- | 112 |
- 1x |
+ 23 |
+ 8x |
- rmd_yaml_args = rmd_yaml_args,
+ ns <- shiny::NS(id)
|
- | 113 |
- 1x |
+ 24 |
+ 8x |
- rmd_output = rmd_output,
+ shiny::tagList(
|
- | 114 |
- 1x |
+ 25 |
+ 8x |
- showrcode = any_rcode_block(reporter),
+ shiny::singleton(
|
- | 115 |
- 1x |
+ 26 |
+ 8x |
- session = session
+ shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
|
- | 116 |
+ 27 |
|
- ),
+ ),
|
- | 117 |
- 1x |
+ 28 |
+ 8x |
- footer = shiny::tagList(
+ shiny::tags$button(
|
- | 118 |
- 1x |
+ 29 |
+ 8x |
- shiny::tags$button(
+ id = ns("reset_reporter"),
|
- | 119 |
- 1x |
+ 30 |
+ 8x |
- type = "button",
+ type = "button",
|
- | 120 |
- 1x |
+ 31 |
+ 8x |
- class = "btn btn-secondary",
+ class = "simple_report_button btn btn-warning action-button",
|
- | 121 |
- 1x |
+ 32 |
+ 8x |
- `data-dismiss` = "modal",
+ title = "Reset",
|
- | 122 |
- 1x |
+ 33 |
+ 8x |
- `data-bs-dismiss` = "modal",
+ `data-val` = shiny::restoreInput(id = ns("reset_reporter"), default = NULL),
|
- | 123 |
- 1x |
+ 34 |
+ 8x |
- NULL,
+ NULL,
|
- | 124 |
- 1x |
+ 35 |
+ 8x |
- "Cancel"
+ shiny::tags$span(
|
-
- | 125 |
- |
+
+ | 36 |
+ 8x |
- ),
+ if (!is.null(label)) label,
|
- | 126 |
- 1x |
+ 37 |
+ 8x |
- downb
+ shiny::icon("xmark")
|
- | 127 |
+ 38 |
|
- )
+ )
|
- | 128 |
+ 39 |
|
- )
+ )
|
- | 129 |
+ 40 |
|
- }
+ )
|
- | 130 |
+ 41 |
+ |
+
+ }
+ |
+
+
+ | 42 |
|
|
-
- | 131 |
- 7x |
+
+ | 43 |
+ |
- shiny::observeEvent(input$download_button, {
+ #' @rdname reset_report_button
|
-
- | 132 |
- 1x |
+
+ | 44 |
+ |
- shiny::showModal(download_modal())
+ #' @export
|
- | 133 |
+ 45 |
|
- })
+ reset_report_button_srv <- function(id, reporter) {
+ |
+
+
+ | 46 |
+ 12x |
+
+ checkmate::assert_class(reporter, "Reporter")
|
- | 134 |
+ 47 |
|
|
- | 135 |
- 7x |
+ 48 |
+ 12x |
- output$download_data <- shiny::downloadHandler(
+ shiny::moduleServer(
|
- | 136 |
- 7x |
+ 49 |
+ 12x |
- filename = function() {
+ id,
|
- | 137 |
- 2x |
+ 50 |
+ 12x |
- paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
+ function(input, output, session) {
+ |
+
+
+ | 51 |
+ 12x |
+
+ ns <- session$ns
+ |
+
+
+ | 52 |
+ 12x |
+
+ nr_cards <- length(reporter$get_cards())
|
- | 138 |
+ 53 |
|
- },
+
+ |
+
+
+ | 54 |
+ |
+
+
|
- | 139 |
- 7x |
+ 55 |
+ 12x |
- content = function(file) {
+ shiny::observeEvent(input$reset_reporter, {
|
- | 140 |
- 2x |
+ 56 |
+ 1x |
- shiny::showNotification("Rendering and Downloading the document.")
+ shiny::showModal(
|
- | 141 |
- 2x |
+ 57 |
+ 1x |
- input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
+ shiny::modalDialog(
|
- | 142 |
- 2x |
+ 58 |
+ 1x |
- names(input_list) <- names(rmd_yaml_args)
+ shiny::tags$h3("Reset the Report"),
|
-
- | 143 |
- ! |
+
+ | 59 |
+ 1x |
- if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
+ shiny::tags$hr(),
|
- | 144 |
- 2x |
+ 60 |
+ 1x |
- report_render_and_compress(reporter, input_list, global_knitr, file)
+ shiny::tags$strong(
|
-
- | 145 |
- |
+
+ | 61 |
+ 1x |
- },
+ shiny::tags$p(
|
- | 146 |
- 7x |
+ 62 |
+ 1x |
- contentType = "application/zip"
+ "Are you sure you want to reset the report? (This will remove ALL previously added cards)."
|
- | 147 |
+ 63 |
|
- )
+ )
|
- | 148 |
+ 64 |
|
- }
+ ),
|
-
- | 149 |
- |
+
+ | 65 |
+ 1x |
- )
+ footer = shiny::tagList(
|
-
- | 150 |
- |
+
+ | 66 |
+ 1x |
- }
+ shiny::tags$button(
|
-
- | 151 |
- |
+
+ | 67 |
+ 1x |
-
+ type = "button",
|
-
- | 152 |
- |
+
+ | 68 |
+ 1x |
- #' Render the Report
+ class = "btn btn-secondary",
|
-
- | 153 |
- |
+
+ | 69 |
+ 1x |
- #' @description render the report and zip the created directory.
+ `data-dismiss` = "modal",
|
-
- | 154 |
- |
+
+ | 70 |
+ 1x |
- #' @param reporter [`Reporter`] instance.
+ `data-bs-dismiss` = "modal",
|
-
- | 155 |
- |
+
+ | 71 |
+ 1x |
- #' @param input_list `list` like shiny input converted to a regular named list.
+ NULL,
+ |
+
+
+ | 72 |
+ 1x |
+
+ "Cancel"
|
- | 156 |
+ 73 |
|
- #' @param global_knitr `list` a global `knitr` parameters, like echo.
+ ),
+ |
+
+
+ | 74 |
+ 1x |
+
+ shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn-danger")
|
- | 157 |
+ 75 |
|
- #' But if local parameter is set it will have priority.
+ )
|
- | 158 |
+ 76 |
|
- #' @param file `character` where to copy the returned directory.
+ )
|
- | 159 |
+ 77 |
|
- #' @return `file` argument, invisibly.
+ )
|
- | 160 |
+ 78 |
|
- #' @keywords internal
+ })
|
- | 161 |
+ 79 |
|
- report_render_and_compress <- function(reporter, input_list, global_knitr, file = tempdir()) {
+
|
- | 162 |
- 8x |
-
- checkmate::assert_class(reporter, "Reporter")
+ | 80 |
+ 12x |
+
+ shiny::observeEvent(input$reset_reporter_ok, {
|
- | 163 |
- 8x |
+ 81 |
+ 1x |
- checkmate::assert_list(input_list, names = "named")
+ reporter$reset()
|
- | 164 |
- 7x |
+ 82 |
+ 1x |
- checkmate::assert_string(file)
+ shiny::removeModal()
|
- | 165 |
+ 83 |
|
-
+ })
|
-
- | 166 |
- 5x |
+
+ | 84 |
+ |
- if (identical("pdf_document", input_list$output) &&
+ }
|
-
- | 167 |
- 5x |
+
+ | 85 |
+ |
- inherits(try(system2("pdflatex", "--version", stdout = TRUE), silent = TRUE), "try-error")) {
+ )
|
-
- | 168 |
- ! |
+
+ | 86 |
+ |
- shiny::showNotification(
+ }
|
-
- | 169 |
- ! |
+
+
+
+
+
+
+
+ | 1 |
+ |
- ui = "pdflatex is not available so the pdf_document could not be rendered. Please use other output type.",
+ #' Simple reporter module
|
-
- | 170 |
- ! |
+
+ | 2 |
+ |
- action = "Please contact app developer",
+ #'
|
-
- | 171 |
- ! |
+
+ | 3 |
+ |
- type = "error"
+ #' @description `r lifecycle::badge("experimental")`
|
- | 172 |
+ 4 |
|
- )
+ #'
|
-
- | 173 |
- ! |
+
+ | 5 |
+ |
- stop("pdflatex is not available so the pdf_document could not be rendered.")
+ #' Module provides compact UI and server functions for managing a report in a `shiny` app.
|
- | 174 |
+ 6 |
|
- }
+ #' This module combines functionalities for [adding cards to a report][add_card_button],
|
- | 175 |
+ 7 |
|
-
+ #' [downloading the report][download_report_button], and [resetting report content][reset_report_button].
|
-
- | 176 |
- 5x |
+
+ | 8 |
+ |
- yaml_header <- as_yaml_auto(input_list)
+ #'
|
-
- | 177 |
- 5x |
+
+ | 9 |
+ |
- renderer <- Renderer$new()
+ #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
|
- | 178 |
+ 10 |
|
-
+ #'
|
-
- | 179 |
- 5x |
+
+ | 11 |
+ |
- tryCatch(
+ #' @details `r global_knitr_details()`
|
-
- | 180 |
- 5x |
+
+ | 12 |
+ |
- renderer$render(reporter$get_blocks(), yaml_header, global_knitr),
+ #'
|
-
- | 181 |
- 5x |
+
+ | 13 |
+ |
- warning = function(cond) {
+ #' @name simple_reporter
|
-
- | 182 |
- ! |
+
+ | 14 |
+ |
- shiny::showNotification(
+ #'
|
-
- | 183 |
- ! |
+
+ | 15 |
+ |
- ui = "Render document warning!",
+ #' @param id (`character(1)`) `shiny` module instance id.
|
-
- | 184 |
- ! |
+
+ | 16 |
+ |
- action = "Please contact app developer",
+ #' @param reporter (`Reporter`) instance.
|
-
- | 185 |
- ! |
+
+ | 17 |
+ |
- type = "warning"
+ #' @param card_fun (`function`) which returns a [`ReportCard`] instance,
|
- | 186 |
+ 18 |
|
- )
+ #' the function has a `card` argument and an optional `comment` argument.
|
- | 187 |
+ 19 |
|
- },
+ #' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
|
-
- | 188 |
- 5x |
+
+ | 20 |
+ |
- error = function(cond) {
+ #' @inheritParams reporter_download_inputs
|
-
- | 189 |
- ! |
+
+ | 21 |
+ |
- shiny::showNotification(
+ #'
|
-
- | 190 |
- ! |
+
+ | 22 |
+ |
- ui = "Render document error!",
+ #' @return `NULL`.
|
-
- | 191 |
- ! |
+
+ | 23 |
+ |
- action = "Please contact app developer",
+ #'
|
-
- | 192 |
- ! |
+
+ | 24 |
+ |
- type = "error"
+ #' @examples
|
- | 193 |
+ 25 |
|
- )
+ #' library(shiny)
|
- | 194 |
+ 26 |
|
- }
+ #' if (interactive()) {
|
- | 195 |
+ 27 |
|
- )
+ #' shinyApp(
|
- | 196 |
+ 28 |
|
-
+ #' ui = fluidPage(simple_reporter_ui("simple")),
|
-
- | 197 |
- 5x |
+
+ | 29 |
+ |
- temp_zip_file <- tempfile(fileext = ".zip")
+ #' server = function(input, output, session) {
|
-
- | 198 |
- 5x |
+
+ | 30 |
+ |
- tryCatch(
+ #' simple_reporter_srv("simple", Reporter$new(), function(card) card)
|
-
- | 199 |
- 5x |
+
+ | 31 |
+ |
- expr = zip::zipr(temp_zip_file, renderer$get_output_dir()),
+ #' }
|
-
- | 200 |
- 5x |
+
+ | 32 |
+ |
- warning = function(cond) {
- |
-
-
- | 201 |
- ! |
-
- shiny::showNotification(
- |
-
-
- | 202 |
- ! |
-
- ui = "Zipping folder warning!",
- |
-
-
- | 203 |
- ! |
-
- action = "Please contact app developer",
- |
-
-
- | 204 |
- ! |
-
- type = "warning"
+ #' )
|
- | 205 |
+ 33 |
|
- )
+ #' }
|
- | 206 |
+ 34 |
|
- },
- |
-
-
- | 207 |
- 5x |
-
- error = function(cond) {
- |
-
-
- | 208 |
- ! |
-
- shiny::showNotification(
- |
-
-
- | 209 |
- ! |
-
- ui = "Zipping folder error!",
- |
-
-
- | 210 |
- ! |
-
- action = "Please contact app developer",
- |
-
-
- | 211 |
- ! |
-
- type = "error"
+ NULL
|
- | 212 |
+ 35 |
|
- )
+
|
- | 213 |
+ 36 |
|
- }
+ #' @rdname simple_reporter
|
- | 214 |
+ 37 |
|
- )
+ #' @export
|
- | 215 |
+ 38 |
|
-
+ simple_reporter_ui <- function(id) {
|
- | 216 |
- 5x |
+ 39 |
+ 1x |
- tryCatch(
+ ns <- shiny::NS(id)
|
- | 217 |
- 5x |
+ 40 |
+ 1x |
- expr = file.copy(temp_zip_file, file),
+ shiny::tagList(
|
- | 218 |
- 5x |
-
- warning = function(cond) {
- |
-
-
- | 219 |
- ! |
+ 41 |
+ 1x |
- shiny::showNotification(
+ shiny::singleton(
|
-
- | 220 |
- ! |
+
+ | 42 |
+ 1x |
- ui = "Copying file warning!",
+ shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
|
-
- | 221 |
- ! |
+
+ | 43 |
+ |
- action = "Please contact app developer",
+ ),
|
-
- | 222 |
- ! |
+
+ | 44 |
+ 1x |
- type = "warning"
+ shiny::tags$div(
|
-
- | 223 |
- |
+
+ | 45 |
+ 1x |
- )
+ class = "block mb-4 p-1",
|
-
- | 224 |
- |
+
+ | 46 |
+ 1x |
- },
+ shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
|
- | 225 |
- 5x |
+ 47 |
+ 1x |
- error = function(cond) {
+ shiny::tags$div(
|
-
- | 226 |
- ! |
+
+ | 48 |
+ 1x |
- shiny::showNotification(
+ class = "simple_reporter_container",
|
-
- | 227 |
- ! |
+
+ | 49 |
+ 1x |
- ui = "Copying file error!",
+ add_card_button_ui(ns("add_report_card_simple")),
|
-
- | 228 |
- ! |
+
+ | 50 |
+ 1x |
- action = "Please contact app developer",
+ download_report_button_ui(ns("download_button_simple")),
|
-
- | 229 |
- ! |
+
+ | 51 |
+ 1x |
- type = "error"
+ reset_report_button_ui(ns("reset_button_simple"))
|
- | 230 |
+ 52 |
|
)
|
- | 231 |
+ 53 |
|
- }
+ )
|
- | 232 |
+ 54 |
|
)
|
- | 233 |
+ 55 |
|
-
+ }
|
-
- | 234 |
- 5x |
+
+ | 56 |
+ |
- rm(renderer)
+
|
-
- | 235 |
- 5x |
+
+ | 57 |
+ |
- invisible(file)
+ #' @rdname simple_reporter
|
- | 236 |
+ 58 |
|
- }
+ #' @export
|
- | 237 |
+ 59 |
|
-
+ simple_reporter_srv <- function(id,
|
- | 238 |
+ 60 |
|
- #' Get the custom list of User Interface inputs
+ reporter,
|
- | 239 |
+ 61 |
|
- #' @param rmd_output `character` vector with `rmarkdown` output types,
+ card_fun,
|
- | 240 |
+ 62 |
|
- #' by default all possible `c("pdf_document", "html_document", "powerpoint_presentation", "word_document")`.
+ global_knitr = getOption("teal.reporter.global_knitr"),
|
- | 241 |
+ 63 |
|
- #' If vector is named then those names will appear in the `UI`.
+ rmd_output = c(
|
- | 242 |
+ 64 |
|
- #' @param rmd_yaml_args `named list` with `Rmd` `yaml` header fields and their default values.
+ "html" = "html_document", "pdf" = "pdf_document",
|
- | 243 |
+ 65 |
|
- #' This `list` will result in the custom subset of User Interface inputs for the download reporter functionality.
+ "powerpoint" = "powerpoint_presentation", "word" = "word_document"
|
- | 244 |
+ 66 |
|
- #' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`.
+ ),
|
- | 245 |
+ 67 |
|
- #' The `list` must include at least `"output"` field.
+ rmd_yaml_args = list(
|
- | 246 |
+ 68 |
|
- #' The default value for `"output"` has to be in the `rmd_output` argument.
+ author = "NEST", title = "Report",
|
- | 247 |
+ 69 |
|
- #' @keywords internal
+ date = as.character(Sys.Date()), output = "html_document",
|
- | 248 |
+ 70 |
|
- reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) {
- |
-
-
- | 249 |
- 8x |
-
- shiny::tagList(
+ toc = FALSE
|
-
- | 250 |
- 8x |
+
+ | 71 |
+ |
- lapply(names(rmd_yaml_args), function(e) {
+ )) {
|
- | 251 |
- 40x |
+ 72 |
+ 3x |
- switch(e,
+ shiny::moduleServer(
|
- | 252 |
- 8x |
+ 73 |
+ 3x |
- author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author),
+ id,
|
- | 253 |
- 8x |
+ 74 |
+ 3x |
- title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title),
+ function(input, output, session) {
|
- | 254 |
- 8x |
+ 75 |
+ 3x |
- date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date),
+ add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
|
- | 255 |
- 8x |
+ 76 |
+ 3x |
- output = shiny::tags$div(
+ download_report_button_srv(
|
- | 256 |
- 8x |
+ 77 |
+ 3x |
- shinyWidgets::pickerInput(
+ "download_button_simple",
|
- | 257 |
- 8x |
+ 78 |
+ 3x |
- inputId = session$ns("output"),
+ reporter = reporter,
|
- | 258 |
- 8x |
+ 79 |
+ 3x |
- label = "Choose a document type: ",
+ global_knitr = global_knitr,
|
- | 259 |
- 8x |
+ 80 |
+ 3x |
- choices = rmd_output,
+ rmd_output = rmd_output,
|
- | 260 |
- 8x |
-
- selected = rmd_yaml_args$output
- |
-
-
- | 261 |
- |
+ 81 |
+ 3x |
- )
+ rmd_yaml_args = rmd_yaml_args
|
- | 262 |
+ 82 |
|
- ),
+ )
|
- | 263 |
- 8x |
+ 83 |
+ 3x |
- toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc)
+ reset_report_button_srv("reset_button_simple", reporter = reporter)
|
- | 264 |
+ 84 |
|
- )
+ }
|
- | 265 |
+ 85 |
|
- }),
- |
-
-
- | 266 |
- 8x |
-
- if (showrcode) {
- |
-
-
- | 267 |
- ! |
-
- shiny::checkboxInput(
- |
-
-
- | 268 |
- ! |
-
- session$ns("showrcode"),
+ )
|
-
- | 269 |
- ! |
+
+ | 86 |
+ |
- label = "Include R Code",
+ }
|
-
- | 270 |
- ! |
+
+
+
+
+
+
+
+ | 1 |
+ |
- value = FALSE
+ #' @title `Renderer`
|
- | 271 |
+ 2 |
|
- )
+ #' @docType class
|
- | 272 |
+ 3 |
|
- }
+ #' @description
|
- | 273 |
+ 4 |
|
- )
+ #' A class for rendering reports from `ContentBlock` into various formats using `rmarkdown`.
|
- | 274 |
+ 5 |
|
- }
+ #' It supports `TextBlock`, `PictureBlock`, `RcodeBlock`, `NewpageBlock`, and `TableBlock`.
|
- | 275 |
+ 6 |
|
-
+ #'
|
- | 276 |
+ 7 |
|
#' @keywords internal
|
- | 277 |
+ 8 |
|
- any_rcode_block <- function(reporter) {
- |
-
-
- | 278 |
- 10x |
-
- any(
- |
-
-
- | 279 |
- 10x |
-
- vapply(
- |
-
-
- | 280 |
- 10x |
-
- reporter$get_blocks(),
- |
-
-
- | 281 |
- 10x |
-
- function(e) inherits(e, "RcodeBlock"),
- |
-
-
- | 282 |
- 10x |
-
- logical(1)
+ Renderer <- R6::R6Class( # nolint: object_name_linter.
|
- | 283 |
+ 9 |
|
- )
+ classname = "Renderer",
|
- | 284 |
+ 10 |
|
- )
+ public = list(
|
- | 285 |
+ 11 |
|
- }
+ #' @description Initialize a `Renderer` object.
|
-
-
-
-
-
-
- | 1 |
+ 12 |
|
- #' @title `Archiver`
+ #'
|
- | 2 |
+ 13 |
|
- #' @keywords internal
+ #' @details Creates a new instance of `Renderer`
|
- | 3 |
+ 14 |
|
- Archiver <- R6::R6Class( # nolint: object_name_linter.
+ #' with a temporary directory for storing report files.
|
- | 4 |
+ 15 |
|
- classname = "Archiver",
+ #'
|
- | 5 |
+ 16 |
|
- public = list(
+ #' @return Object of class `Renderer`, invisibly.
|
- | 6 |
+ 17 |
|
- #' @description Returns an `Archiver` object.
+ #' @examples
|
- | 7 |
+ 18 |
|
- #'
+ #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
|
- | 8 |
+ 19 |
|
- #' @return an `Archiver` object
+ #' Renderer$new()
|
- | 9 |
+ 20 |
|
- #' @examples
+ #'
|
- | 10 |
+ 21 |
|
- #' Archiver <- getFromNamespace("Archiver", "teal.reporter")
- |
-
-
- | 11 |
- |
-
- #' Archiver$new()
- |
-
-
- | 12 |
- |
-
- initialize = function() {
- |
-
-
- | 13 |
- 3x |
-
- invisible(self)
- |
-
-
- | 14 |
- |
-
- },
- |
-
-
- | 15 |
- |
-
- #' @description Finalizes an `Archiver` object.
- |
-
-
- | 16 |
- |
-
- finalize = function() {
- |
-
-
- | 17 |
- |
-
- # destructor
- |
-
-
- | 18 |
- |
-
- },
- |
-
-
- | 19 |
- |
-
- #' @description Pure virtual method for reading an `Archiver`.
- |
-
-
- | 20 |
- |
-
- read = function() {
- |
-
-
- | 21 |
- |
-
- # returns Reporter instance
+ initialize = function() {
|
| 22 |
- 1x |
+ 10x |
- stop("Pure virtual method.")
+ tmp_dir <- tempdir()
|
-
+
| 23 |
- |
+ 10x |
- },
+ output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
|
-
+
| 24 |
- |
+ 10x |
- #' @description Pure virtual method for writing an `Archiver`.
+ dir.create(path = output_dir)
|
-
+
| 25 |
- |
+ 10x |
- write = function() {
+ private$output_dir <- output_dir
|
| 26 |
- 1x |
+ 10x |
- stop("Pure virtual method.")
+ invisible(self)
|
| 27 |
|
- }
+ },
|
| 28 |
|
- ),
+ #' @description Finalizes a `Renderer` object.
|
| 29 |
|
- lock_objects = TRUE,
+ finalize = function() {
|
-
+
| 30 |
- |
+ 10x |
- lock_class = TRUE
+ unlink(private$output_dir, recursive = TRUE)
|
| 31 |
|
- )
+ },
|
| 32 |
|
-
+ #' @description Getting the `Rmd` text which could be easily rendered later.
|
| 33 |
|
- #' @title `RDSArchiver`
+ #'
|
| 34 |
|
- #' @keywords internal
+ #' @param blocks (`list`) of `TextBlock`, `PictureBlock` and `NewpageBlock` objects.
|
| 35 |
|
- FileArchiver <- R6::R6Class( # nolint: object_name_linter.
+ #' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
|
| 36 |
|
- classname = "FileArchiver",
+ #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
|
| 37 |
|
- inherit = Archiver,
+ #' for customizing the rendering process.
|
| 38 |
|
- public = list(
+ #' @details `r global_knitr_details()`
|
| 39 |
|
- #' @description Returns a `FileArchiver` object.
+ #'
|
| 40 |
|
- #'
+ #' @return Character vector constituting `rmarkdown` text (`yaml` header + body), ready to be rendered.
|
| 41 |
|
- #' @return a `FileArchiver` object
+ #' @examples
|
| 42 |
|
- #' @examples
+ #' library(yaml)
|
| 43 |
|
- #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
+ #' library(rtables)
|
| 44 |
|
- #' FileArchiver$new()
+ #' library(ggplot2)
|
| 45 |
|
- initialize = function() {
+ #'
|
-
+
| 46 |
- 10x |
+ |
- tmp_dir <- tempdir()
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
-
+
| 47 |
- 10x |
+ |
- output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
+ #' card1 <- ReportCard$new()
|
-
+
| 48 |
- 10x |
+ |
- dir.create(path = output_dir)
+ #'
|
-
+
| 49 |
- 10x |
+ |
- private$output_dir <- output_dir
+ #' card1$append_text("Header 2 text", "header2")
|
-
+
| 50 |
- 10x |
+ |
- invisible(self)
+ #' card1$append_text("A paragraph of default text")
|
| 51 |
|
- },
+ #' card1$append_plot(
|
| 52 |
|
- #' @description Finalizes a `FileArchiver` object.
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
| 53 |
|
- finalize = function() {
+ #' )
|
-
+
| 54 |
- 10x |
+ |
- unlink(private$output_dir, recursive = TRUE)
+ #'
|
| 55 |
|
- },
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
| 56 |
|
- #' @description get `output_dir` field
+ #' card2 <- ReportCard$new()
|
@@ -18014,1619 +17768,3062 @@ teal.reporter coverage - 82.57%
58 |
|
- #' @return `character` a `output_dir` field path.
+ #' card2$append_text("Header 2 text", "header2")
|
| 59 |
|
- #' @examples
+ #' card2$append_text("A paragraph of default text", "header2")
|
| 60 |
|
- #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
+ #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
|
| 61 |
|
- #' FileArchiver$new()$get_output_dir()
+ #' table_res2 <- build_table(lyt, airquality)
|
| 62 |
|
- get_output_dir = function() {
+ #' card2$append_table(table_res2)
|
-
+
| 63 |
- 9x |
+ |
- private$output_dir
+ #' card2$append_table(iris)
|
| 64 |
|
- }
+ #' card2$append_rcode("2+2", echo = FALSE)
|
| 65 |
|
- ),
+ #'
|
| 66 |
|
- private = list(
+ #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
|
| 67 |
|
- output_dir = character(0)
+ #' reporter <- Reporter$new()
|
| 68 |
|
- )
+ #' reporter$append_cards(list(card1, card2))
|
| 69 |
|
- )
+ #'
|
| 70 |
|
-
+ #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
|
| 71 |
|
- #' @title `JSONArchiver`
+ #' yaml_l <- list(
|
| 72 |
|
- #' @keywords internal
+ #' author = yaml_quoted("NEST"),
|
| 73 |
|
- JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
+ #' title = yaml_quoted("Report"),
|
| 74 |
|
- classname = "JSONArchiver",
+ #' date = yaml_quoted("07/04/2019"),
|
| 75 |
|
- inherit = FileArchiver,
+ #' output = list(html_document = list(toc = FALSE))
|
| 76 |
|
- public = list(
+ #' )
|
| 77 |
|
- #' @description write a `Reporter` instance in to this `JSONArchiver` object.
+ #'
|
| 78 |
|
- #'
+ #' md_header <- getFromNamespace("md_header", "teal.reporter")
|
| 79 |
|
- #' @param reporter `Reporter` instance.
+ #' yaml_header <- md_header(as.yaml(yaml_l))
|
| 80 |
|
- #'
+ #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
|
| 81 |
|
- #' @return invisibly self
+ #' result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
|
| 82 |
|
- #' @examples
+ #'
|
| 83 |
|
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ renderRmd = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr")) {
|
-
+
| 84 |
- |
+ 8x |
- #' card1 <- ReportCard$new()
+ checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
|
-
+
| 85 |
- |
+ 7x |
- #'
+ checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
|
| 86 |
|
- #' card1$append_text("Header 2 text", "header2")
+
|
-
+
| 87 |
- |
+ 7x |
- #' card1$append_text("A paragraph of default text", "header2")
+ if (missing(yaml_header)) {
|
-
+
| 88 |
- |
+ 2x |
- #' card1$append_plot(
+ yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
|
| 89 |
|
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ }
|
| 90 |
|
- #' )
+
|
-
+
| 91 |
- |
+ 7x |
- #'
+ private$report_type <- get_yaml_field(yaml_header, "output")
|
| 92 |
|
- #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
+
|
-
+
| 93 |
- |
+ 7x |
- #' reporter <- Reporter$new()
+ parsed_global_knitr <- sprintf(
|
-
+
| 94 |
- |
+ 7x |
- #' reporter$append_cards(list(card1))
+ "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n%s\n```\n",
|
-
+
| 95 |
- |
+ 7x |
- #'
+ capture.output(dput(global_knitr)),
|
-
+
| 96 |
- |
+ 7x |
- #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
+ if (identical(private$report_type, "powerpoint_presentation")) {
|
-
+
| 97 |
- |
+ ! |
- #' archiver <- JSONArchiver$new()
+ format_code_block_function <- quote(
|
-
+
| 98 |
- |
+ ! |
- #' archiver$write(reporter)
+ code_block <- function(code_text) {
|
-
+
| 99 |
- |
+ ! |
- #' archiver$get_output_dir()
+ df <- data.frame(code_text)
|
-
+
| 100 |
- |
+ ! |
- write = function(reporter) {
+ ft <- flextable::flextable(df)
|
-
+
| 101 |
- 1x |
+ ! |
- checkmate::assert_class(reporter, "Reporter")
+ ft <- flextable::delete_part(ft, part = "header")
|
-
+
| 102 |
- 1x |
+ ! |
- unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
+ ft <- flextable::autofit(ft, add_h = 0)
|
-
+
| 103 |
- 1x |
+ ! |
- reporter$to_jsondir(private$output_dir)
+ ft <- flextable::fontsize(ft, size = 7, part = "body")
|
-
+
| 104 |
- 1x |
+ ! |
- self
+ ft <- flextable::bg(x = ft, bg = "lightgrey")
|
-
+
| 105 |
- |
+ ! |
- },
+ ft <- flextable::border_outer(ft)
|
-
+
| 106 |
- |
+ ! |
- #' @description read a `Reporter` instance from a directory with `JSONArchiver`.
+ if (flextable::flextable_dim(ft)$widths > 8) {
|
-
+
| 107 |
- |
+ ! |
- #'
+ ft <- flextable::width(ft, width = 8)
|
| 108 |
|
- #' @param path `character(1)` a path to the directory with all proper files.
+ }
|
-
+
| 109 |
- |
+ ! |
- #'
+ ft
|
| 110 |
|
- #' @return `Reporter` instance.
+ }
|
| 111 |
|
- #' @examples
+ )
|
-
+
| 112 |
- |
+ ! |
- #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
+ paste(deparse(format_code_block_function), collapse = "\n")
|
| 113 |
|
- #' card1 <- ReportCard$new()
+ } else {
|
| 114 |
|
- #'
+ ""
|
| 115 |
|
- #' card1$append_text("Header 2 text", "header2")
+ }
|
| 116 |
|
- #' card1$append_text("A paragraph of default text", "header2")
+ )
|
| 117 |
|
- #' card1$append_plot(
+
|
-
+
| 118 |
- |
+ 7x |
- #' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
+ parsed_blocks <- paste(
|
-
+
| 119 |
- |
+ 7x |
- #' )
+ unlist(
|
-
+
| 120 |
- |
+ 7x |
- #'
+ lapply(blocks, function(b) private$block2md(b))
|
| 121 |
|
- #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
+ ),
|
-
+
| 122 |
- |
+ 7x |
- #' reporter <- Reporter$new()
+ collapse = "\n\n"
|
| 123 |
|
- #' reporter$append_cards(list(card1))
+ )
|
| 124 |
|
- #'
+
|
-
+
| 125 |
- |
+ 7x |
- #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
+ rmd_text <- paste0(yaml_header, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
|
-
+
| 126 |
- |
+ 7x |
- #' archiver <- JSONArchiver$new()
+ tmp <- tempfile(fileext = ".Rmd")
|
-
+
| 127 |
- |
+ 7x |
- #' archiver$write(reporter)
+ input_path <- file.path(
|
-
+
| 128 |
- |
+ 7x |
- #' archiver$get_output_dir()
+ private$output_dir,
|
-
+
| 129 |
- |
+ 7x |
- #'
+ sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
|
| 130 |
|
- #' archiver$read()$get_cards()[[1]]$get_content()
+ )
|
-
+
| 131 |
- |
+ 7x |
- #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
+ cat(rmd_text, file = input_path)
|
-
+
| 132 |
- |
+ 7x |
- #' blocks <- Reporter$new()
+ input_path
|
| 133 |
|
- #' blocks <- blocks$from_reporter(archiver$read())$get_blocks()
+ },
|
| 134 |
|
- #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
+ #' @description Renders the `Report` to the desired output format by compiling the `rmarkdown` file.
|
| 135 |
|
- #' doc <- Renderer$new()$render(blocks)
+ #'
|
| 136 |
|
- read = function(path = NULL) {
+ #' @param blocks (`list`) of `TextBlock`, `PictureBlock` or `NewpageBlock` objects.
|
-
+
| 137 |
- 7x |
+ |
- checkmate::assert(
+ #' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
|
-
+
| 138 |
- 7x |
+ |
- checkmate::check_null(path),
+ #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
|
-
+
| 139 |
- 7x |
+ |
- checkmate::check_directory_exists(path)
+ #' for customizing the rendering process.
|
| 140 |
|
- )
+ #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
|
| 141 |
|
-
+ #' @details `r global_knitr_details()`
|
-
+
| 142 |
- 7x |
+ |
- if (!is.null(path) && !identical(path, private$output_dir)) {
+ #'
|
-
+
| 143 |
- 3x |
+ |
- unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
+ #' @return `character` path to the output.
|
-
+
| 144 |
- 3x |
+ |
- file.copy(list.files(path, full.names = TRUE), private$output_dir)
+ #' @examples
|
| 145 |
|
- }
+ #' library(yaml)
|
| 146 |
|
-
+ #' library(ggplot2)
|
-
+
| 147 |
- 7x |
+ |
- if (length(list.files(private$output_dir))) {
+ #'
|
-
+
| 148 |
- 6x |
+ |
- Reporter$new()$from_jsondir(private$output_dir)
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
| 149 |
|
- } else {
+ #' card1 <- ReportCard$new()
|
-
+
| 150 |
- 1x |
+ |
- warning("The directory provided to the Archiver is empty.")
+ #'
|
-
+
| 151 |
- 1x |
+ |
- Reporter$new()
+ #' card1$append_text("Header 2 text", "header2")
|
| 152 |
|
- }
+ #' card1$append_text("A paragraph of default text")
|
| 153 |
|
- }
+ #' card1$append_plot(
|
| 154 |
|
- ),
+ #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
|
| 155 |
|
- lock_objects = TRUE,
+ #' )
|
| 156 |
|
- lock_class = TRUE
+ #'
|
| 157 |
|
- )
+ #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
|
-
-
-
-
-
-
- | 1 |
+ 158 |
|
- #' @title `TableBlock`
+ #' card2 <- ReportCard$new()
|
- | 2 |
+ 159 |
|
- #' @keywords internal
+ #'
|
- | 3 |
+ 160 |
|
- TableBlock <- R6::R6Class( # nolint: object_name_linter.
+ #' card2$append_text("Header 2 text", "header2")
|
- | 4 |
+ 161 |
|
- classname = "TableBlock",
+ #' card2$append_text("A paragraph of default text", "header2")
|
- | 5 |
+ 162 |
|
- inherit = FileBlock,
+ #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
|
- | 6 |
+ 163 |
|
- public = list(
+ #' table_res2 <- build_table(lyt, airquality)
|
- | 7 |
+ 164 |
|
- #' @description Returns a new `TableBlock` object
+ #' card2$append_table(table_res2)
|
- | 8 |
+ 165 |
|
- #'
+ #' card2$append_table(iris)
|
- | 9 |
+ 166 |
|
- #' @param table (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`) a table assigned to
+ #' card2$append_rcode("2+2", echo = FALSE)
|
- | 10 |
+ 167 |
|
- #' this `TableBlock`
+ #' Reporter <- getFromNamespace("Reporter", "teal.reporter")$new()
|
- | 11 |
+ 168 |
|
- #'
+ #' Reporter$append_cards(list(card1, card2))
|
- | 12 |
+ 169 |
|
- #' @return a `TableBlock` object
+ #'
|
- | 13 |
+ 170 |
|
- initialize = function(table) {
+ #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
|
-
- | 14 |
- 36x |
+
+ | 171 |
+ |
- if (!missing(table)) {
+ #' yaml_l <- list(
|
-
- | 15 |
- 6x |
+
+ | 172 |
+ |
- self$set_content(table)
+ #' author = yaml_quoted("NEST"),
|
- | 16 |
+ 173 |
|
- }
+ #' title = yaml_quoted("Report"),
|
-
- | 17 |
- 36x |
+
+ | 174 |
+ |
- invisible(self)
+ #' date = yaml_quoted("07/04/2019"),
|
- | 18 |
+ 175 |
|
- },
+ #' output = list(html_document = list(toc = FALSE))
|
- | 19 |
+ 176 |
|
- #' @description Sets content of this `TableBlock`.
+ #' )
|
- | 20 |
+ 177 |
|
#'
|
- | 21 |
+ 178 |
|
- #' @details throws if argument is not a table-like object.
+ #' md_header <- getFromNamespace("md_header", "teal.reporter")
|
- | 22 |
+ 179 |
|
- #'
+ #' yaml_header <- md_header(as.yaml(yaml_l))
|
- | 23 |
+ 180 |
|
- #' @param content (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`) a table assigned to
+ #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
|
- | 24 |
+ 181 |
|
- #' this `TableBlock`
+ #' result_path <- Renderer$new()$render(Reporter$get_blocks(), yaml_header)
|
- | 25 |
+ 182 |
|
#'
|
- | 26 |
+ 183 |
|
- #' @return invisibly self
+ render = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
|
-
- | 27 |
- |
+
+ | 184 |
+ 6x |
- #' @examples
+ args <- list(...)
|
-
- | 28 |
- |
+
+ | 185 |
+ 6x |
- #' TableBlock <- getFromNamespace("TableBlock", "teal.reporter")
+ input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
|
-
- | 29 |
- |
+
+ | 186 |
+ 6x |
- #' block <- TableBlock$new()
+ args <- append(args, list(
|
-
- | 30 |
- |
+
+ | 187 |
+ 6x |
- #' block$set_content(iris)
+ input = input_path,
|
-
- | 31 |
- |
+
+ | 188 |
+ 6x |
- #'
+ output_dir = private$output_dir,
|
-
- | 32 |
- |
+
+ | 189 |
+ 6x |
- set_content = function(content) {
+ output_format = "all",
|
- | 33 |
- 15x |
+ 190 |
+ 6x |
- checkmate::assert_multi_class(content, private$supported_tables)
+ quiet = TRUE
|
-
- | 34 |
- 14x |
+
+ | 191 |
+ |
- content <- to_flextable(content)
+ ))
|
- | 35 |
- 14x |
+ 192 |
+ 6x |
- path <- tempfile(fileext = ".rds")
+ args_nams <- unique(names(args))
|
- | 36 |
- 14x |
+ 193 |
+ 6x |
- saveRDS(content, file = path)
+ args <- lapply(args_nams, function(x) args[[x]])
|
- | 37 |
- 14x |
+ 194 |
+ 6x |
- super$set_content(path)
+ names(args) <- args_nams
|
- | 38 |
- 14x |
+ 195 |
+ 6x |
- invisible(self)
+ do.call(rmarkdown::render, args)
|
- | 39 |
+ 196 |
|
- }
+ },
|
- | 40 |
+ 197 |
|
- ),
+ #' @description Get `output_dir` field.
|
- | 41 |
+ 198 |
|
- private = list(
+ #'
|
- | 42 |
+ 199 |
|
- supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df")
+ #' @return `character` a `output_dir` field path.
|
- | 43 |
+ 200 |
|
- ),
+ #' @examples
|
- | 44 |
+ 201 |
|
- lock_objects = TRUE,
+ #' Renderer <- getFromNamespace("Renderer", "teal.reporter")$new()
|
- | 45 |
+ 202 |
|
- lock_class = TRUE
+ #' Renderer$get_output_dir()
|
- | 46 |
+ 203 |
|
- )
+ #'
|
-
-
-
-
-
-
- | 1 |
+ 204 |
|
- #' Reset Button Reporter User Interface
+ get_output_dir = function() {
|
-
- | 2 |
- |
+
+ | 205 |
+ 7x |
+
+ private$output_dir
+ |
+
+
+ | 206 |
+ |
+
+ }
+ |
+
+
+ | 207 |
+ |
+
+ ),
+ |
+
+
+ | 208 |
+ |
+
+ private = list(
+ |
+
+
+ | 209 |
+ |
+
+ output_dir = character(0),
+ |
+
+
+ | 210 |
+ |
+
+ report_type = NULL,
+ |
+
+
+ | 211 |
+ |
+
+ # factory method
+ |
+
+
+ | 212 |
+ |
+
+ block2md = function(block) {
+ |
+
+
+ | 213 |
+ 25x |
+
+ if (inherits(block, "TextBlock")) {
+ |
+
+
+ | 214 |
+ 14x |
+
+ private$textBlock2md(block)
+ |
+
+
+ | 215 |
+ 11x |
+
+ } else if (inherits(block, "RcodeBlock")) {
+ |
+
+
+ | 216 |
+ ! |
+
+ private$rcodeBlock2md(block)
+ |
+
+
+ | 217 |
+ 11x |
+
+ } else if (inherits(block, "PictureBlock")) {
+ |
+
+
+ | 218 |
+ 7x |
+
+ private$pictureBlock2md(block)
+ |
+
+
+ | 219 |
+ 4x |
+
+ } else if (inherits(block, "TableBlock")) {
+ |
+
+
+ | 220 |
+ 2x |
+
+ private$tableBlock2md(block)
+ |
+
+
+ | 221 |
+ 2x |
+
+ } else if (inherits(block, "NewpageBlock")) {
+ |
+
+
+ | 222 |
+ 2x |
+
+ block$get_content()
+ |
+
+
+ | 223 |
+ |
+
+ } else {
+ |
+
+
+ | 224 |
+ ! |
+
+ stop("Unknown block class")
+ |
+
+
+ | 225 |
+ |
+
+ }
+ |
+
+
+ | 226 |
+ |
+
+ },
+ |
+
+
+ | 227 |
+ |
+
+ # card specific methods
+ |
+
+
+ | 228 |
+ |
+
+ textBlock2md = function(block) {
+ |
+
+
+ | 229 |
+ 14x |
+
+ text_style <- block$get_style()
+ |
+
+
+ | 230 |
+ 14x |
+
+ block_content <- block$get_content()
+ |
+
+
+ | 231 |
+ 14x |
+
+ switch(text_style,
+ |
+
+
+ | 232 |
+ 2x |
+
+ "default" = block_content,
+ |
+
+
+ | 233 |
+ ! |
+
+ "verbatim" = sprintf("\n```\n%s\n```\n", block_content),
+ |
+
+
+ | 234 |
+ 12x |
+
+ "header2" = paste0("## ", block_content),
+ |
+
+
+ | 235 |
+ ! |
+
+ "header3" = paste0("### ", block_content),
+ |
+
+
+ | 236 |
+ ! |
+
+ block_content
+ |
+
+
+ | 237 |
+ |
+
+ )
+ |
+
+
+ | 238 |
+ |
+
+ },
+ |
+
+
+ | 239 |
+ |
+
+ rcodeBlock2md = function(block) {
+ |
+
+
+ | 240 |
+ ! |
+
+ params <- block$get_params()
+ |
+
+
+ | 241 |
+ ! |
+
+ params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
+ |
+
+
+ | 242 |
+ ! |
+
+ if (identical(private$report_type, "powerpoint_presentation")) {
+ |
+
+
+ | 243 |
+ ! |
+
+ block_content_list <- split_text_block(block$get_content(), 30)
+ |
+
+
+ | 244 |
+ ! |
+
+ paste(
+ |
+
+
+ | 245 |
+ ! |
+
+ sprintf(
+ |
+
+
+ | 246 |
+ ! |
+
+ "\\newpage\n\n---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
+ |
+
+
+ | 247 |
+ ! |
+
+ shQuote(block_content_list, type = "cmd")
+ |
+
+
+ | 248 |
+ |
+
+ ),
+ |
+
+
+ | 249 |
+ ! |
+
+ collapse = "\n\n"
+ |
+
+
+ | 250 |
+ |
+
+ )
+ |
+
+
+ | 251 |
+ |
+
+ } else {
+ |
+
+
+ | 252 |
+ ! |
+
+ sprintf(
+ |
+
+
+ | 253 |
+ ! |
+
+ "\\newpage\n\n--- \n\n```{r, %s}\n%s\n```\n",
+ |
+
+
+ | 254 |
+ ! |
+
+ paste(names(params), params, sep = "=", collapse = ", "),
+ |
+
+
+ | 255 |
+ ! |
+
+ block$get_content()
+ |
+
+
+ | 256 |
+ |
+
+ )
+ |
+
+
+ | 257 |
+ |
+
+ }
+ |
+
+
+ | 258 |
+ |
+
+ },
+ |
+
+
+ | 259 |
+ |
+
+ pictureBlock2md = function(block) {
+ |
+
+
+ | 260 |
+ 7x |
+
+ basename_pic <- basename(block$get_content())
+ |
+
+
+ | 261 |
+ 7x |
+
+ file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
+ |
+
+
+ | 262 |
+ 7x |
+
+ params <- c(
+ |
+
+
+ | 263 |
+ 7x |
+
+ `out.width` = "'100%'",
+ |
+
+
+ | 264 |
+ 7x |
+
+ `out.height` = "'100%'"
+ |
+
+
+ | 265 |
+ |
+
+ )
+ |
+
+
+ | 266 |
+ 7x |
+
+ title <- block$get_title()
+ |
+
+
+ | 267 |
+ 7x |
+
+ if (length(title)) params["fig.cap"] <- shQuote(title)
+ |
+
+
+ | 268 |
+ 7x |
+
+ sprintf(
+ |
+
+
+ | 269 |
+ 7x |
+
+ "\n```{r, echo = FALSE, %s}\nknitr::include_graphics(path = '%s')\n```\n",
+ |
+
+
+ | 270 |
+ 7x |
+
+ paste(names(params), params, sep = "=", collapse = ", "),
+ |
+
+
+ | 271 |
+ 7x |
+
+ basename_pic
+ |
+
+
+ | 272 |
+ |
+
+ )
+ |
+
+
+ | 273 |
+ |
+
+ },
+ |
+
+
+ | 274 |
+ |
+
+ tableBlock2md = function(block) {
+ |
+
+
+ | 275 |
+ 2x |
+
+ basename_table <- basename(block$get_content())
+ |
+
+
+ | 276 |
+ 2x |
+
+ file.copy(block$get_content(), file.path(private$output_dir, basename_table))
+ |
+
+
+ | 277 |
+ 2x |
+
+ sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
+ |
+
+
+ | 278 |
+ |
+
+ }
+ |
+
+
+ | 279 |
+ |
+
+ ),
+ |
+
+
+ | 280 |
+ |
+
+ lock_objects = TRUE,
+ |
+
+
+ | 281 |
+ |
+
+ lock_class = TRUE
+ |
+
+
+ | 282 |
+ |
+
+ )
+ |
+
+
+
+
+
+
+
+
+ | 1 |
+ |
+
+ #' Add card button module
+ |
+
+
+ | 2 |
+ |
+
+ #'
+ |
+
+
+ | 3 |
+ |
+
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
+
+ | 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 `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 `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 `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 card_fun (`function`) which returns a [`ReportCard`] instance. See `Details`.
+ |
+
+
+ | 38 |
+ |
+
+ #'
+ |
+
+
+ | 39 |
+ |
+
+ #' @return `NULL`.
+ |
+
+
+ | 40 |
+ |
+
+ NULL
+ |
+
+
+ | 41 |
+ |
+
+
+ |
+
+
+ | 42 |
+ |
+
+ #' @rdname add_card_button
+ |
+
+
+ | 43 |
+ |
+
+ #' @export
+ |
+
+
+ | 44 |
+ |
+
+ add_card_button_ui <- function(id) {
+ |
+
+
+ | 45 |
+ 2x |
+
+ ns <- shiny::NS(id)
+ |
+
+
+ | 46 |
+ |
+
+
+ |
+
+
+ | 47 |
+ |
+
+ # Buttons with custom css and
+ |
+
+
+ | 48 |
+ |
+
+ # js code to disable the add card button when clicked to prevent multi-clicks
+ |
+
+
+ | 49 |
+ 2x |
+
+ shiny::tagList(
+ |
+
+
+ | 50 |
+ 2x |
+
+ shiny::singleton(
+ |
+
+
+ | 51 |
+ 2x |
+
+ shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
+ |
+
+
+ | 52 |
+ |
+
+ ),
+ |
+
+
+ | 53 |
+ 2x |
+
+ shiny::singleton(
+ |
+
+
+ | 54 |
+ 2x |
+
+ shiny::tags$head(
+ |
+
+
+ | 55 |
+ 2x |
+
+ shiny::tags$script(
+ |
+
+
+ | 56 |
+ 2x |
+
+ shiny::HTML(
+ |
+
+
+ | 57 |
+ 2x |
+
+ sprintf(
+ |
+
+
+ | 58 |
+ |
+
+ '
+ |
+
+
+ | 59 |
+ 2x |
+
+ $(document).ready(function(event) {
+ |
+
+
+ | 60 |
+ 2x |
+
+ $("body").on("click", "#%s", function() {
+ |
+
+
+ | 61 |
+ 2x |
+
+ $(this).addClass("disabled");
+ |
+
+
+ | 62 |
+ |
+
+ })
+ |
+
+
+ | 63 |
+ |
+
+ })',
+ |
+
+
+ | 64 |
+ 2x |
+
+ ns("add_card_ok")
+ |
+
+
+ | 65 |
+ |
+
+ )
+ |
+
+
+ | 66 |
+ |
+
+ )
+ |
+
+
+ | 67 |
+ |
+
+ )
+ |
+
+
+ | 68 |
+ |
+
+ )
+ |
+
+
+ | 69 |
+ |
+
+ ),
+ |
+
+
+ | 70 |
+ 2x |
+
+ shiny::tags$button(
+ |
+
+
+ | 71 |
+ 2x |
+
+ id = ns("add_report_card_button"),
+ |
+
+
+ | 72 |
+ 2x |
+
+ type = "button",
+ |
+
+
+ | 73 |
+ 2x |
+
+ class = "simple_report_button btn btn-primary action-button",
+ |
+
+
+ | 74 |
+ 2x |
+
+ title = "Add Card",
+ |
+
+
+ | 75 |
+ 2x |
+
+ `data-val` = shiny::restoreInput(id = ns("add_report_card_button"), default = NULL),
+ |
+
+
+ | 76 |
+ 2x |
+
+ NULL,
+ |
+
+
+ | 77 |
+ 2x |
+
+ shiny::tags$span(
+ |
+
+
+ | 78 |
+ 2x |
+
+ shiny::icon("plus")
+ |
+
+
+ | 79 |
+ |
+
+ )
+ |
+
+
+ | 80 |
+ |
+
+ )
+ |
+
+
+ | 81 |
+ |
+
+ )
+ |
+
+
+ | 82 |
+ |
- #' @description `r lifecycle::badge("experimental")`
+ }
|
- | 3 |
+ 83 |
+ |
+
+
+ |
+
+
+ | 84 |
+ |
+
+ #' @rdname add_card_button
+ |
+
+
+ | 85 |
+ |
+
+ #' @export
+ |
+
+
+ | 86 |
+ |
+
+ add_card_button_srv <- function(id, reporter, card_fun) {
+ |
+
+
+ | 87 |
+ 13x |
+
+ checkmate::assert_function(card_fun)
+ |
+
+
+ | 88 |
+ 13x |
+
+ checkmate::assert_class(reporter, "Reporter")
+ |
+
+
+ | 89 |
+ 13x |
+
+ checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)
+ |
+
+
+ | 90 |
+ |
+
+
+ |
+
+
+ | 91 |
+ 13x |
+
+ shiny::moduleServer(
+ |
+
+
+ | 92 |
+ 13x |
+
+ id,
+ |
+
+
+ | 93 |
+ 13x |
+
+ function(input, output, session) {
+ |
+
+
+ | 94 |
+ 13x |
+
+ ns <- session$ns
+ |
+
+
+ | 95 |
+ 13x |
+
+ add_modal <- function() {
+ |
+
+
+ | 96 |
+ 11x |
+
+ shiny::modalDialog(
+ |
+
+
+ | 97 |
+ 11x |
+
+ easyClose = TRUE,
+ |
+
+
+ | 98 |
+ 11x |
+
+ shiny::tags$h3("Add a Card to the Report"),
+ |
+
+
+ | 99 |
+ 11x |
+
+ shiny::tags$hr(),
+ |
+
+
+ | 100 |
+ 11x |
+
+ shiny::textInput(
+ |
+
+
+ | 101 |
+ 11x |
+
+ ns("label"),
+ |
+
+
+ | 102 |
+ 11x |
+
+ "Card Name",
+ |
+
+
+ | 103 |
+ 11x |
+
+ value = "",
+ |
+
+
+ | 104 |
+ 11x |
+
+ placeholder = "Add the card title here",
+ |
+
+
+ | 105 |
+ 11x |
+
+ width = "100%"
+ |
+
+
+ | 106 |
+ |
+
+ ),
+ |
+
+
+ | 107 |
+ 11x |
+
+ shiny::textAreaInput(
+ |
+
+
+ | 108 |
+ 11x |
+
+ ns("comment"),
+ |
+
+
+ | 109 |
+ 11x |
+
+ "Comment",
+ |
+
+
+ | 110 |
+ 11x |
+
+ value = "",
+ |
+
+
+ | 111 |
+ 11x |
+
+ placeholder = "Add a comment here...",
+ |
+
+
+ | 112 |
+ 11x |
+
+ width = "100%"
+ |
+
+
+ | 113 |
+ |
+
+ ),
+ |
+
+
+ | 114 |
+ 11x |
+
+ shiny::tags$script(
+ |
+
+
+ | 115 |
+ 11x |
+
+ shiny::HTML(
+ |
+
+
+ | 116 |
+ 11x |
+
+ sprintf(
+ |
+
+
+ | 117 |
|
- #' button for resetting the report content.
+ "
+ |
+
+
+ | 118 |
+ 11x |
+
+ $('#shiny-modal').on('shown.bs.modal', () => {
+ |
+
+
+ | 119 |
+ 11x |
+
+ $('#%s').focus()
|
- | 4 |
+ 120 |
|
- #'
+ })
|
- | 5 |
+ 121 |
|
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ ",
|
-
- | 6 |
- |
+
+ | 122 |
+ 11x |
- #' @param id `character(1)` this `shiny` module's id.
+ ns("label")
|
- | 7 |
+ 123 |
|
- #' @param label `character(1)` label before the icon.
+ )
|
- | 8 |
+ 124 |
|
- #' By default `NULL`.
+ )
|
- | 9 |
+ 125 |
|
- #' @return `shiny::tagList`
+ ),
|
-
- | 10 |
- |
+
+ | 126 |
+ 11x |
- #' @export
+ footer = shiny::div(
|
-
- | 11 |
- |
+
+ | 127 |
+ 11x |
- reset_report_button_ui <- function(id, label = NULL) {
+ shiny::tags$button(
|
- | 12 |
- 8x |
+ 128 |
+ 11x |
- checkmate::assert_string(label, null.ok = TRUE)
+ type = "button",
|
-
- | 13 |
- |
+
+ | 129 |
+ 11x |
-
+ class = "btn btn-secondary",
|
- | 14 |
- 8x |
+ 130 |
+ 11x |
- ns <- shiny::NS(id)
+ `data-dismiss` = "modal",
|
- | 15 |
- 8x |
+ 131 |
+ 11x |
- shiny::tagList(
+ `data-bs-dismiss` = "modal",
|
- | 16 |
- 8x |
+ 132 |
+ 11x |
- shiny::singleton(
+ NULL,
|
- | 17 |
- 8x |
+ 133 |
+ 11x |
- shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
+ "Cancel"
|
- | 18 |
+ 134 |
|
- ),
+ ),
|
- | 19 |
- 8x |
+ 135 |
+ 11x |
- shiny::tags$button(
+ shiny::tags$button(
|
- | 20 |
- 8x |
+ 136 |
+ 11x |
- id = ns("reset_reporter"),
+ id = ns("add_card_ok"),
|
- | 21 |
- 8x |
+ 137 |
+ 11x |
- type = "button",
+ type = "button",
|
- | 22 |
- 8x |
+ 138 |
+ 11x |
- class = "simple_report_button btn btn-warning action-button",
+ class = "btn btn-primary action-button",
|
- | 23 |
- 8x |
+ 139 |
+ 11x |
- title = "Reset",
+ `data-val` = shiny::restoreInput(id = ns("add_card_ok"), default = NULL),
|
- | 24 |
- 8x |
+ 140 |
+ 11x |
- `data-val` = shiny::restoreInput(id = ns("reset_reporter"), default = NULL),
+ NULL,
|
- | 25 |
- 8x |
+ 141 |
+ 11x |
- NULL,
+ "Add Card"
|
-
- | 26 |
- 8x |
+
+ | 142 |
+ |
- shiny::tags$span(
+ )
+ |
+
+
+ | 143 |
+ |
+
+ )
+ |
+
+
+ | 144 |
+ |
+
+ )
+ |
+
+
+ | 145 |
+ |
+
+ }
+ |
+
+
+ | 146 |
+ |
+
+
|
- | 27 |
- 8x |
+ 147 |
+ 13x |
- if (!is.null(label)) label,
+ shiny::observeEvent(input$add_report_card_button, {
|
- | 28 |
- 8x |
+ 148 |
+ 11x |
- shiny::icon("xmark")
+ shiny::showModal(add_modal())
|
- | 29 |
+ 149 |
|
- )
+ })
|
- | 30 |
+ 150 |
|
- )
+
|
- | 31 |
+ 151 |
|
- )
+ # the add card button is disabled when clicked to prevent multi-clicks
|
- | 32 |
+ 152 |
|
- }
+ # please check the ui part for more information
+ |
+
+
+ | 153 |
+ 13x |
+
+ shiny::observeEvent(input$add_card_ok, {
+ |
+
+
+ | 154 |
+ 11x |
+
+ card_fun_args_nams <- names(formals(card_fun))
+ |
+
+
+ | 155 |
+ 11x |
+
+ has_card_arg <- "card" %in% card_fun_args_nams
+ |
+
+
+ | 156 |
+ 11x |
+
+ has_comment_arg <- "comment" %in% card_fun_args_nams
+ |
+
+
+ | 157 |
+ 11x |
+
+ has_label_arg <- "label" %in% card_fun_args_nams
|
- | 33 |
+ 158 |
|
|
-
- | 34 |
- |
+
+ | 159 |
+ 11x |
- #' Reset Button Server
+ arg_list <- list()
|
- | 35 |
+ 160 |
|
- #' @description `r lifecycle::badge("experimental")`
+
+ |
+
+
+ | 161 |
+ 11x |
+
+ if (has_comment_arg) {
+ |
+
+
+ | 162 |
+ 4x |
+
+ arg_list <- c(arg_list, list(comment = input$comment))
|
- | 36 |
+ 163 |
|
- #' server for resetting the Report content.
+ }
+ |
+
+
+ | 164 |
+ 11x |
+
+ if (has_label_arg) {
|
-
- | 37 |
- |
+
+ | 165 |
+ ! |
- #'
+ arg_list <- c(arg_list, list(label = input$label))
|
- | 38 |
+ 166 |
|
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ }
|
- | 39 |
+ 167 |
|
- #' @param id `character(1)` this `shiny` module's id.
+
|
-
- | 40 |
- |
+
+ | 168 |
+ 11x |
- #' @param reporter [`Reporter`] instance.
+ if (has_card_arg) {
|
- | 41 |
+ 169 |
|
- #' @return `shiny::moduleServer`
+ # The default_card is defined here because formals() returns a pairedlist object
|
- | 42 |
+ 170 |
|
- #' @export
+ # of formal parameter names and their default values. The values are missing
|
- | 43 |
+ 171 |
|
- reset_report_button_srv <- function(id, reporter) {
+ # if not defined and the missing check does not work if supplied formals(card_fun)[[1]]
|
- | 44 |
- 12x |
+ 172 |
+ 8x |
- checkmate::assert_class(reporter, "Reporter")
+ default_card <- formals(card_fun)$card
|
-
- | 45 |
- |
+
+ | 173 |
+ 8x |
-
+ card <- `if`(
|
- | 46 |
- 12x |
+ 174 |
+ 8x |
- shiny::moduleServer(
+ missing(default_card),
|
- | 47 |
- 12x |
+ 175 |
+ 8x |
- id,
+ ReportCard$new(),
|
- | 48 |
- 12x |
+ 176 |
+ 8x |
- function(input, output, session) {
+ eval(default_card, envir = environment(card_fun))
|
-
- | 49 |
- 12x |
+
+ | 177 |
+ |
- ns <- session$ns
+ )
|
- | 50 |
- 12x |
+ 178 |
+ 8x |
- nr_cards <- length(reporter$get_cards())
+ arg_list <- c(arg_list, list(card = card))
|
- | 51 |
+ 179 |
|
-
+ }
|
- | 52 |
+ 180 |
|
|
- | 53 |
- 12x |
-
- shiny::observeEvent(input$reset_reporter, {
- |
-
-
- | 54 |
- 1x |
+ 181 |
+ 11x |
- shiny::showModal(
+ card <- try(do.call(card_fun, arg_list))
|
-
- | 55 |
- 1x |
+
+ | 182 |
+ |
- shiny::modalDialog(
+
|
- | 56 |
- 1x |
+ 183 |
+ 11x |
- shiny::tags$h3("Reset the Report"),
+ if (inherits(card, "try-error")) {
|
- | 57 |
- 1x |
+ 184 |
+ 3x |
- shiny::tags$hr(),
+ msg <- paste0(
|
- | 58 |
- 1x |
+ 185 |
+ 3x |
- shiny::tags$strong(
+ "The card could not be added to the report. ",
|
- | 59 |
- 1x |
+ 186 |
+ 3x |
- shiny::tags$p(
+ "Have the outputs for the report been created yet? If not please try again when they ",
|
- | 60 |
- 1x |
+ 187 |
+ 3x |
- "Are you sure you want to reset the report? (This will remove ALL previously added cards)."
+ "are ready. Otherwise contact your application developer"
|
- | 61 |
+ 188 |
|
- )
+ )
|
-
- | 62 |
- |
+
+ | 189 |
+ 3x |
- ),
+ warning(msg)
|
- | 63 |
- 1x |
+ 190 |
+ 3x |
- footer = shiny::tagList(
+ shiny::showNotification(
|
- | 64 |
- 1x |
+ 191 |
+ 3x |
- shiny::tags$button(
+ msg,
|
- | 65 |
- 1x |
+ 192 |
+ 3x |
- type = "button",
+ type = "error"
|
-
- | 66 |
- 1x |
+
+ | 193 |
+ |
- class = "btn btn-secondary",
+ )
|
-
- | 67 |
- 1x |
+
+ | 194 |
+ |
- `data-dismiss` = "modal",
+ } else {
|
- | 68 |
- 1x |
+ 195 |
+ 8x |
- `data-bs-dismiss` = "modal",
+ checkmate::assert_class(card, "ReportCard")
|
- | 69 |
- 1x |
+ 196 |
+ 8x |
- NULL,
+ if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
|
- | 70 |
+ 197 |
1x |
- "Cancel"
- |
-
-
- | 71 |
- |
-
- ),
+ card$append_text("Comment", "header3")
|
- | 72 |
+ 198 |
1x |
- shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn-danger")
+ card$append_text(input$comment)
|
- | 73 |
+ 199 |
|
- )
+ }
|
- | 74 |
+ 200 |
|
- )
+
|
-
- | 75 |
- |
+
+ | 201 |
+ 8x |
- )
+ if (!has_label_arg && length(input$label) == 1 && input$label != "") {
+ |
+
+
+ | 202 |
+ ! |
+
+ card$set_name(input$label)
|
- | 76 |
+ 203 |
|
- })
+ }
|
- | 77 |
+ 204 |
|
|
- | 78 |
- 12x |
+ 205 |
+ 8x |
- shiny::observeEvent(input$reset_reporter_ok, {
+ reporter$append_cards(list(card))
+ |
+
+
+ | 206 |
+ 8x |
+
+ shiny::showNotification(sprintf("The card added successfully."), type = "message")
|
- | 79 |
- 1x |
+ 207 |
+ 8x |
- reporter$reset()
+ shiny::removeModal()
|
-
- | 80 |
- 1x |
+
+ | 208 |
+ |
- shiny::removeModal()
+ }
|
- | 81 |
+ 209 |
|
})
|
- | 82 |
+ 210 |
|
}
|
- | 83 |
+ 211 |
|
)
|
- | 84 |
+ 212 |
|
}
@@ -19635,140 +20832,140 @@ teal.reporter coverage - 82.57%
|
-
+
| 1 |
|
- #' @title `PictureBlock`
+ #' @title `FileBlock`
|
| 2 |
|
- #' @keywords internal
+ #' @docType class
|
| 3 |
|
- #' @noRd
+ #' @description
|
| 4 |
|
- PictureBlock <- R6::R6Class( # nolint: object_name_linter.
+ #' `FileBlock` manages file-based content in a report,
|
| 5 |
|
- classname = "PictureBlock",
+ #' ensuring appropriate handling of content files.
|
| 6 |
|
- inherit = FileBlock,
+ #'
|
| 7 |
|
- public = list(
+ #' @keywords internal
|
| 8 |
|
- #' @description Returns a new `PictureBlock` object.
+ FileBlock <- R6::R6Class( # nolint: object_name_linter.
|
| 9 |
|
- #'
+ classname = "FileBlock",
|
| 10 |
|
- #' @param plot (`ggplot`, `grid`) a picture in this `PictureBlock`
+ inherit = ContentBlock,
|
| 11 |
|
- #'
+ public = list(
|
| 12 |
|
- #' @return a `PictureBlock` object
+ #' @description Finalize the `FileBlock`.
|
| 13 |
|
- initialize = function(plot) {
+ #'
|
-
+
| 14 |
- 52x |
+ |
- if (!missing(plot)) {
+ #' @details Removes the temporary file created in the constructor.
|
-
+
| 15 |
- ! |
+ |
- self$set_content(plot)
+ finalize = function() {
|
-
+
| 16 |
- |
+ 97x |
- }
+ try(unlink(super$get_content()))
|
-
+
| 17 |
- 52x |
+ |
- invisible(self)
+ },
|
| 18 |
|
- },
+ #' @description Create the `FileBlock` from a list.
|
| 19 |
|
- #' @description Sets the content of this `PictureBlock`.
+ #' The list should contain one named field, `"basename"`.
|
@@ -19782,1262 +20979,1193 @@ teal.reporter coverage - 82.57%
21 |
|
- #' @details throws if argument is not a `ggplot`, `grob` or `trellis` plot.
+ #' @param x (`named list`) with one field `"basename"`, a name of the file.
|
| 22 |
|
- #'
+ #' @param output_dir (`character`) with a path to the directory where a file will be copied.
|
| 23 |
|
- #' @param content (`ggplot`, `grob`, `trellis`) a picture in this `PictureBlock`
+ #'
|
| 24 |
|
- #'
+ #' @return `self`, invisibly.
|
| 25 |
|
- #' @return invisibly self
+ #' @examples
|
| 26 |
|
- #' @examples
+ #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
|
| 27 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ #' block <- FileBlock$new()
|
| 28 |
|
- #' block <- PictureBlock$new()
+ #' file_path <- tempfile(fileext = ".png")
|
| 29 |
|
- #' block$set_content(ggplot2::ggplot(iris))
+ #' saveRDS(iris, file_path)
|
| 30 |
|
- #'
+ #' block$from_list(list(basename = basename(file_path)), dirname(file_path))
|
| 31 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ #'
|
| 32 |
|
- #' block <- PictureBlock$new()
+ from_list = function(x, output_dir) {
|
-
+
| 33 |
- |
+ 28x |
- #' block$set_content(lattice::bwplot(1))
+ checkmate::assert_list(x)
|
-
+
| 34 |
- |
+ 28x |
- #'
+ checkmate::assert_names(names(x), must.include = "basename")
|
-
+
| 35 |
- |
+ 28x |
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ path <- file.path(output_dir, x$basename)
|
-
+
| 36 |
- |
+ 28x |
- #' block <- PictureBlock$new()
+ file_type <- paste0(".", tools::file_ext(path))
|
-
+
| 37 |
- |
+ 28x |
- #' block$set_content(ggplot2::ggplotGrob(ggplot2::ggplot(iris)))
+ checkmate::assert_file_exists(path, extension = file_type)
|
-
+
| 38 |
- |
+ 28x |
- set_content = function(content) {
+ new_file_path <- tempfile(fileext = file_type)
|
| 39 |
- 31x |
+ 28x |
- checkmate::assert_multi_class(content, private$supported_plots)
+ file.copy(path, new_file_path)
|
| 40 |
- 29x |
-
- path <- tempfile(fileext = ".png")
- |
-
-
- | 41 |
- 29x |
-
- grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
- |
-
-
- | 42 |
- 29x |
-
- tryCatch(
- |
-
-
- | 43 |
- 29x |
-
- expr = {
- |
-
-
- | 44 |
- 29x |
-
- if (inherits(content, "grob")) {
- |
-
-
- | 45 |
- 1x |
-
- grid::grid.newpage()
- |
-
-
- | 46 |
- 1x |
-
- grid::grid.draw(content)
- |
-
-
- | 47 |
28x |
- } else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
- |
-
-
- | 48 |
- 27x |
-
- print(content)
- |
-
-
- | 49 |
- 1x |
-
- } else if (inherits(content, "trellis")) {
- |
-
-
- | 50 |
- 1x |
-
- grid::grid.newpage()
- |
-
-
- | 51 |
- 1x |
-
- grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
- |
-
-
- | 52 |
- |
-
- }
- |
-
-
- | 53 |
- 29x |
-
- super$set_content(path)
- |
-
-
- | 54 |
- |
-
- },
- |
-
-
- | 55 |
- 29x |
-
- finally = grDevices::dev.off()
- |
-
-
- | 56 |
- |
-
- )
+ super$set_content(new_file_path)
|
- | 57 |
- 29x |
-
- invisible(self)
- |
-
-
- | 58 |
- |
-
- },
- |
-
-
- | 59 |
- |
+ 41 |
+ 28x |
- #' @description Sets the title of this `PictureBlock`.
+ invisible(self)
|
- | 60 |
+ 42 |
|
- #'
+ },
|
- | 61 |
+ 43 |
|
- #' @details throws if argument is not `character(1)`.
+ #' @description Convert the `FileBlock` to a list.
|
- | 62 |
+ 44 |
|
#'
|
- | 63 |
+ 45 |
|
- #' @param title (`character(1)`) a string assigned to this `PictureBlock`
+ #' @param output_dir (`character`) with a path to the directory where a file will be copied.
|
- | 64 |
+ 46 |
|
#'
|
- | 65 |
+ 47 |
|
- #' @return invisibly self
+ #' @return `named list` with a `basename` of the file.
|
- | 66 |
+ 48 |
|
#' @examples
|
- | 67 |
+ 49 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
|
- | 68 |
+ 50 |
|
- #' block <- PictureBlock$new()
+ #' block <- FileBlock$new()
|
- | 69 |
+ 51 |
|
- #' block$set_title("Title")
+ #' block$to_list(tempdir())
|
- | 70 |
+ 52 |
|
#'
|
- | 71 |
+ 53 |
|
- set_title = function(title) {
+ to_list = function(output_dir) {
|
- | 72 |
- 5x |
+ 54 |
+ 18x |
- checkmate::assert_string(title)
+ base_name <- basename(super$get_content())
|
- | 73 |
- 4x |
+ 55 |
+ 18x |
- private$title <- title
+ file.copy(super$get_content(), file.path(output_dir, base_name))
|
- | 74 |
- 4x |
+ 56 |
+ 18x |
- invisible(self)
+ list(basename = base_name)
|
- | 75 |
+ 57 |
|
- },
+ }
|
- | 76 |
+ 58 |
|
- #' @description Returns the title of this `PictureBlock`
+ ),
|
- | 77 |
+ 59 |
|
- #'
+ lock_objects = TRUE,
|
- | 78 |
+ 60 |
|
- #' @return the content of this `PictureBlock`
+ lock_class = TRUE
|
- | 79 |
+ 61 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ )
|
+
+
+
+
+
+
- | 80 |
+ 1 |
|
- #' block <- PictureBlock$new()
+ #' @title `PictureBlock`
|
- | 81 |
+ 2 |
|
- #' block$get_title()
+ #' @docType class
|
- | 82 |
+ 3 |
|
- #'
+ #' @description
|
- | 83 |
+ 4 |
|
- get_title = function() {
+ #' Specialized `FileBlock` for managing picture content in reports.
|
-
- | 84 |
- 9x |
+
+ | 5 |
+ |
- private$title
+ #' It's designed to handle plots from packages such as `ggplot2`, `grid`, or `lattice`.
|
- | 85 |
+ 6 |
|
- },
+ #' It can save plots to files, set titles and specify dimensions.
|
- | 86 |
+ 7 |
|
- #' @description Sets the dimensions of this `PictureBlock`
+ #'
|
- | 87 |
+ 8 |
|
- #'
+ #' @keywords internal
|
- | 88 |
+ 9 |
|
- #' @param dim `numeric` figure dimensions (width and height) in pixels, length 2.
+ PictureBlock <- R6::R6Class( # nolint: object_name_linter.
|
- | 89 |
+ 10 |
|
- #'
+ classname = "PictureBlock",
|
- | 90 |
+ 11 |
|
- #' @return `self`
+ inherit = FileBlock,
|
- | 91 |
+ 12 |
|
- #' @examples
+ public = list(
|
- | 92 |
+ 13 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ #' @description Initialize a `PictureBlock` object.
|
- | 93 |
+ 14 |
|
- #' block <- PictureBlock$new()
+ #'
|
- | 94 |
+ 15 |
|
- #' block$set_dim(c(800, 600))
+ #' @param plot (`ggplot` or `grid`) a picture in this `PictureBlock`
|
- | 95 |
+ 16 |
|
#'
|
- | 96 |
+ 17 |
|
- set_dim = function(dim) {
+ #' @return Object of class `PictureBlock`, invisibly.
|
-
- | 97 |
- 6x |
+
+ | 18 |
+ |
- checkmate::assert_numeric(dim, len = 2)
+ initialize = function(plot) {
|
- | 98 |
- 4x |
+ 19 |
+ 52x |
- private$dim <- dim
+ if (!missing(plot)) {
+ |
+
+
+ | 20 |
+ ! |
+
+ self$set_content(plot)
+ |
+
+
+ | 21 |
+ |
+
+ }
|
- | 99 |
- 4x |
+ 22 |
+ 52x |
invisible(self)
|
- | 100 |
+ 23 |
|
},
|
- | 101 |
+ 24 |
|
- #' @description Returns the dimensions of this `PictureBlock`
+ #' @description Sets the content of this `PictureBlock`.
|
- | 102 |
+ 25 |
|
#'
|
- | 103 |
+ 26 |
|
- #' @return `numeric` the array of 2 numeric values representing width and height in pixels.
+ #' @details Raises error if argument is not a `ggplot`, `grob` or `trellis` plot.
|
- | 104 |
+ 27 |
|
- #' @examples
+ #'
|
- | 105 |
+ 28 |
|
- #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ #' @param content (`ggplot` or `grob` or `trellis`) a picture in this `PictureBlock`
|
- | 106 |
+ 29 |
|
- #' block <- PictureBlock$new()
+ #'
|
- | 107 |
+ 30 |
|
- #' block$get_dim()
+ #' @return `self`, invisibly.
|
- | 108 |
+ 31 |
|
- get_dim = function() {
+ #' @examples
|
-
- | 109 |
- ! |
+
+ | 32 |
+ |
- private$dim
+ #' library(ggplot2)
|
- | 110 |
+ 33 |
|
- }
+ #' library(lattice)
|
- | 111 |
+ 34 |
|
- ),
+ #'
|
- | 112 |
+ 35 |
|
- private = list(
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
- | 113 |
+ 36 |
|
- supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
+ #' block <- PictureBlock$new()
|
- | 114 |
+ 37 |
|
- type = character(0),
+ #' block$set_content(ggplot(iris))
|
- | 115 |
+ 38 |
|
- title = "",
+ #'
|
- | 116 |
+ 39 |
|
- dim = c(800, 600)
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
- | 117 |
+ 40 |
+ |
+
+ #' block <- PictureBlock$new()
+ |
+
+
+ | 41 |
+ |
+
+ #' block$set_content(bwplot(1))
+ |
+
+
+ | 42 |
+ |
+
+ #'
+ |
+
+
+ | 43 |
|
- ),
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
- | 118 |
+ 44 |
|
- lock_objects = TRUE,
+ #' block <- PictureBlock$new()
|
- | 119 |
+ 45 |
|
- lock_class = TRUE
+ #' block$set_content(ggplotGrob(ggplot(iris)))
|
- | 120 |
+ 46 |
|
- )
+ set_content = function(content) {
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 47 |
+ 31x |
- #' @title `NewpageBlock`
+ checkmate::assert_multi_class(content, private$supported_plots)
|
-
- | 2 |
- |
+
+ | 48 |
+ 29x |
- #' @keywords internal
+ path <- tempfile(fileext = ".png")
|
-
- | 3 |
- |
+
+ | 49 |
+ 29x |
- NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
+ grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
|
-
- | 4 |
- |
+
+ | 50 |
+ 29x |
- classname = "NewpageBlock",
+ tryCatch(
|
-
- | 5 |
- |
+
+ | 51 |
+ 29x |
- inherit = ContentBlock,
+ expr = {
|
-
- | 6 |
- |
+
+ | 52 |
+ 29x |
- public = list(
+ if (inherits(content, "grob")) {
|
-
- | 7 |
- |
+
+ | 53 |
+ 1x |
- #' @description Returns a `NewpageBlock` object.
+ grid::grid.newpage()
|
-
- | 8 |
- |
+
+ | 54 |
+ 1x |
- #'
+ grid::grid.draw(content)
|
-
- | 9 |
- |
+
+ | 55 |
+ 28x |
- #' @details Returns a `NewpageBlock` object with no content and the default style.
+ } else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
|
-
- | 10 |
- |
+
+ | 56 |
+ 27x |
- #'
+ print(content)
|
-
- | 11 |
- |
+
+ | 57 |
+ 1x |
- #' @return `NewpageBlock`
+ } else if (inherits(content, "trellis")) {
|
-
- | 12 |
- |
+
+ | 58 |
+ 1x |
- #' @examples
+ grid::grid.newpage()
|
-
- | 13 |
- |
+
+ | 59 |
+ 1x |
- #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
+ grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
|
- | 14 |
+ 60 |
|
- #' block <- NewpageBlock$new()
+ }
|
-
- | 15 |
- |
+
+ | 61 |
+ 29x |
- #'
+ super$set_content(path)
|
- | 16 |
+ 62 |
|
- initialize = function() {
+ },
|
- | 17 |
- 18x |
+ 63 |
+ 29x |
- super$set_content("\n\\newpage\n")
+ finally = grDevices::dev.off()
+ |
+
+
+ | 64 |
+ |
+
+ )
|
- | 18 |
- 18x |
+ 65 |
+ 29x |
invisible(self)
|
- | 19 |
+ 66 |
|
- }
+ },
|
- | 20 |
+ 67 |
|
- ),
+ #' @description Sets the title of this `PictureBlock`.
|
- | 21 |
+ 68 |
|
- lock_objects = TRUE,
+ #'
|
- | 22 |
+ 69 |
|
- lock_class = TRUE
+ #' @details Raises error if argument is not `character(1)`.
|
- | 23 |
+ 70 |
|
- )
+ #'
|
-
-
-
-
-
-
- | 1 |
+ 71 |
|
- #' @title `FileBlock`
+ #' @param title (`character(1)`) a string assigned to this `PictureBlock`
|
- | 2 |
+ 72 |
|
- #' @keywords internal
+ #'
|
- | 3 |
+ 73 |
|
- FileBlock <- R6::R6Class( # nolint: object_name_linter.
+ #' @return `self`, invisibly.
|
- | 4 |
+ 74 |
|
- classname = "FileBlock",
+ #' @examples
|
- | 5 |
+ 75 |
|
- inherit = ContentBlock,
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
- | 6 |
+ 76 |
|
- public = list(
+ #' block <- PictureBlock$new()
|
- | 7 |
+ 77 |
|
- #' @description finalize of this `FileBlock`.
+ #' block$set_title("Title")
|
- | 8 |
+ 78 |
|
#'
|
- | 9 |
+ 79 |
|
- #' @details Removes the temporary file created in the constructor.
+ set_title = function(title) {
|
-
- | 10 |
- |
+
+ | 80 |
+ 5x |
- finalize = function() {
+ checkmate::assert_string(title)
|
- | 11 |
- 97x |
+ 81 |
+ 4x |
- try(unlink(super$get_content()))
+ private$title <- title
+ |
+
+
+ | 82 |
+ 4x |
+
+ invisible(self)
|
- | 12 |
+ 83 |
|
},
|
- | 13 |
+ 84 |
|
- #' @description Create the `FileBlock` from a list.
+ #' @description Get the title of this `PictureBlock`.
|
- | 14 |
+ 85 |
|
- #' The list should contain one named field, `"basename"`.
+ #'
|
- | 15 |
+ 86 |
|
- #'
+ #' @return The content of this `PictureBlock`.
|
- | 16 |
+ 87 |
|
- #' @param x `named list` with one field `"basename"`, a name of the file.
+ #' @examples
|
- | 17 |
+ 88 |
+ |
+
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
+ |
+
+
+ | 89 |
|
- #' @param output_dir `character` with a path to the directory where a file will be copied.
+ #' block <- PictureBlock$new()
|
- | 18 |
+ 90 |
|
- #'
+ #' block$get_title()
|
- | 19 |
+ 91 |
|
- #' @return invisibly self
+ #'
|
- | 20 |
+ 92 |
|
- #' @examples
+ get_title = function() {
|
-
- | 21 |
- |
+
+ | 93 |
+ 9x |
- #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
+ private$title
|
- | 22 |
+ 94 |
|
- #' block <- FileBlock$new()
+ },
|
- | 23 |
+ 95 |
|
- #' file_path <- tempfile(fileext = ".png")
+ #' @description Sets the dimensions of this `PictureBlock`.
|
- | 24 |
+ 96 |
|
- #' saveRDS(iris, file_path)
+ #'
|
- | 25 |
+ 97 |
|
- #' block$from_list(list(basename = basename(file_path)), dirname(file_path))
+ #' @param dim (`numeric(2)`) figure dimensions (width and height) in pixels.
|
- | 26 |
+ 98 |
|
#'
|
- | 27 |
+ 99 |
|
- from_list = function(x, output_dir) {
+ #' @return `self`, invisibly.
|
-
- | 28 |
- 28x |
+
+ | 100 |
+ |
- checkmate::assert_list(x)
+ #' @examples
|
-
- | 29 |
- 28x |
+
+ | 101 |
+ |
- checkmate::assert_names(names(x), must.include = "basename")
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
-
- | 30 |
- 28x |
+
+ | 102 |
+ |
- path <- file.path(output_dir, x$basename)
+ #' block <- PictureBlock$new()
|
-
- | 31 |
- 28x |
+
+ | 103 |
+ |
- file_type <- paste0(".", tools::file_ext(path))
+ #' block$set_dim(c(800, 600))
|
-
- | 32 |
- 28x |
+
+ | 104 |
+ |
- checkmate::assert_file_exists(path, extension = file_type)
+ #'
|
-
- | 33 |
- 28x |
+
+ | 105 |
+ |
- new_file_path <- tempfile(fileext = file_type)
+ set_dim = function(dim) {
|
- | 34 |
- 28x |
+ 106 |
+ 6x |
- file.copy(path, new_file_path)
+ checkmate::assert_numeric(dim, len = 2)
|
- | 35 |
- 28x |
+ 107 |
+ 4x |
- super$set_content(new_file_path)
+ private$dim <- dim
|
- | 36 |
- 28x |
+ 108 |
+ 4x |
invisible(self)
|
- | 37 |
+ 109 |
|
},
|
- | 38 |
+ 110 |
|
- #' @description Convert the `FileBlock` to a list.
+ #' @description Get `PictureBlock` dimensions as a numeric vector.
|
- | 39 |
+ 111 |
|
#'
|
- | 40 |
+ 112 |
|
- #' @param output_dir `character` with a path to the directory where a file will be copied.
+ #' @return `numeric` the array of 2 numeric values representing width and height in pixels.
|
- | 41 |
+ 113 |
|
- #'
+ #' @examples
|
- | 42 |
+ 114 |
|
- #' @return `named list` with a `basename` of the file.
+ #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
|
- | 43 |
+ 115 |
|
- #' @examples
+ #' block <- PictureBlock$new()
|
- | 44 |
+ 116 |
|
- #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
+ #' block$get_dim()
|
- | 45 |
+ 117 |
|
- #' block <- FileBlock$new()
+ get_dim = function() {
+ |
+
+
+ | 118 |
+ ! |
+
+ private$dim
|
- | 46 |
+ 119 |
|
- #' block$to_list(tempdir())
+ }
|
- | 47 |
+ 120 |
|
- #'
+ ),
|
- | 48 |
+ 121 |
|
- to_list = function(output_dir) {
+ private = list(
|
-
- | 49 |
- 18x |
+
+ | 122 |
+ |
- base_name <- basename(super$get_content())
+ supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
|
-
- | 50 |
- 18x |
+
+ | 123 |
+ |
- file.copy(super$get_content(), file.path(output_dir, base_name))
+ type = character(0),
|
-
- | 51 |
- 18x |
+
+ | 124 |
+ |
- list(basename = base_name)
+ title = "",
|
- | 52 |
+ 125 |
|
- }
+ dim = c(800, 600)
|
- | 53 |
+ 126 |
|
),
|
- | 54 |
+ 127 |
|
lock_objects = TRUE,
|
- | 55 |
+ 128 |
|
lock_class = TRUE
|
- | 56 |
+ 129 |
|
)
@@ -21046,899 +22174,893 @@ teal.reporter coverage - 82.57%
|
-
+
| 1 |
|
- #' Simple Reporter User Interface
+ #' @title `TextBlock`
|
| 2 |
|
- #' @description `r lifecycle::badge("experimental")`
+ #' @docType class
|
| 3 |
|
- #' three buttons for adding cards, downloading and resetting the Report.
+ #' @description
|
| 4 |
|
- #'
+ #' Specialized `ContentBlock` for embedding styled text within reports.
|
| 5 |
|
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ #' It supports multiple styling options to accommodate various text roles,
|
| 6 |
|
- #' @param id `character(1)` this `shiny` module's id.
+ #' such as headers or verbatim text, in the report content.
|
| 7 |
|
- #' @return `shiny.tag`
+ #'
|
| 8 |
|
- #' @export
+ #' @keywords internal
|
| 9 |
|
- #'
+ TextBlock <- R6::R6Class( # nolint: object_name_linter.
|
| 10 |
|
- #' @examples
+ classname = "TextBlock",
|
| 11 |
|
- #' if (interactive()) {
+ inherit = ContentBlock,
|
| 12 |
|
- #' shiny::shinyApp(
+ public = list(
|
| 13 |
|
- #' ui = shiny::fluidPage(simple_reporter_ui("simple")),
+ #' @description Initialize a `TextBlock` object.
|
| 14 |
|
- #' server = function(input, output, session) {
+ #'
|
| 15 |
|
- #' simple_reporter_srv("simple", Reporter$new(), function(card) card)
+ #' @details Constructs a `TextBlock` object with no content and the default style.
|
| 16 |
|
- #' }
+ #'
|
| 17 |
|
- #' )
+ #' @param content (`character`) a string assigned to this `TextBlock`
|
| 18 |
|
- #' }
+ #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
|
| 19 |
|
- simple_reporter_ui <- function(id) {
+ #'
|
-
+
| 20 |
- 1x |
+ |
- ns <- shiny::NS(id)
+ #' @return Object of class `TextBlock`, invisibly.
|
-
+
| 21 |
- 1x |
+ |
- shiny::tagList(
+ #' @examples
|
-
+
| 22 |
- 1x |
+ |
- shiny::singleton(
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
-
+
| 23 |
- 1x |
+ |
- shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
+ #' block <- TextBlock$new()
|
| 24 |
|
- ),
+ #'
|
-
+
| 25 |
- 1x |
+ |
- shiny::tags$div(
+ initialize = function(content = character(0), style = private$styles[1]) {
|
| 26 |
- 1x |
+ 130x |
- class = "block mb-4 p-1",
+ super$set_content(content)
|
| 27 |
- 1x |
+ 130x |
- shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
+ self$set_style(style)
|
| 28 |
- 1x |
+ 130x |
- shiny::tags$div(
+ invisible(self)
|
-
+
| 29 |
- 1x |
+ |
- class = "simple_reporter_container",
+ },
|
-
+
| 30 |
- 1x |
+ |
- add_card_button_ui(ns("add_report_card_simple")),
+ #' @description Sets the style of this `TextBlock`.
|
-
+
| 31 |
- 1x |
+ |
- download_report_button_ui(ns("download_button_simple")),
+ #'
|
-
+
| 32 |
- 1x |
+ |
- reset_report_button_ui(ns("reset_button_simple"))
+ #' @details The style has bearing on the rendering of this block.
|
| 33 |
|
- )
+ #'
|
| 34 |
|
- )
+ #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
|
| 35 |
|
- )
+ #'
|
| 36 |
|
- }
+ #' @return `self`, invisibly.
|
| 37 |
|
-
+ #' @examples
|
| 38 |
|
- #' Simple Reporter Server
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
| 39 |
|
- #' @description `r lifecycle::badge("experimental")`
+ #' block <- TextBlock$new()
|
| 40 |
|
- #' three buttons for adding cards, downloading and resetting the Report.
+ #' block$set_style("header2")
|
| 41 |
|
- #' The add module has `add_report_card_simple` id, the download module the `download_button_simple` id
+ #'
|
| 42 |
|
- #' and the reset module the `reset_button_simple` id.
+ set_style = function(style) {
|
-
+
| 43 |
- |
+ 174x |
- #'
+ private$style <- match.arg(style, private$styles)
|
-
+
| 44 |
- |
+ 173x |
- #' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
+ invisible(self)
|
| 45 |
|
- #' @param id `character(1)` this `shiny` module's id.
+ },
|
| 46 |
|
- #' @param reporter [`Reporter`] instance.
+ #' @description Get the style of this `TextBlock`.
|
| 47 |
|
- #' @param card_fun `function` which returns a [`ReportCard`] instance,
+ #'
|
| 48 |
|
- #' the function has a `card` argument and an optional `comment` argument.
+ #' @return `character(1)` the style of this `TextBlock`.
|
| 49 |
|
- #' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
+ #' @examples
|
| 50 |
|
- #' @inheritParams reporter_download_inputs
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
| 51 |
|
- #' @details `r global_knitr_details()`
+ #' block <- TextBlock$new()
|
| 52 |
|
- #'
+ #' block$get_style()
|
| 53 |
|
- #' @return `shiny::moduleServer`
+ #'
|
| 54 |
|
- #' @export
+ get_style = function() {
|
-
+
| 55 |
- |
+ 59x |
- simple_reporter_srv <- function(id,
+ private$style
|
| 56 |
|
- reporter,
+ },
|
| 57 |
|
- card_fun,
+ #' @description Get available an array of styles available to this `TextBlock`.
|
| 58 |
|
- global_knitr = getOption("teal.reporter.global_knitr"),
+ #'
|
| 59 |
|
- rmd_output = c(
+ #' @return A `character` array of styles.
|
| 60 |
|
- "html" = "html_document", "pdf" = "pdf_document",
+ #' @examples
|
| 61 |
|
- "powerpoint" = "powerpoint_presentation", "word" = "word_document"
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
| 62 |
|
- ),
+ #' block <- TextBlock$new()
|
| 63 |
|
- rmd_yaml_args = list(
+ #' block$get_available_styles()
|
| 64 |
|
- author = "NEST", title = "Report",
+ #'
|
| 65 |
|
- date = as.character(Sys.Date()), output = "html_document",
+ get_available_styles = function() {
|
-
+
| 66 |
- |
+ 23x |
- toc = FALSE
+ private$styles
|
| 67 |
|
- )) {
+ },
|
-
+
| 68 |
- 3x |
+ |
- shiny::moduleServer(
+ #' @description Create the `TextBlock` from a list.
|
-
+
| 69 |
- 3x |
+ |
- id,
+ #'
|
-
+
| 70 |
- 3x |
+ |
- function(input, output, session) {
+ #' @param x (`named list`) with two fields `text` and `style`.
|
-
+
| 71 |
- 3x |
+ |
- add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
+ #' Use the `get_available_styles` method to get all possible styles.
|
-
+
| 72 |
- 3x |
+ |
- download_report_button_srv(
+ #'
|
-
+
| 73 |
- 3x |
+ |
- "download_button_simple",
+ #' @return `self`, invisibly.
|
-
+
| 74 |
- 3x |
+ |
- reporter = reporter,
+ #' @examples
|
-
+
| 75 |
- 3x |
+ |
- global_knitr = global_knitr,
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
-
+
| 76 |
- 3x |
+ |
- rmd_output = rmd_output,
+ #' block <- TextBlock$new()
|
-
+
| 77 |
- 3x |
+ |
- rmd_yaml_args = rmd_yaml_args
+ #' block$from_list(list(text = "sth", style = "default"))
|
| 78 |
|
- )
+ #'
|
-
+
| 79 |
- 3x |
+ |
- reset_report_button_srv("reset_button_simple", reporter = reporter)
+ from_list = function(x) {
|
-
+
| 80 |
- |
+ 36x |
- }
+ checkmate::assert_list(x)
|
-
+
| 81 |
- |
+ 36x |
- )
+ checkmate::assert_names(names(x), must.include = c("text", "style"))
|
-
+
| 82 |
- |
+ 36x |
- }
+ self$set_content(x$text)
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 83 |
+ 36x |
- .onLoad <- function(libname, pkgname) {
+ self$set_style(x$style)
|
-
- | 2 |
- ! |
+
+ | 84 |
+ 36x |
- op <- options()
+ invisible(self)
|
-
- | 3 |
- ! |
+
+ | 85 |
+ |
- default_global_knitr <- list(teal.reporter.global_knitr = list(
+ },
|
-
- | 4 |
- ! |
+
+ | 86 |
+ |
- echo = TRUE,
+ #' @description Convert the `TextBlock` to a list.
|
-
- | 5 |
- ! |
+
+ | 87 |
+ |
- tidy.opts = list(width.cutoff = 60),
+ #'
|
-
- | 6 |
- ! |
+
+ | 88 |
+ |
- tidy = requireNamespace("formatR", quietly = TRUE)
+ #' @return `named list` with a text and style.
|
- | 7 |
+ 89 |
|
- ))
+ #' @examples
|
- | 8 |
+ 90 |
|
-
+ #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
|
-
- | 9 |
- ! |
+
+ | 91 |
+ |
- if (!("teal.reporter.global_knitr" %in% names(op))) {
+ #' block <- TextBlock$new()
|
-
- | 10 |
- ! |
+
+ | 92 |
+ |
- options(default_global_knitr)
+ #' block$to_list()
|
- | 11 |
+ 93 |
|
- }
+ #'
|
- | 12 |
+ 94 |
|
-
+ to_list = function() {
|
-
- | 13 |
- ! |
+
+ | 95 |
+ 16x |
- invisible()
+ list(text = self$get_content(), style = self$get_style())
|
- | 14 |
+ 96 |
|
- }
+ }
|
- | 15 |
+ 97 |
|
-
+ ),
|
- | 16 |
+ 98 |
|
- .onAttach <- function(libname, pkgname) {
+ private = list(
|
-
- | 17 |
- 2x |
+
+ | 99 |
+ |
- packageStartupMessage(
+ style = character(0),
|
-
- | 18 |
- 2x |
+
+ | 100 |
+ |
- if (!requireNamespace("formatR", quietly = TRUE)) {
+ styles = c("default", "header2", "header3", "verbatim")
|
-
- | 19 |
- ! |
+
+ | 101 |
+ |
- "For better code formatting, consider installing the formatR package."
+ ),
|
- | 20 |
+ 102 |
|
- }
+ lock_objects = TRUE,
|
- | 21 |
+ 103 |
|
- )
+ lock_class = TRUE
|
- | 22 |
+ 104 |
|
- }
+ )
|
-
+
| 1 |
|
- #' @title `TextBlock`
+ #' @title `NewpageBlock`
|
| 2 |
|
- #' @keywords internal
+ #' @docType class
|
| 3 |
|
- TextBlock <- R6::R6Class( # nolint: object_name_linter.
+ #' @description
|
| 4 |
|
- classname = "TextBlock",
+ #' A `ContentBlock` subclass that represents a page break in a report output.
|
| 5 |
|
- inherit = ContentBlock,
+ #'
|
| 6 |
|
- public = list(
+ #' @keywords internal
|
| 7 |
|
- #' @description Returns a `TextBlock` object.
+ NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
|
| 8 |
|
- #'
+ classname = "NewpageBlock",
|
| 9 |
|
- #' @details Returns a `TextBlock` object with no content and the default style.
+ inherit = ContentBlock,
|
| 10 |
|
- #'
+ public = list(
|
| 11 |
|
- #' @param content (`character(1)` or `character(0)`) a string assigned to this `TextBlock`
+ #' @description Initialize a `NewpageBlock` object.
|
| 12 |
|
- #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
+ #'
|
| 13 |
|
- #'
+ #' @details Returns a `NewpageBlock` object with no content and the default style.
|
| 14 |
|
- #' @return `TextBlock`
+ #'
|
| 15 |
|
- #' @examples
+ #' @return Object of class `NewpageBlock`, invisibly.
|
| 16 |
|
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ #' @examples
|
| 17 |
|
- #' block <- TextBlock$new()
+ #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
|
| 18 |
|
- #'
+ #' block <- NewpageBlock$new()
|
| 19 |
|
- initialize = function(content = character(0), style = private$styles[1]) {
+ #'
|
-
+
| 20 |
- 130x |
+ |
- super$set_content(content)
+ initialize = function() {
|
| 21 |
- 130x |
+ 18x |
- self$set_style(style)
+ super$set_content("\n\\newpage\n")
|
| 22 |
- 130x |
+ 18x |
invisible(self)
|
@@ -21947,529 +23069,562 @@ teal.reporter coverage - 82.57%
23 |
|
- },
+ }
|
| 24 |
|
- #' @description Sets the style of this `TextBlock`.
+ ),
|
| 25 |
|
- #'
+ lock_objects = TRUE,
|
| 26 |
|
- #' @details The style has bearing on the rendering of this block.
+ lock_class = TRUE
|
| 27 |
|
- #'
+ )
|
+
+
+
+
+
+
- | 28 |
+ 1 |
|
- #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
+ .onLoad <- function(libname, pkgname) {
|
-
- | 29 |
- |
+
+ | 2 |
+ ! |
- #'
+ op <- options()
+ |
+
+
+ | 3 |
+ ! |
+
+ default_global_knitr <- list(teal.reporter.global_knitr = list(
+ |
+
+
+ | 4 |
+ ! |
+
+ echo = TRUE,
+ |
+
+
+ | 5 |
+ ! |
+
+ tidy.opts = list(width.cutoff = 60),
+ |
+
+
+ | 6 |
+ ! |
+
+ tidy = requireNamespace("formatR", quietly = TRUE)
|
- | 30 |
+ 7 |
|
- #' @return invisibly self
+ ))
|
- | 31 |
+ 8 |
|
- #' @examples
+
+ |
+
+
+ | 9 |
+ ! |
+
+ if (!("teal.reporter.global_knitr" %in% names(op))) {
+ |
+
+
+ | 10 |
+ ! |
+
+ options(default_global_knitr)
|
- | 32 |
+ 11 |
|
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ }
|
- | 33 |
+ 12 |
|
- #' block <- TextBlock$new()
+
+ |
+
+
+ | 13 |
+ ! |
+
+ invisible()
|
- | 34 |
+ 14 |
|
- #' block$set_style("header2")
+ }
|
- | 35 |
+ 15 |
|
- #'
+
|
- | 36 |
+ 16 |
|
- set_style = function(style) {
+ .onAttach <- function(libname, pkgname) {
|
- | 37 |
- 174x |
+ 17 |
+ 2x |
- private$style <- match.arg(style, private$styles)
+ packageStartupMessage(
|
- | 38 |
- 173x |
+ 18 |
+ 2x |
- invisible(self)
+ if (!requireNamespace("formatR", quietly = TRUE)) {
+ |
+
+
+ | 19 |
+ ! |
+
+ "For better code formatting, consider installing the formatR package."
|
- | 39 |
+ 20 |
|
- },
+ }
+ |
+
+
+ | 21 |
+ |
+
+ )
+ |
+
+
+ | 22 |
+ |
+
+ }
|
+
+
+
+
+
+
- | 40 |
+ 1 |
|
- #' @description Returns the style of this `TextBlock`.
+ #' @title `TableBlock`
|
- | 41 |
+ 2 |
|
- #'
+ #' @docType class
|
- | 42 |
+ 3 |
|
- #' @return `character(1)` the style of this `TextBlock`
+ #' @description
|
- | 43 |
+ 4 |
|
- #' @examples
+ #' Specialized `FileBlock` for managing table content in reports.
|
- | 44 |
+ 5 |
|
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ #' It's designed to handle various table formats, converting them into a consistent,
|
- | 45 |
+ 6 |
|
- #' block <- TextBlock$new()
+ #' document-ready format (e.g., `flextable`) for inclusion in reports.
|
- | 46 |
+ 7 |
|
- #' block$get_style()
+ #'
|
- | 47 |
+ 8 |
|
- #'
+ #' @keywords internal
|
- | 48 |
+ 9 |
|
- get_style = function() {
- |
-
-
- | 49 |
- 59x |
-
- private$style
+ TableBlock <- R6::R6Class( # nolint: object_name_linter.
|
- | 50 |
+ 10 |
|
- },
+ classname = "TableBlock",
|
- | 51 |
+ 11 |
|
- #' @description Returns an array of styles available to this `TextBlock`.
+ inherit = FileBlock,
|
- | 52 |
+ 12 |
|
- #'
+ public = list(
|
- | 53 |
+ 13 |
|
- #' @return a `character` array of styles
+ #' @description Initialize a `TableBlock` object.
|
- | 54 |
+ 14 |
|
- #' @examples
+ #'
|
- | 55 |
+ 15 |
|
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ #' @param table (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) a table assigned to
|
- | 56 |
+ 16 |
|
- #' block <- TextBlock$new()
+ #' this `TableBlock`
|
- | 57 |
+ 17 |
|
- #' block$get_available_styles()
+ #'
|
- | 58 |
+ 18 |
|
- #'
+ #' @return Object of class `TableBlock`, invisibly.
|
- | 59 |
+ 19 |
|
- get_available_styles = function() {
+ initialize = function(table) {
|
- | 60 |
- 23x |
+ 20 |
+ 36x |
- private$styles
+ if (!missing(table)) {
|
-
- | 61 |
- |
+
+ | 21 |
+ 6x |
- },
+ self$set_content(table)
|
- | 62 |
+ 22 |
|
- #' @description Create the `TextBlock` from a list.
+ }
|
-
- | 63 |
- |
+
+ | 23 |
+ 36x |
- #'
+ invisible(self)
|
- | 64 |
+ 24 |
|
- #' @param x `named list` with two fields `c("text", "style")`.
+ },
|
- | 65 |
+ 25 |
|
- #' Use the `get_available_styles` method to get all possible styles.
+ #' @description Sets content of this `TableBlock`.
|
- | 66 |
+ 26 |
|
#'
|
- | 67 |
+ 27 |
|
- #' @return invisibly self
+ #' @details Raises error if argument is not a table-like object.
|
- | 68 |
+ 28 |
|
- #' @examples
+ #'
|
- | 69 |
+ 29 |
|
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ #' @param content (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
|
- | 70 |
+ 30 |
|
- #' block <- TextBlock$new()
+ #' a table assigned to this `TableBlock`
|
- | 71 |
+ 31 |
|
- #' block$from_list(list(text = "sth", style = "default"))
+ #'
|
- | 72 |
+ 32 |
|
- #'
+ #' @return `self`, invisibly.
|
- | 73 |
+ 33 |
|
- from_list = function(x) {
- |
-
-
- | 74 |
- 36x |
-
- checkmate::assert_list(x)
- |
-
-
- | 75 |
- 36x |
-
- checkmate::assert_names(names(x), must.include = c("text", "style"))
- |
-
-
- | 76 |
- 36x |
-
- self$set_content(x$text)
- |
-
-
- | 77 |
- 36x |
-
- self$set_style(x$style)
- |
-
-
- | 78 |
- 36x |
-
- invisible(self)
+ #' @examples
|
- | 79 |
+ 34 |
|
- },
+ #' TableBlock <- getFromNamespace("TableBlock", "teal.reporter")
|
- | 80 |
+ 35 |
|
- #' @description Convert the `TextBlock` to a list.
+ #' block <- TableBlock$new()
|
- | 81 |
+ 36 |
|
- #'
+ #' block$set_content(iris)
|
- | 82 |
+ 37 |
|
- #' @return `named list` with a text and style.
+ #'
|
- | 83 |
+ 38 |
|
- #' @examples
+ set_content = function(content) {
|
-
- | 84 |
- |
+
+ | 39 |
+ 15x |
- #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
+ checkmate::assert_multi_class(content, private$supported_tables)
|
-
- | 85 |
- |
+
+ | 40 |
+ 14x |
- #' block <- TextBlock$new()
+ content <- to_flextable(content)
|
-
- | 86 |
- |
+
+ | 41 |
+ 14x |
- #' block$to_list()
+ path <- tempfile(fileext = ".rds")
|
-
- | 87 |
- |
+
+ | 42 |
+ 14x |
- #'
+ saveRDS(content, file = path)
|
-
- | 88 |
- |
+
+ | 43 |
+ 14x |
- to_list = function() {
+ super$set_content(path)
|
- | 89 |
- 16x |
+ 44 |
+ 14x |
- list(text = self$get_content(), style = self$get_style())
+ invisible(self)
|
- | 90 |
+ 45 |
|
}
|
- | 91 |
+ 46 |
|
),
|
- | 92 |
+ 47 |
|
private = list(
|
- | 93 |
- |
-
- style = character(0),
- |
-
-
- | 94 |
+ 48 |
|
- styles = c("default", "header2", "header3", "verbatim")
+ supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df")
|
- | 95 |
+ 49 |
|
),
|
- | 96 |
+ 50 |
|
lock_objects = TRUE,
|
- | 97 |
+ 51 |
|
lock_class = TRUE
|
- | 98 |
+ 52 |
|
)
| |