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