teal.reporter coverage - 82.57%

Files
Source

#' Reporter Previewer User Interface
#' @description `r lifecycle::badge("experimental")`
#' reporter previewer user interface to visualize and manipulate the already added report Cards
#' @param id `character(1)` this `shiny` module's id.
#' @export
reporter_previewer_ui <- function(id) {
  ns <- shiny::NS(id)

  shiny::fluidRow(
    add_previewer_js(ns),
    add_previewer_css(),
    shiny::tagList(
      shiny::tags$div(
        class = "col-md-3",
        shiny::tags$div(class = "well", shiny::uiOutput(ns("encoding")))
      ),
      shiny::tags$div(
        class = "col-md-9",
        shiny::tags$div(
          id = "reporter_previewer",
          shiny::uiOutput(ns("pcards"))
        )
      )
    )
  )
}

#' Reporter Previewer Server
#' @description `r lifecycle::badge("experimental")`
#' server supporting the functionalities of the reporter previewer
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter `Reporter` instance
#' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
#'  for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#' @details `r global_knitr_details()`
#'
#' @export
reporter_previewer_srv <- function(id,
                                   reporter,
                                   global_knitr = getOption("teal.reporter.global_knitr"),
                                   rmd_output = c(
                                     "html" = "html_document", "pdf" = "pdf_document",
                                     "powerpoint" = "powerpoint_presentation",
                                     "word" = "word_document"
                                   ), rmd_yaml_args = list(
                                     author = "NEST", title = "Report",
                                     date = as.character(Sys.Date()), output = "html_document",
                                     toc = FALSE
                                   )) {
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  checkmate::assert_subset(
    rmd_output,
    c(
      "html_document", "pdf_document",
      "powerpoint_presentation", "word_document"
    ),
    empty.ok = FALSE
  )
  checkmate::assert_list(rmd_yaml_args, names = "named")
  checkmate::assert_names(
    names(rmd_yaml_args),
    subset.of = c("author", "title", "date", "output", "toc"),
    must.include = "output"
  )
  checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)

  shiny::moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns

      teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter)

      output$encoding <- shiny::renderUI({
        reporter$get_reactive_add_card()
        shiny::tagList(
          shiny::tags$h3("Download the Report"),
          shiny::tags$hr(),
          reporter_download_inputs(
            rmd_yaml_args = rmd_yaml_args,
            rmd_output = rmd_output,
            showrcode = any_rcode_block(reporter),
            session = session
          ),
          htmltools::tagAppendAttributes(
            shiny::tags$a(
              id = ns("download_data_prev"),
              class = "btn btn-primary shiny-download-link",
              href = "",
              target = "_blank",
              download = NA,
              shiny::tags$span("Download Report", shiny::icon("download"))
            ),
            class = if (length(reporter$get_cards())) "" else "disabled"
          ),
          teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
        )
      })

      output$pcards <- shiny::renderUI({
        reporter$get_reactive_add_card()
        input$card_remove_id
        input$card_down_id
        input$card_up_id

        cards <- reporter$get_cards()

        if (length(cards)) {
          shiny::tags$div(
            class = "panel-group accordion",
            id = "reporter_previewer_panel",
            lapply(seq_along(cards), function(ic) {
              previewer_collapse_item(ic, cards[[ic]]$get_name(), cards[[ic]]$get_content())
            })
          )
        } else {
          shiny::tags$div(
            id = "reporter_previewer_panel_no_cards",
            shiny::tags$p(
              class = "text-danger mt-4",
              shiny::tags$strong("No Cards added")
            )
          )
        }
      })

      shiny::observeEvent(input$card_remove_id, {
        shiny::showModal(
          shiny::modalDialog(
            title = "Remove the Report Card",
            shiny::tags$p(
              shiny::HTML(
                sprintf(
                  "Do you really want to remove <strong>the card %s</strong> from the Report?",
                  input$card_remove_id
                )
              )
            ),
            footer = shiny::tagList(
              shiny::tags$button(
                type = "button",
                class = "btn btn-secondary",
                `data-dismiss` = "modal",
                `data-bs-dismiss` = "modal",
                NULL,
                "Cancel"
              ),
              shiny::actionButton(ns("remove_card_ok"), "OK", class = "btn-danger")
            )
          )
        )
      })

      shiny::observeEvent(input$remove_card_ok, {
        reporter$remove_cards(input$card_remove_id)
        shiny::removeModal()
      })

      shiny::observeEvent(input$card_up_id, {
        if (input$card_up_id > 1) {
          reporter$swap_cards(
            as.integer(input$card_up_id),
            as.integer(input$card_up_id - 1)
          )
        }
      })

      shiny::observeEvent(input$card_down_id, {
        if (input$card_down_id < length(reporter$get_cards())) {
          reporter$swap_cards(
            as.integer(input$card_down_id),
            as.integer(input$card_down_id + 1)
          )
        }
      })

      output$download_data_prev <- shiny::downloadHandler(
        filename = function() {
          paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
        },
        content = function(file) {
          shiny::showNotification("Rendering and Downloading the document.")
          input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
          names(input_list) <- names(rmd_yaml_args)
          if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
          report_render_and_compress(reporter, input_list, global_knitr, file)
        },
        contentType = "application/zip"
      )
    }
  )
}

#' @keywords internal
block_to_html <- function(b) {
  b_content <- b$get_content()
  if (inherits(b, "TextBlock")) {
    switch(b$get_style(),
      header1 = shiny::tags$h1(b_content),
      header2 = shiny::tags$h2(b_content),
      header3 = shiny::tags$h3(b_content),
      header4 = shiny::tags$h4(b_content),
      verbatim = shiny::tags$pre(b_content),
      shiny::tags$pre(b_content)
    )
  } else if (inherits(b, "RcodeBlock")) {
    panel_item("R Code", shiny::tags$pre(b_content))
  } else if (inherits(b, "PictureBlock")) {
    shiny::tags$img(src = knitr::image_uri(b_content))
  } else if (inherits(b, "TableBlock")) {
    b_table <- readRDS(b_content)
    shiny::tags$pre(
      flextable::htmltools_value(b_table)
    )
  } else if (inherits(b, "NewpageBlock")) {
    shiny::tags$br()
  } else {
    stop("Unknown block class")
  }
}

#' @keywords internal
add_previewer_css <- function() {
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/Previewer.css", package = "teal.reporter")))
    ),
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    )
  )
}

#' @keywords internal
add_previewer_js <- function(ns) {
  shiny::singleton(
    shiny::tags$head(shiny::tags$script(
      shiny::HTML(sprintf('
          $(document).ready(function(event) {
            $("body").on("click", "span.card_remove_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
            });

            $("body").on("click", "span.card_up_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
            });

             $("body").on("click", "span.card_down_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
             });
          });
         ', ns("card_remove_id"), ns("card_up_id"), ns("card_down_id")))
    ))
  )
}

#' @keywords internal
nav_previewer_icon <- function(name, icon_name, idx, size = 1L) {
  checkmate::assert_string(name)
  checkmate::assert_string(icon_name)
  checkmate::assert_int(size)

  shiny::tags$span(
    class = paste(name, "icon_previewer"),
    # data field needed to record clicked card on the js side
    `data-cardid` = idx,
    shiny::icon(icon_name, sprintf("fa-%sx", size))
  )
}

#' @keywords internal
nav_previewer_icons <- function(idx, size = 1L) {
  shiny::tags$span(
    class = "preview_card_control",
    nav_previewer_icon(name = "card_remove_id", icon_name = "xmark", idx = idx, size = size),
    nav_previewer_icon(name = "card_up_id", icon_name = "arrow-up", idx = idx, size = size),
    nav_previewer_icon(name = "card_down_id", icon_name = "arrow-down", idx = idx, size = size)
  )
}

#' @keywords internal
previewer_collapse_item <- function(idx, card_name, card_blocks) {
  shiny::tags$div(.renderHook = function(x) {
    # get bs version
    version <- get_bs_version()

    if (version == "3") {
      shiny::tags$div(
        id = paste0("panel_card_", idx),
        class = "panel panel-default",
        shiny::tags$div(
          class = "panel-heading overflow-auto",
          shiny::tags$div(
            class = "panel-title",
            shiny::tags$span(
              nav_previewer_icons(idx = idx),
              shiny::tags$a(
                class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
                `data-toggle` = "collapse",
                `data-parent` = "#reporter_previewer_panel",
                href = paste0("#collapse", idx),
                shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down"))
              )
            )
          )
        ),
        shiny::tags$div(
          id = paste0("collapse", idx), class = "collapse out",
          shiny::tags$div(
            class = "panel-body",
            shiny::tags$div(
              id = paste0("card", idx),
              lapply(
                card_blocks,
                function(b) {
                  block_to_html(b)
                }
              )
            )
          )
        )
      )
    } else {
      shiny::tags$div(
        id = paste0("panel_card_", idx),
        class = "card",
        shiny::tags$div(
          class = "overflow-auto",
          shiny::tags$div(
            class = "card-header",
            shiny::tags$span(
              nav_previewer_icons(idx = idx),
              shiny::tags$a(
                class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
                # bs4
                `data-toggle` = "collapse",
                # bs5
                `data-bs-toggle` = "collapse",
                href = paste0("#collapse", idx),
                shiny::tags$h4(
                  paste0("Card ", idx, ": ", card_name),
                  shiny::icon("caret-down")
                )
              )
            )
          )
        ),
        shiny::tags$div(
          id = paste0("collapse", idx),
          class = "collapse out",
          # bs4
          `data-parent` = "#reporter_previewer_panel",
          # bs5
          `data-bs-parent` = "#reporter_previewer_panel",
          shiny::tags$div(
            class = "card-body",
            shiny::tags$div(
              id = paste0("card", idx),
              lapply(
                card_blocks,
                function(b) {
                  block_to_html(b)
                }
              )
            )
          )
        )
      )
    }
  })
}

#' @title `Renderer`
#' @keywords internal
Renderer <- R6::R6Class( # nolint: object_name_linter.
  classname = "Renderer",
  public = list(
    #' @description Returns a `Renderer` object.
    #'
    #' @details Returns a `Renderer` object.
    #'
    #' @return `Renderer` object.
    #' @examples
    #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
    #' Renderer$new()
    #'
    initialize = function() {
      tmp_dir <- tempdir()
      output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
      dir.create(path = output_dir)
      private$output_dir <- output_dir
      invisible(self)
    },
    #' @description Finalizes a `Renderer` object.
    finalize = function() {
      unlink(private$output_dir, recursive = TRUE)
    },
    #' @description getting the `Rmd` text which could be easily rendered later.
    #'
    #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
    #' @param yaml_header `character` an `rmarkdown` `yaml` header.
    #' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
    #'  for customizing the rendering process.
    #' @details `r global_knitr_details()`
    #'
    #' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
    #' @examples
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #' card2$append_rcode("2+2", echo = FALSE)
    #'
    #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #'
    #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
    #' yaml_l <- list(
    #'   author = yaml_quoted("NEST"),
    #'   title = yaml_quoted("Report"),
    #'   date = yaml_quoted("07/04/2019"),
    #'   output = list(html_document = list(toc = FALSE))
    #' )
    #'
    #' md_header <- getFromNamespace("md_header", "teal.reporter")
    #' yaml_header <- md_header(yaml::as.yaml(yaml_l))
    #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
    #' result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
    #'
    renderRmd = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr")) {
      checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
      checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))

      if (missing(yaml_header)) {
        yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
      }

      private$report_type <- get_yaml_field(yaml_header, "output")

      parsed_global_knitr <- sprintf(
        "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n%s\n```\n",
        capture.output(dput(global_knitr)),
        if (identical(private$report_type, "powerpoint_presentation")) {
          format_code_block_function <- quote(
            code_block <- function(code_text) {
              df <- data.frame(code_text)
              ft <- flextable::flextable(df)
              ft <- flextable::delete_part(ft, part = "header")
              ft <- flextable::autofit(ft, add_h = 0)
              ft <- flextable::fontsize(ft, size = 7, part = "body")
              ft <- flextable::bg(x = ft, bg = "lightgrey")
              ft <- flextable::border_outer(ft)
              if (flextable::flextable_dim(ft)$widths > 8) {
                ft <- flextable::width(ft, width = 8)
              }
              ft
            }
          )
          paste(deparse(format_code_block_function), collapse = "\n")
        } else {
          ""
        }
      )

      parsed_blocks <- paste(
        unlist(
          lapply(blocks, function(b) private$block2md(b))
        ),
        collapse = "\n\n"
      )

      rmd_text <- paste0(yaml_header, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
      tmp <- tempfile(fileext = ".Rmd")
      input_path <- file.path(
        private$output_dir,
        sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
      )
      cat(rmd_text, file = input_path)
      input_path
    },
    #' @description Renders the content of this `Report` to the output file
    #'
    #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
    #' @param yaml_header `character` an `rmarkdown` `yaml` header.
    #' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
    #'  for customizing the rendering process.
    #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
    #' @details `r global_knitr_details()`
    #'
    #' @return `character` path to the output
    #' @examples
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #' card2$append_rcode("2+2", echo = FALSE)
    #' Reporter <- getFromNamespace("Reporter", "teal.reporter")$new()
    #' Reporter$append_cards(list(card1, card2))
    #'
    #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
    #' yaml_l <- list(
    #'   author = yaml_quoted("NEST"),
    #'   title = yaml_quoted("Report"),
    #'   date = yaml_quoted("07/04/2019"),
    #'   output = list(html_document = list(toc = FALSE))
    #' )
    #'
    #' md_header <- getFromNamespace("md_header", "teal.reporter")
    #' yaml_header <- md_header(yaml::as.yaml(yaml_l))
    #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
    #' result_path <- Renderer$new()$render(Reporter$get_blocks(), yaml_header)
    #'
    render = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
      args <- list(...)
      input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
      args <- append(args, list(
        input = input_path,
        output_dir = private$output_dir,
        output_format = "all",
        quiet = TRUE
      ))
      args_nams <- unique(names(args))
      args <- lapply(args_nams, function(x) args[[x]])
      names(args) <- args_nams
      do.call(rmarkdown::render, args)
    },
    #' @description get `output_dir` field
    #'
    #' @return `character` a `output_dir` field path.
    #' @examples
    #' Renderer <- getFromNamespace("Renderer", "teal.reporter")$new()
    #' Renderer$get_output_dir()
    #'
    get_output_dir = function() {
      private$output_dir
    }
  ),
  private = list(
    output_dir = character(0),
    report_type = NULL,
    # factory method
    block2md = function(block) {
      if (inherits(block, "TextBlock")) {
        private$textBlock2md(block)
      } else if (inherits(block, "RcodeBlock")) {
        private$rcodeBlock2md(block)
      } else if (inherits(block, "PictureBlock")) {
        private$pictureBlock2md(block)
      } else if (inherits(block, "TableBlock")) {
        private$tableBlock2md(block)
      } else if (inherits(block, "NewpageBlock")) {
        block$get_content()
      } else {
        stop("Unknown block class")
      }
    },
    # card specific methods
    textBlock2md = function(block) {
      text_style <- block$get_style()
      block_content <- block$get_content()
      switch(text_style,
        "default" = block_content,
        "verbatim" = sprintf("\n```\n%s\n```\n", block_content),
        "header2" = paste0("## ", block_content),
        "header3" = paste0("### ", block_content),
        block_content
      )
    },
    rcodeBlock2md = function(block) {
      params <- block$get_params()
      params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
      if (identical(private$report_type, "powerpoint_presentation")) {
        block_content_list <- split_text_block(block$get_content(), 30)
        paste(
          sprintf(
            "\\newpage\n\n---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
            shQuote(block_content_list, type = "cmd")
          ),
          collapse = "\n\n"
        )
      } else {
        sprintf(
          "\\newpage\n\n--- \n\n```{r, %s}\n%s\n```\n",
          paste(names(params), params, sep = "=", collapse = ", "),
          block$get_content()
        )
      }
    },
    pictureBlock2md = function(block) {
      basename_pic <- basename(block$get_content())
      file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
      params <- c(
        `out.width` = "'100%'",
        `out.height` = "'100%'"
      )
      title <- block$get_title()
      if (length(title)) params["fig.cap"] <- shQuote(title)
      sprintf(
        "\n```{r, echo = FALSE, %s}\nknitr::include_graphics(path = '%s')\n```\n",
        paste(names(params), params, sep = "=", collapse = ", "),
        basename_pic
      )
    },
    tableBlock2md = function(block) {
      basename_table <- basename(block$get_content())
      file.copy(block$get_content(), file.path(private$output_dir, basename_table))
      sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `ReportCard`
#' @description `r lifecycle::badge("experimental")`
#' R6 class that supports creating a report card containing text, plot, table and
#' meta data blocks that can be appended and rendered to form a report output from a shiny app.
#' @export
#'
ReportCard <- R6::R6Class( # nolint: object_name_linter.
  classname = "ReportCard",
  public = list(
    #' @description Returns a `ReportCard` object.
    #'
    #' @return a `ReportCard` object
    #' @examples
    #' card <- ReportCard$new()
    #'
    initialize = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Appends a table to this `ReportCard`.
    #'
    #' @param table the appended table
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_table(iris)
    #'
    append_table = function(table) {
      self$append_content(TableBlock$new(table))
      invisible(self)
    },
    #' @description Appends a plot to this `ReportCard`.
    #'
    #' @param plot the appended plot
    #' @param dim `integer vector` width and height in pixels.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    append_plot = function(plot, dim = NULL) {
      pb <- PictureBlock$new()
      if (!is.null(dim) && length(dim) == 2) {
        pb$set_dim(dim)
      }
      pb$set_content(plot)
      self$append_content(pb)
      invisible(self)
    },
    #' @description Appends a paragraph of text to this `ReportCard`.
    #'
    #' @param text (`character(0)` or `character(1)`) the text
    #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_text("A paragraph of default text")
    #'
    append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
      self$append_content(TextBlock$new(text, style))
      invisible(self)
    },
    #' @description Appends an `rmarkdown` R chunk to this `ReportCard`.
    #'
    #' @param text (`character(0)` or `character(1)`) the text
    #' @param ... any `rmarkdown` R chunk parameter and its value.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
    #'
    append_rcode = function(text, ...) {
      self$append_content(RcodeBlock$new(text, ...))
      invisible(self)
    },
    #' @description Appends a `ContentBlock` to this `ReportCard`.
    #'
    #' @param content (`ContentBlock`)
    #' @return invisibly self
    #' @examples
    #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
    #' card <- ReportCard$new()$append_content(NewpageBlock$new())
    #'
    append_content = function(content) {
      checkmate::assert_class(content, "ContentBlock")
      private$content <- append(private$content, content)
      invisible(self)
    },
    #' @description Returns the content of this `ReportCard`.
    #'
    #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_content()
    #'
    #'
    get_content = function() {
      private$content
    },
    #' @description Removes all objects added to this `ReportCard`.
    #'
    #' @return invisibly self
    #'
    reset = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Returns the metadata of this `ReportCard`.
    #'
    #' @return `named list` list of elements.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `ReportCard`.
    #'
    #' @param key (`character(1)`) name of meta data.
    #' @param value value of meta data.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #' card$get_metadata()
    #'
    append_metadata = function(key, value) {
      checkmate::assert_character(key, min.len = 0, max.len = 1)
      checkmate::assert_false(key %in% names(private$metadata))
      meta_list <- list()
      meta_list[[key]] <- value
      private$metadata <- append(private$metadata, meta_list)
      invisible(self)
    },
    #' @description get the Card name
    #'
    #' @return `character` a Card name
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    get_name = function() {
      private$name
    },
    #' @description set the Card name
    #'
    #' @param name `character` a Card name
    #' @return invisibly self
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    set_name = function(name) {
      checkmate::assert_string(name)
      private$name <- name
      invisible(self)
    },
    #' @description Convert the `ReportCard` to a list.
    #' @param output_dir `character` with a path to the directory where files will be copied.
    #' @return `named list` a `ReportCard` representation.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #'
    #' card$to_list(tempdir())
    #'
    to_list = function(output_dir) {
      new_blocks <- list()
      for (block in self$get_content()) {
        block_class <- class(block)[1]
        cblock <- if (inherits(block, "FileBlock")) {
          block$to_list(output_dir)
        } else if (inherits(block, "ContentBlock")) {
          block$to_list()
        } else {
          list()
        }
        new_block <- list()
        new_block[[block_class]] <- cblock
        new_blocks <- c(new_blocks, new_block)
      }
      new_card <- list()
      new_card[["blocks"]] <- new_blocks
      new_card[["metadata"]] <- self$get_metadata()
      new_card
    },
    #' @description Create the `ReportCard` from a list.
    #' @param card `named list` a `ReportCard` representation.
    #' @param output_dir `character` with a path to the directory where a file will be copied.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #'
    #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
    #'
    from_list = function(card, output_dir) {
      self$reset()
      blocks <- card$blocks
      metadata <- card$metadata
      blocks_names <- names(blocks)
      blocks_names <- gsub("[.][0-9]*$", "", blocks_names)
      for (iter_b in seq_along(blocks)) {
        block_class <- blocks_names[iter_b]
        block <- blocks[[iter_b]]
        cblock <- eval(str2lang(sprintf("%s$new()", block_class)))
        if (inherits(cblock, "FileBlock")) {
          cblock$from_list(block, output_dir)
        } else if (inherits(cblock, "ContentBlock")) {
          cblock$from_list(block)
        } else {
          NULL
        }
        self$append_content(cblock)
      }
      for (meta in names(metadata)) {
        self$append_metadata(meta, metadata[[meta]])
      }
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    metadata = list(),
    name = character(0),
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "content") {
        lapply(value, function(content_block) {
          if (inherits(content_block, "R6")) {
            content_block$clone(deep = TRUE)
          } else {
            content_block
          }
        })
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `ContentBlock`
#' @keywords internal
ContentBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "ContentBlock",
  public = list(
    #' @description Returns a `ContentBlock` object.
    #'
    #' @details Returns a `ContentBlock` object with no content and the default style.
    #'
    #' @return `ContentBlock`
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' ContentBlock$new()
    #'
    initialize = function() {
      private$content <- character(0)
      invisible(self)
    },
    #' @description Sets content of this `ContentBlock`.
    #'
    #' @param content (`character(0)` or `character(1)`) a string literal or a file path assigned to this `ContentBlock`
    #'
    #' @return invisibly self
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' block <- ContentBlock$new()
    #' block$set_content("Base64 encoded picture")
    #'
    set_content = function(content) {
      checkmate::assert_character(content, min.len = 0, max.len = 1)
      private$content <- content
      invisible(self)
    },
    #' @description Returns the absolute path to content of this `ContentBlock`
    #'
    #' @return `character` content of this `ContentBlock`
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' block <- ContentBlock$new()
    #' block$get_content()
    #'
    get_content = function() {
      private$content
    },
    #' @description Create the `ContentBlock` from a list.
    #'
    #' @param x `named list` with two fields `c("text", "style")`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return invisibly self
    from_list = function(x) {
      invisible(self)
    },
    #' @description Convert the `ContentBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    to_list = function() {
      list()
    }
  ),
  private = list(
    content = character(0),
    # @description The copy constructor.
    #
    # @param name `character(1)` the name of the field
    # @param value the value assigned to the field
    #
    # @return the value of the copied field
    deep_clone = function(name, value) {
      if (name == "content" && checkmate::test_file_exists(value)) {
        extension <- ""
        split <- strsplit(basename(value), split = "\\.")
        # The below ensures no extension is found for files such as this: .gitignore but is found for files like
        # .gitignore.txt
        if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
          extension <- split[[1]][length(split[[1]])]
          extension <- paste0(".", extension)
        }
        copied_file <- tempfile(fileext = extension)
        file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
        copied_file
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `RcodeBlock`
#' @keywords internal
RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "RcodeBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns a `RcodeBlock` object.
    #'
    #' @details Returns a `RcodeBlock` object with no content and no parameters.
    #'
    #' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock`
    #' @param ... any `rmarkdown` R chunk parameter and it value.
    #'
    #' @return `RcodeBlock`
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #'
    initialize = function(content = character(0), ...) {
      super$set_content(content)
      self$set_params(list(...))
      invisible(self)
    },
    #' @description Sets the parameters of this `RcodeBlock`.
    #'
    #' @details The parameters has bearing on the rendering of this block.
    #'
    #' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
    #'
    #' @return invisibly self
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #' block$set_params(list(echo = TRUE))
    #'
    set_params = function(params) {
      checkmate::assert_list(params, names = "named")
      checkmate::assert_subset(names(params), self$get_available_params())
      private$params <- params
      invisible(self)
    },
    #' @description Returns the parameters of this `RcodeBlock`.
    #'
    #' @return `character` the parameters of this `RcodeBlock`
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #' block$get_params()
    #'
    get_params = function() {
      private$params
    },
    #' @description Returns an array of parameters available to this `RcodeBlock`.
    #'
    #' @return a `character` array of parameters
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #' block$get_available_params()
    #'
    get_available_params = function() {
      names(knitr::opts_chunk$get())
    },
    #' @description Create the `RcodeBlock` from a list.
    #'
    #' @param x `named list` with two fields `c("text", "params")`.
    #' Use the `get_available_params` method to get all possible parameters.
    #'
    #' @return invisibly self
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #' block$from_list(list(text = "sth", params = list()))
    #'
    from_list = function(x) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = c("text", "params"))
      self$set_content(x$text)
      self$set_params(x$params)
      invisible(self)
    },
    #' @description Convert the `RcodeBlock` to a list.
    #'
    #' @return `named list` with a text and `params`.
    #' @examples
    #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
    #' block <- RcodeBlock$new()
    #' block$to_list()
    #'
    to_list = function() {
      list(text = self$get_content(), params = self$get_params())
    }
  ),
  private = list(
    params = list()
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Get bootstrap current version
#' @note will work properly mainly inside a tag `.renderHook`
#' @keywords internal
get_bs_version <- function() {
  theme <- bslib::bs_current_theme()
  if (bslib::is_bs_theme(theme)) {
    bslib::theme_version(theme)
  } else {
    "3"
  }
}

#' Panel group widget
#' @md
#'
#' @description `r lifecycle::badge("experimental")`
#' @param title (`character`)\cr title of panel
#' @param ... content of panel
#' @param collapsed (`logical`, optional)\cr
#'  whether to initially collapse panel
#' @param input_id (`character`, optional)\cr
#'  name of the panel item element. If supplied, this will register a shiny input variable that
#'  indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
#'
#' @return (`shiny.tag`)
#'
#' @keywords internal
panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
  stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
  checkmate::assert_flag(collapsed)
  checkmate::assert_string(input_id, null.ok = TRUE)

  div_id <- paste0(input_id, "_div")
  panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))


  shiny::tags$div(.renderHook = function(res_tag) {
    bs_version <- get_bs_version()

    # alter tag structure
    if (bs_version == "3") {
      res_tag$children <- list(
        shiny::tags$div(
          class = "panel panel-default",
          shiny::tags$div(
            id = div_id,
            class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
            `data-toggle` = "collapse",
            href = paste0("#", panel_id),
            `aria-expanded` = ifelse(collapsed, "false", "true"),
            shiny::icon("angle-down", class = "dropdown-icon"),
            shiny::tags$label(
              class = "panel-title inline",
              title,
            )
          ),
          shiny::tags$div(
            class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
            id = panel_id,
            shiny::tags$div(
              class = "panel-body",
              ...
            )
          )
        )
      )
    } else if (bs_version %in% c("4", "5")) {
      res_tag$children <- list(
        shiny::tags$div(
          class = "card my-2",
          shiny::tags$div(
            class = "card-header",
            shiny::tags$div(
              class = ifelse(collapsed, "collapsed", ""),
              # bs4
              `data-toggle` = "collapse",
              # bs5
              `data-bs-toggle` = "collapse",
              href = paste0("#", panel_id),
              `aria-expanded` = ifelse(collapsed, "false", "true"),
              shiny::icon("angle-down", class = "dropdown-icon"),
              shiny::tags$label(
                class = "card-title inline",
                title,
              )
            )
          ),
          shiny::tags$div(
            id = panel_id,
            class = paste("collapse", ifelse(collapsed, "", "show")),
            shiny::tags$div(
              class = "card-body",
              ...
            )
          )
        )
      )
    } else {
      stop("Bootstrap 3, 4, and 5 are supported.")
    }

    shiny::tagList(
      shiny::singleton(
        shiny::tags$head(
          shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter"))
        )
      ),
      res_tag
    )
  })
}

#' Convert content into a `flextable`, merge cells with `colspan` > 1
#' align columns to the center, and row names to the left
#' Indent the row names by 10 times indentation
#'
#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
#'
#' @return (`flextable`)
#'
#' @keywords internal
to_flextable <- function(content) {
  if (inherits(content, c("rtables", "TableTree", "ElementaryTable", "listing_df"))) {
    mf <- rtables::matrix_form(content)
    nr_header <- attr(mf, "nrow_header")
    non_total_coln <- c(TRUE, !grepl("All Patients", names(content)))
    df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
    header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])

    ft <- flextable::flextable(df)
    ft <- flextable::delete_part(ft, part = "header")
    ft <- flextable::add_header(ft, values = header_df)

    # Add titles
    ft <- flextable::set_caption(ft, flextable::as_paragraph(
      flextable::as_b(mf$main_title), "\n", paste(mf$subtitles, collapse = "\n")
    ),
    align_with_table = FALSE
    )

    merge_index_body <- get_merge_index(mf$spans[seq(nr_header + 1, nrow(mf$spans)), , drop = FALSE])
    merge_index_header <- get_merge_index(mf$spans[seq_len(nr_header), , drop = FALSE])

    ft <- merge_at_indice(ft, lst = merge_index_body, part = "body")
    ft <- merge_at_indice(ft, lst = merge_index_header, part = "header")
    ft <- flextable::align_text_col(ft, align = "center", header = TRUE)
    ft <- flextable::align(ft, i = seq_len(nrow(content)), j = 1, align = "left")
    ft <- padding_lst(ft, mf$row_info$indent)
    ft <- flextable::padding(ft, padding.top = 1, padding.bottom = 1, part = "all")
    ft <- flextable::autofit(ft, add_h = 0)

    width_vector <- c(
      dim(ft)$widths[1],
      rep(sum(dim(ft)$widths[-1]), length(dim(ft)$widths) - 1) / (ncol(mf$strings) - 1)
    )
    ft <- flextable::width(ft, width = width_vector)
    ft <- custom_theme(ft)

    # Add footers
    ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
      flextable::as_chunk(mf$main_footer, props = flextable::fp_text_default(font.size = 8))
    ))
    if (length(mf$main_footer) > 0 && length(mf$prov_footer) > 0) ft <- flextable::add_footer_lines(ft, c("\n"))
    ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
      flextable::as_chunk(mf$prov_footer, props = flextable::fp_text_default(font.size = 8))
    ))
  } else if (inherits(content, "data.frame")) {
    ft <- flextable::flextable(content)
    ft <- custom_theme(ft)
  } else {
    stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
  }

  if (flextable::flextable_dim(ft)$widths > 10) {
    pgwidth <- 10.5
    width_vector <- dim(ft)$widths * pgwidth / flextable::flextable_dim(ft)$widths
    ft <- flextable::width(ft, width = width_vector)
  }

  ft
}

#' Apply a custom theme to a `flextable`
#' @noRd
#'
#' @keywords internal
custom_theme <- function(ft) {
  checkmate::assert_class(ft, "flextable")
  ft <- flextable::fontsize(ft, size = 8, part = "body")
  ft <- flextable::bold(ft, part = "header")
  ft <- flextable::theme_booktabs(ft)
  ft <- flextable::hline(ft, border = flextable::fp_border_default(width = 1, color = "grey"))
  ft <- flextable::border_outer(ft)
  ft
}

#' Get the merge index for a single span.
#' This function retrieves the merge index for a single span,
#' which is used in merging cells.
#' @noRd
#'
#' @keywords internal
get_merge_index_single <- function(span) {
  ret <- list()
  j <- 1
  while (j < length(span)) {
    if (span[j] != 1) {
      ret <- c(ret, list(seq(j, j + span[j] - 1)))
    }
    j <- j + span[j]
  }
  return(ret)
}

#' Get the merge index for multiple spans.
#' This function merges cells in a `flextable` at specified row and column indices.
#' @noRd
#'
#' @keywords internal
get_merge_index <- function(spans) {
  ret <- lapply(seq_len(nrow(spans)), function(i) {
    ri <- spans[i, ]
    r <- get_merge_index_single(ri)
    lapply(r, function(s) {
      list(j = s, i = i)
    })
  })
  unlist(ret, recursive = FALSE, use.names = FALSE)
}

#' Merge cells in a `flextable` at specified indices
#' @noRd
#'
#' @keywords internal
merge_at_indice <- function(ft, lst, part) {
  Reduce(function(ft, ij) {
    flextable::merge_at(ft, i = ij$i, j = ij$j, part = part)
  }, lst, ft)
}

#' Apply padding to a `flextable` based on indentation levels.
#' This function applies padding to a `flextable` based on indentation levels provided as a vector.
#' @noRd
#'
#' @keywords internal
padding_lst <- function(ft, indents) {
  Reduce(function(ft, s) {
    flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
  }, seq_len(length(indents)), ft)
}

#' Split a text block into smaller blocks with a specified number of lines.
#'
#' Divide text block into smaller blocks.
#'
#' A single character string containing a text block of multiple lines (separated by `\n`)
#' is split into multiple strings with n or less lines each.
#'
#' @param x `character` string containing the input block of text
#' @param n `integer` number of lines per block
#'
#' @return
#' List of character strings with up to `n` lines in each element.
#'
#' @keywords internal
split_text_block <- function(x, n) {
  checkmate::assert_string(x)
  checkmate::assert_integerish(n, lower = 1L, len = 1L)

  lines <- strsplit(x, "\n")[[1]]

  if (length(lines) <= n) {
    return(list(x))
  }

  nblocks <- ceiling(length(lines) / n)
  ind <- rep(1:nblocks, each = n)[seq_along(lines)]
  unname(lapply(split(lines, ind), paste, collapse = "\n"))
}

#' Retrieve text details for global_knitr options
#' This function returns a character string describing the default settings for the global_knitr options.
#' @noRd
#'
#' @keywords internal
global_knitr_details <- function() {
  paste0(
    c(
      " To access the default values for the `global_knitr` parameter,",
      "  use `getOption('teal.reporter.global_knitr')`. These defaults include:",
      " - `echo = TRUE`",
      " - `tidy.opts = list(width.cutoff = 60)`",
      " - `tidy = TRUE`  if `formatR` package is installed, `FALSE` otherwise"
    ),
    collapse = "\n"
  )
}

#' @title quoted string for `yaml`
#' @description add quoted attribute for `yaml` package
#' @param x `character`
#' @keywords internal
#' @examples
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
#' yaml <- list(
#'   author = yaml_quoted("NEST"),
#'   title = yaml_quoted("Report"),
#'   date = yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' yaml::as.yaml(yaml)
yaml_quoted <- function(x) {
  attr(x, "quoted") <- TRUE
  x
}

#' @title wrap a `yaml` string to the `markdown` header
#' @description wrap a `yaml` string to the `markdown` header.
#' @param x `character` `yaml` formatted string.
#' @keywords internal
#' @examples
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
#' yaml <- list(
#'   author = yaml_quoted("NEST"),
#'   title = yaml_quoted("Report"),
#'   date = yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' md_header <- getFromNamespace("md_header", "teal.reporter")
#' md_header(yaml::as.yaml(yaml))
md_header <- function(x) {
  paste0("---\n", x, "---\n")
}

#' @title Convert a character of a `yaml` boolean to a logical value
#' @description convert a character of a `yaml` boolean to a logical value.
#' @param input `character`
#' @param name `charcter`
#' @param pos_logi `character` vector of `yaml` values which should be treated as `TRUE`.
#' @param neg_logi `character` vector of `yaml` values which should be treated as `FALSE`.
#' @param silent `logical` if to suppress the messages and warnings.
#' @return `input` argument or the appropriate `logical` value.
#' @keywords internal
#' @examples
#'
#' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter")
#' conv_str_logi("TRUE")
#' conv_str_logi("True")
#'
#' conv_str_logi("off")
#' conv_str_logi("n")
#'
#' conv_str_logi("sth")
conv_str_logi <- function(input,
                          name = "",
                          pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"),
                          neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"),
                          silent = TRUE) {
  checkmate::assert_string(input)
  checkmate::assert_string(name)
  checkmate::assert_character(pos_logi)
  checkmate::assert_character(neg_logi)
  checkmate::assert_flag(silent)

  all_logi <- c(pos_logi, neg_logi)
  if (input %in% all_logi) {
    if (isFALSE(silent)) {
      message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
    }
    input %in% pos_logi
  } else {
    input
  }
}

#' @title Get document output types from the `rmarkdown` package
#'
#' @description `r lifecycle::badge("experimental")`
#' get document output types from the `rmarkdown` package.
#' @return `character` vector.
#' @export
#' @examples
#' rmd_outputs()
rmd_outputs <- function() {
  rmarkdown_namespace <- asNamespace("rmarkdown")
  ls(rmarkdown_namespace)[grep("_document|_presentation", ls(rmarkdown_namespace))]
}

#' @title Get document output arguments from the `rmarkdown` package
#'
#' @description `r lifecycle::badge("experimental")`
#' get document output arguments from the `rmarkdown` package
#' @param output_name `character` `rmarkdown` output name.
#' @param default_values `logical` if to return a default values for each argument.
#' @export
#' @examples
#' rmd_output_arguments("pdf_document")
#' rmd_output_arguments("pdf_document", TRUE)
rmd_output_arguments <- function(output_name, default_values = FALSE) {
  checkmate::assert_string(output_name)
  checkmate::assert_subset(output_name, rmd_outputs())

  rmarkdown_namespace <- asNamespace("rmarkdown")
  if (default_values) {
    formals(rmarkdown_namespace[[output_name]])
  } else {
    names(formals(rmarkdown_namespace[[output_name]]))
  }
}

#' @title Parse a Named List to the `Rmd` `yaml` Header
#' @description `r lifecycle::badge("experimental")`
#' parse a named list to the `Rmd` `yaml` header, so the developer gets automatically tabulated `Rmd` `yaml` header.
#' Only a non nested (flat) list will be processed,
#' where as a nested list is directly processed with the [`yaml::as.yaml`] function.
#' All `Rmd` `yaml` header fields from the vector are supported,
#' `c("author", "date", "title", "subtitle", "abstract", "keywords", "subject", "description", "category", "lang")`.
#' Moreover all `output`field types in the `rmarkdown` package and their arguments are supported.
#' @param input_list `named list` non nested with slots names and their values compatible with `Rmd` `yaml` header.
#' @param as_header `logical` optionally wrap with result with the internal `md_header()`, default `TRUE`.
#' @param convert_logi `logical` convert a character values to logical,
#'  if they are recognized as quoted `yaml` logical values , default `TRUE`.
#' @param multi_output `logical` multi `output` slots in the `input` argument, default `FALSE`.
#' @param silent `logical` suppress messages and warnings, default `FALSE`.
#' @return `character` with `rmd_yaml_header` class,
#' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`.
#' @export
#' @examples
#' # nested so using yaml::as.yaml directly
#' as_yaml_auto(
#'   list(author = "", output = list(pdf_document = list(toc = TRUE)))
#' )
#'
#' # auto parsing for a flat list, like shiny input
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
#' as_yaml_auto(input)
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
#'
#' as_yaml_auto(list(
#'   author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
#'   wrong = 2
#' ))
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
#'   silent = TRUE
#' )
#'
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
#' as_yaml_auto(input)
#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
#' as_yaml_auto(input, silent = TRUE)
#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
#'
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = TRUE, keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = "True", keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
as_yaml_auto <- function(input_list,
                         as_header = TRUE,
                         convert_logi = TRUE,
                         multi_output = FALSE,
                         silent = FALSE) {
  checkmate::assert_logical(as_header)
  checkmate::assert_logical(convert_logi)
  checkmate::assert_logical(silent)
  checkmate::assert_logical(multi_output)

  if (multi_output) {
    checkmate::assert_list(input_list, names = "named")
  } else {
    checkmate::assert_list(input_list, names = "unique")
  }

  is_nested <- function(x) any(unlist(lapply(x, is.list)))
  if (is_nested(input_list)) {
    result <- input_list
  } else {
    result <- list()
    input_nams <- names(input_list)

    # top fields
    top_fields <- c(
      "author", "date", "title", "subtitle", "abstract",
      "keywords", "subject", "description", "category", "lang"
    )
    for (itop in top_fields) {
      if (itop %in% input_nams) {
        result[[itop]] <- switch(itop,
          date = as.character(input_list[[itop]]),
          input_list[[itop]]
        )
      }
    }

    # output field
    doc_types <- unlist(input_list[input_nams == "output"])
    if (length(doc_types)) {
      for (dtype in doc_types) {
        doc_type_args <- rmd_output_arguments(dtype, TRUE)
        doc_type_args_nams <- names(doc_type_args)
        any_output_arg <- any(input_nams %in% doc_type_args_nams)

        not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
        if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
          warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
        }

        if (any_output_arg) {
          doc_list <- list()
          doc_list[[dtype]] <- list()
          for (e in intersect(input_nams, doc_type_args_nams)) {
            if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
              pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
              neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
              all_logi <- c(pos_logi, neg_logi)
              if (input_list[[e]] %in% all_logi && convert_logi) {
                input_list[[e]] <- conv_str_logi(input_list[[e]], e,
                  pos_logi = pos_logi,
                  neg_logi = neg_logi, silent = silent
                )
              }
            }

            doc_list[[dtype]][[e]] <- input_list[[e]]
          }
          result[["output"]] <- append(result[["output"]], doc_list)
        } else {
          result[["output"]] <- append(result[["output"]], input_list[["output"]])
        }
      }
    }
  }

  result <- yaml::as.yaml(result)
  if (as_header) {
    result <- md_header(result)
  }
  structure(result, class = "rmd_yaml_header")
}

#' @title Print method for the `yaml_header` class
#'
#' @description `r lifecycle::badge("experimental")`
#' Print method for the `yaml_header` class.
#' @param x `rmd_yaml_header` class object.
#' @param ... optional text.
#' @return NULL
#' @exportS3Method
#' @examples
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
#' out <- as_yaml_auto(input)
#' out
#' print(out)
print.rmd_yaml_header <- function(x, ...) {
  cat(x, ...)
}

#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
#' otherwise, the field itself.
#'
#' @param yaml_text A character vector containing the `yaml` text.
#' @param field_name The name of the field to extract.
#'
#' @return if the field is a list, it returns the names of elements in the list; otherwise,
#' it returns the extracted field.
#'
#' @keywords internal
get_yaml_field <- function(yaml_text, field_name) {
  checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
  checkmate::assert_string(field_name)

  yaml_obj <- yaml::yaml.load(yaml_text)

  result <- yaml_obj[[field_name]]
  if (is.list(result)) {
    result <- names(result)
  }
  result
}

#' Add Card Button User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for adding views/cards to the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny::tagList`
#' @export
add_card_button_ui <- function(id) {
  ns <- shiny::NS(id)

  # Buttons with custom css and
  # js code to disable the add card button when clicked to prevent multi-clicks
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::singleton(
      shiny::tags$head(
        shiny::tags$script(
          shiny::HTML(
            sprintf(
              '
              $(document).ready(function(event) {
                $("body").on("click", "#%s", function() {
                  $(this).addClass("disabled");
                })
              })',
              ns("add_card_ok")
            )
          )
        )
      )
    ),
    shiny::tags$button(
      id = ns("add_report_card_button"),
      type = "button",
      class = "simple_report_button btn btn-primary action-button",
      title = "Add Card",
      `data-val` = shiny::restoreInput(id = ns("add_report_card_button"), default = NULL),
      NULL,
      shiny::tags$span(
        shiny::icon("plus")
      )
    )
  )
}

#' Add Card Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for adding views/cards to the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details
#' This module allows using a child of [`ReportCard`] instead of [`ReportCard`].
#' To properly support this, an instance of the child class must be passed
#' as the default value of the `card` argument in the `card_fun` function.
#' See below:
#' ```{r}
#' CustomReportCard <- R6::R6Class( # nolint: object_name_linter.
#'   classname = "CustomReportCard",
#'   inherit = teal.reporter::ReportCard
#' )
#'
#' custom_function <- function(card = CustomReportCard$new()) {
#'   card
#' }
#' ```
#'
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @param card_fun `function` which returns a [`ReportCard`] instance. It can have optional `card`, `comment` and
#' `label` parameters. If `card` parameter is added, then the `ReportCard` instance is created for the user.
#' Use `comment` parameter to pass it's value whenever you prefer with `card$append_text()` - if `card_fun` does not
#' have `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the
#' card. If `label` parameter is provided, you can use it to customize appearance of the `card name` and use if to
#' specify `card` content with `card$append_text()` - if `card_fun` does not have `label` parameter, then `card name`
#' will be set to the name passed in `Add Card UI` module, but no text will be added to the content of the `card`.
#'
#' @return `shiny::moduleServer`
#' @export
add_card_button_srv <- function(id, reporter, card_fun) {
  checkmate::assert_function(card_fun)
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)

  shiny::moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns
      add_modal <- function() {
        shiny::modalDialog(
          easyClose = TRUE,
          shiny::tags$h3("Add a Card to the Report"),
          shiny::tags$hr(),
          shiny::textInput(
            ns("label"),
            "Card Name",
            value = "",
            placeholder = "Add the card title here",
            width = "100%"
          ),
          shiny::textAreaInput(
            ns("comment"),
            "Comment",
            value = "",
            placeholder = "Add a comment here...",
            width = "100%"
          ),
          shiny::tags$script(
            shiny::HTML(
              sprintf(
                "
                $('#shiny-modal').on('shown.bs.modal', () => {
                  $('#%s').focus()
                })
                ",
                ns("label")
              )
            )
          ),
          footer = shiny::div(
            shiny::tags$button(
              type = "button",
              class = "btn btn-secondary",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            shiny::tags$button(
              id = ns("add_card_ok"),
              type = "button",
              class = "btn btn-primary action-button",
              `data-val` = shiny::restoreInput(id = ns("add_card_ok"), default = NULL),
              NULL,
              "Add Card"
            )
          )
        )
      }

      shiny::observeEvent(input$add_report_card_button, {
        shiny::showModal(add_modal())
      })

      # the add card button is disabled when clicked to prevent multi-clicks
      # please check the ui part for more information
      shiny::observeEvent(input$add_card_ok, {
        card_fun_args_nams <- names(formals(card_fun))
        has_card_arg <- "card" %in% card_fun_args_nams
        has_comment_arg <- "comment" %in% card_fun_args_nams
        has_label_arg <- "label" %in% card_fun_args_nams

        arg_list <- list()

        if (has_comment_arg) {
          arg_list <- c(arg_list, list(comment = input$comment))
        }
        if (has_label_arg) {
          arg_list <- c(arg_list, list(label = input$label))
        }

        if (has_card_arg) {
          # The default_card is defined here because formals() returns a pairedlist object
          # of formal parameter names and their default values. The values are missing
          # if not defined and the missing check does not work if supplied formals(card_fun)[[1]]
          default_card <- formals(card_fun)$card
          card <- `if`(
            missing(default_card),
            ReportCard$new(),
            eval(default_card, envir = environment(card_fun))
          )
          arg_list <- c(arg_list, list(card = card))
        }

        card <- try(do.call(card_fun, arg_list))

        if (inherits(card, "try-error")) {
          msg <- paste0(
            "The card could not be added to the report. ",
            "Have the outputs for the report been created yet? If not please try again when they ",
            "are ready. Otherwise contact your application developer"
          )
          warning(msg)
          shiny::showNotification(
            msg,
            type = "error"
          )
        } else {
          checkmate::assert_class(card, "ReportCard")
          if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
            card$append_text("Comment", "header3")
            card$append_text(input$comment)
          }

          if (!has_label_arg && length(input$label) == 1 && input$label != "") {
            card$set_name(input$label)
          }

          reporter$append_cards(list(card))
          shiny::showNotification(sprintf("The card added successfully."), type = "message")
          shiny::removeModal()
        }
      })
    }
  )
}

#' @title `Reporter`
#' @description `r lifecycle::badge("experimental")`
#' R6 class that stores and manages report cards.
#' @export
#'
Reporter <- R6::R6Class( # nolint: object_name_linter.
  classname = "Reporter",
  public = list(
    #' @description Returns a `Reporter` object.
    #'
    #' @return a `Reporter` object
    #' @examples
    #' reporter <- teal.reporter::Reporter$new()
    #'
    initialize = function() {
      private$cards <- list()
      private$reactive_add_card <- shiny::reactiveVal(0)
      invisible(self)
    },
    #' @description Appends a table to this `Reporter`.
    #'
    #' @param cards [`ReportCard`] or a list of such objects
    #' @return invisibly self
    #' @examples
    #' card1 <- teal.reporter::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.reporter::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #'
    append_cards = function(cards) {
      checkmate::assert_list(cards, "ReportCard")
      private$cards <- append(private$cards, cards)
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description Returns cards of this `Reporter`.
    #'
    #' @return `list()` list of [`ReportCard`]
    #' @examples
    #' card1 <- teal.reporter::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.reporter::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      private$cards
    },
    #' @description Returns blocks of all [`ReportCard`] of this `Reporter`.
    #'
    #' @param sep the element inserted between each content element in this `Reporter`.
    #' Pass `NULL` to return content without any additional elements. Default: `NewpageBlock$new()`
    #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`
    #' @examples
    #' card1 <- teal.reporter::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.reporter::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_blocks()
    #'
    get_blocks = function(sep = NewpageBlock$new()) {
      blocks <- list()
      if (length(private$cards) > 0) {
        for (card_idx in head(seq_along(private$cards), -1)) {
          blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
        }
        blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
      }
      blocks
    },
    #' @description Removes all [`ReportCard`] objects added to this `Reporter`.
    #' Additionally all metadata are removed.
    #'
    #' @return invisibly self
    #'
    reset = function() {
      private$cards <- list()
      private$metadata <- list()
      private$reactive_add_card(0)
      invisible(self)
    },
    #' @description remove a specific Card in the Reporter
    #'
    #' @param ids `integer` the indexes of cards
    #' @return invisibly self
    remove_cards = function(ids = NULL) {
      checkmate::assert(
        checkmate::check_null(ids),
        checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
      )
      if (!is.null(ids)) {
        private$cards <- private$cards[-ids]
      }
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description swap two cards in the Reporter
    #'
    #' @param start `integer` the index of the first card
    #' @param end `integer` the index of the second card
    #' @return invisibly self
    swap_cards = function(start, end) {
      checkmate::assert(
        checkmate::check_integer(start,
          min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
        ),
        checkmate::check_integer(end,
          min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
        ),
        combine = "and"
      )
      start_val <- private$cards[[start]]$clone()
      end_val <- private$cards[[end]]$clone()
      private$cards[[start]] <- end_val
      private$cards[[end]] <- start_val
      invisible(self)
    },
    #' @description get a value for the reactive value for the add card
    #'
    #' @return `reactive_add_card` field value
    #' @note The function has to be used in the shiny reactive context.
    #' @examples
    #' shiny::isolate(Reporter$new()$get_reactive_add_card())
    get_reactive_add_card = function() {
      private$reactive_add_card()
    },
    #' @description get metadata of this `Reporter`.
    #'
    #' @return metadata
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `Reporter`.
    #'
    #' @param meta (`list`) of metadata.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    append_metadata = function(meta) {
      checkmate::assert_list(meta, names = "unique")
      checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata)))
      private$metadata <- append(private$metadata, meta)
      invisible(self)
    },
    #' @description Create/Recreate a Reporter from another Reporter
    #' @param reporter `Reporter` instance.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' reporter$from_reporter(reporter)
    from_reporter = function(reporter) {
      checkmate::assert_class(reporter, "Reporter")
      self$reset()
      self$append_cards(reporter$get_cards())
      self$append_metadata(reporter$get_metadata())
      invisible(self)
    },
    #' @description Convert a Reporter to a list and transfer files
    #' @param output_dir `character(1)` a path to the directory where files will be copied.
    #' @return `named list` `Reporter` representation
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "testdir")
    #' dir.create(tmp_dir)
    #' reporter$to_list(tmp_dir)
    to_list = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      rlist <- list(version = "1", cards = list())
      rlist[["metadata"]] <- self$get_metadata()
      for (card in self$get_cards()) {
        # we want to have list names being a class names to indicate the class for $from_list
        card_class <- class(card)[1]
        u_card <- list()
        u_card[[card_class]] <- card$to_list(output_dir)
        rlist$cards <- c(rlist$cards, u_card)
      }
      rlist
    },
    #' @description Create/Recreate a Reporter from a list and directory with files
    #' @param rlist `named list` `Reporter` representation.
    #' @param output_dir `character(1)` a path to the directory from which files will be copied.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "testdir")
    #' unlink(tmp_dir, recursive = TRUE)
    #' dir.create(tmp_dir)
    #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
    from_list = function(rlist, output_dir) {
      checkmate::assert_list(rlist)
      checkmate::assert_directory_exists(output_dir)
      if (rlist$version == "1") {
        new_cards <- list()
        cards_names <- names(rlist$cards)
        cards_names <- gsub("[.][0-9]*$", "", cards_names)
        for (iter_c in seq_along(rlist$cards)) {
          card_class <- cards_names[iter_c]
          card <- rlist$cards[[iter_c]]
          new_card <- eval(str2lang(sprintf("%s$new()", card_class)))
          new_card$from_list(card, output_dir)
          new_cards <- c(new_cards, new_card)
        }
      } else {
        stop("The provided version is not supported")
      }
      self$reset()
      self$append_cards(new_cards)
      self$append_metadata(rlist$metadata)
      invisible(self)
    },
    #' @description Create/Recreate a Reporter to a directory with `JSON` file and static files
    #' @param output_dir `character(1)` a path to the directory where files will be copied, `JSON` and statics.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "jsondir")
    #' dir.create(tmp_dir)
    #' reporter$to_jsondir(tmp_dir)
    to_jsondir = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      json <- self$to_list(output_dir)
      cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
        file = file.path(output_dir, "Report.json")
      )
      output_dir
    },
    #' @description Create/Recreate a Reporter from a directory with `JSON` file and static files
    #' @param output_dir `character(1)` a path to the directory with files, `JSON` and statics.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "jsondir")
    #' dir.create(tmp_dir)
    #' unlink(list.files(tmp_dir, recursive = TRUE))
    #' reporter$to_jsondir(tmp_dir)
    #' reporter$from_jsondir(tmp_dir)
    from_jsondir = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      checkmate::assert_true(length(list.files(output_dir)) > 0)
      dir_files <- list.files(output_dir)
      which_json <- grep("json$", dir_files)
      json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
      self$reset()
      self$from_list(json, output_dir)
      invisible(self)
    }
  ),
  private = list(
    cards = list(),
    metadata = list(),
    reactive_add_card = NULL,
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "cards") {
        lapply(value, function(card) card$clone(deep = TRUE))
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Download Button Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for downloading the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny::tagList`
#' @export
download_report_button_ui <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$button(
      id = ns("download_button"),
      type = "button",
      class = "simple_report_button btn btn-primary action-button",
      title = "Download",
      `data-val` = shiny::restoreInput(id = ns("download_button"), default = NULL),
      NULL,
      shiny::tags$span(
        shiny::icon("download")
      )
    )
  )
}

#' Download Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for downloading the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @param global_knitr `list` a of `knitr` parameters (passed to `knitr::opts_chunk$set`)
#'  for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#' @return `shiny::moduleServer`
#' @details `r global_knitr_details()`
#'
#' @export
download_report_button_srv <- function(id,
                                       reporter,
                                       global_knitr = getOption("teal.reporter.global_knitr"),
                                       rmd_output = c(
                                         "html" = "html_document", "pdf" = "pdf_document",
                                         "powerpoint" = "powerpoint_presentation", "word" = "word_document"
                                       ),
                                       rmd_yaml_args = list(
                                         author = "NEST", title = "Report",
                                         date = as.character(Sys.Date()), output = "html_document",
                                         toc = FALSE
                                       )) {
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  checkmate::assert_subset(
    rmd_output,
    c(
      "html_document", "pdf_document",
      "powerpoint_presentation", "word_document"
    ),
    empty.ok = FALSE
  )
  checkmate::assert_list(rmd_yaml_args, names = "named")
  checkmate::assert_names(
    names(rmd_yaml_args),
    subset.of = c("author", "title", "date", "output", "toc"),
    must.include = "output"
  )
  checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)

  shiny::moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns

      download_modal <- function() {
        nr_cards <- length(reporter$get_cards())
        downb <- shiny::tags$a(
          id = ns("download_data"),
          class = paste("btn btn-primary shiny-download-link", if (nr_cards) NULL else "disabled"),
          style = if (nr_cards) NULL else "pointer-events: none;",
          href = "",
          target = "_blank",
          download = NA,
          shiny::icon("download"),
          "Download"
        )
        shiny::modalDialog(
          easyClose = TRUE,
          shiny::tags$h3("Download the Report"),
          shiny::tags$hr(),
          if (length(reporter$get_cards()) == 0) {
            shiny::tags$div(
              class = "mb-4",
              shiny::tags$p(
                class = "text-danger",
                shiny::tags$strong("No Cards Added")
              )
            )
          } else {
            shiny::tags$div(
              class = "mb-4",
              shiny::tags$p(
                class = "text-success",
                shiny::tags$strong(paste("Number of cards: ", nr_cards))
              ),
            )
          },
          reporter_download_inputs(
            rmd_yaml_args = rmd_yaml_args,
            rmd_output = rmd_output,
            showrcode = any_rcode_block(reporter),
            session = session
          ),
          footer = shiny::tagList(
            shiny::tags$button(
              type = "button",
              class = "btn btn-secondary",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            downb
          )
        )
      }

      shiny::observeEvent(input$download_button, {
        shiny::showModal(download_modal())
      })

      output$download_data <- shiny::downloadHandler(
        filename = function() {
          paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
        },
        content = function(file) {
          shiny::showNotification("Rendering and Downloading the document.")
          input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
          names(input_list) <- names(rmd_yaml_args)
          if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
          report_render_and_compress(reporter, input_list, global_knitr, file)
        },
        contentType = "application/zip"
      )
    }
  )
}

#' Render the Report
#' @description render the report and zip the created directory.
#' @param reporter [`Reporter`] instance.
#' @param input_list `list` like shiny input converted to a regular named list.
#' @param global_knitr `list` a global `knitr` parameters, like echo.
#' But if local parameter is set it will have priority.
#' @param file `character` where to copy the returned directory.
#' @return `file` argument, invisibly.
#' @keywords internal
report_render_and_compress <- function(reporter, input_list, global_knitr, file = tempdir()) {
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_list(input_list, names = "named")
  checkmate::assert_string(file)

  if (identical("pdf_document", input_list$output) &&
    inherits(try(system2("pdflatex", "--version", stdout = TRUE), silent = TRUE), "try-error")) {
    shiny::showNotification(
      ui = "pdflatex is not available so the pdf_document could not be rendered. Please use other output type.",
      action = "Please contact app developer",
      type = "error"
    )
    stop("pdflatex is not available so the pdf_document could not be rendered.")
  }

  yaml_header <- as_yaml_auto(input_list)
  renderer <- Renderer$new()

  tryCatch(
    renderer$render(reporter$get_blocks(), yaml_header, global_knitr),
    warning = function(cond) {
      shiny::showNotification(
        ui = "Render document warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      shiny::showNotification(
        ui = "Render document error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

  temp_zip_file <- tempfile(fileext = ".zip")
  tryCatch(
    expr = zip::zipr(temp_zip_file, renderer$get_output_dir()),
    warning = function(cond) {
      shiny::showNotification(
        ui = "Zipping folder warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      shiny::showNotification(
        ui = "Zipping folder error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

  tryCatch(
    expr = file.copy(temp_zip_file, file),
    warning = function(cond) {
      shiny::showNotification(
        ui = "Copying file warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      shiny::showNotification(
        ui = "Copying file error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

  rm(renderer)
  invisible(file)
}

#' Get the custom list of User Interface inputs
#' @param rmd_output `character` vector with `rmarkdown` output types,
#' by default all possible `c("pdf_document", "html_document", "powerpoint_presentation", "word_document")`.
#' If vector is named then those names will appear in the `UI`.
#' @param rmd_yaml_args `named list` with `Rmd` `yaml` header fields and their default values.
#' This `list` will result in the custom subset of User Interface inputs for the download reporter functionality.
#' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`.
#' The `list` must include at least `"output"` field.
#' The default value for `"output"` has to be in the `rmd_output` argument.
#' @keywords internal
reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) {
  shiny::tagList(
    lapply(names(rmd_yaml_args), function(e) {
      switch(e,
        author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author),
        title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title),
        date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date),
        output = shiny::tags$div(
          shinyWidgets::pickerInput(
            inputId = session$ns("output"),
            label = "Choose a document type: ",
            choices = rmd_output,
            selected = rmd_yaml_args$output
          )
        ),
        toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc)
      )
    }),
    if (showrcode) {
      shiny::checkboxInput(
        session$ns("showrcode"),
        label = "Include R Code",
        value = FALSE
      )
    }
  )
}

#' @keywords internal
any_rcode_block <- function(reporter) {
  any(
    vapply(
      reporter$get_blocks(),
      function(e) inherits(e, "RcodeBlock"),
      logical(1)
    )
  )
}

#' @title `Archiver`
#' @keywords internal
Archiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "Archiver",
  public = list(
    #' @description Returns an `Archiver` object.
    #'
    #' @return an `Archiver` object
    #' @examples
    #' Archiver <- getFromNamespace("Archiver", "teal.reporter")
    #' Archiver$new()
    initialize = function() {
      invisible(self)
    },
    #' @description Finalizes an `Archiver` object.
    finalize = function() {
      # destructor
    },
    #' @description Pure virtual method for reading an `Archiver`.
    read = function() {
      # returns Reporter instance
      stop("Pure virtual method.")
    },
    #' @description Pure virtual method for writing an `Archiver`.
    write = function() {
      stop("Pure virtual method.")
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `RDSArchiver`
#' @keywords internal
FileArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileArchiver",
  inherit = Archiver,
  public = list(
    #' @description Returns a `FileArchiver` object.
    #'
    #' @return a `FileArchiver` object
    #' @examples
    #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
    #' FileArchiver$new()
    initialize = function() {
      tmp_dir <- tempdir()
      output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
      dir.create(path = output_dir)
      private$output_dir <- output_dir
      invisible(self)
    },
    #' @description Finalizes a `FileArchiver` object.
    finalize = function() {
      unlink(private$output_dir, recursive = TRUE)
    },
    #' @description get `output_dir` field
    #'
    #' @return `character` a `output_dir` field path.
    #' @examples
    #' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
    #' FileArchiver$new()$get_output_dir()
    get_output_dir = function() {
      private$output_dir
    }
  ),
  private = list(
    output_dir = character(0)
  )
)

#' @title `JSONArchiver`
#' @keywords internal
JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "JSONArchiver",
  inherit = FileArchiver,
  public = list(
    #' @description write a `Reporter` instance in to this `JSONArchiver` object.
    #'
    #' @param reporter `Reporter` instance.
    #'
    #' @return invisibly self
    #' @examples
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1))
    #'
    #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
    #' archiver <- JSONArchiver$new()
    #' archiver$write(reporter)
    #' archiver$get_output_dir()
    write = function(reporter) {
      checkmate::assert_class(reporter, "Reporter")
      unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
      reporter$to_jsondir(private$output_dir)
      self
    },
    #' @description read a `Reporter` instance from a directory with `JSONArchiver`.
    #'
    #' @param path `character(1)` a path to the directory with all proper files.
    #'
    #' @return `Reporter` instance.
    #' @examples
    #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1))
    #'
    #' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
    #' archiver <- JSONArchiver$new()
    #' archiver$write(reporter)
    #' archiver$get_output_dir()
    #'
    #' archiver$read()$get_cards()[[1]]$get_content()
    #' Reporter <- getFromNamespace("Reporter", "teal.reporter")
    #' blocks <- Reporter$new()
    #' blocks <- blocks$from_reporter(archiver$read())$get_blocks()
    #' Renderer <- getFromNamespace("Renderer", "teal.reporter")
    #' doc <- Renderer$new()$render(blocks)
    read = function(path = NULL) {
      checkmate::assert(
        checkmate::check_null(path),
        checkmate::check_directory_exists(path)
      )

      if (!is.null(path) && !identical(path, private$output_dir)) {
        unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
        file.copy(list.files(path, full.names = TRUE), private$output_dir)
      }

      if (length(list.files(private$output_dir))) {
        Reporter$new()$from_jsondir(private$output_dir)
      } else {
        warning("The directory provided to the Archiver is empty.")
        Reporter$new()
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `TableBlock`
#' @keywords internal
TableBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TableBlock",
  inherit = FileBlock,
  public = list(
    #' @description Returns a new `TableBlock` object
    #'
    #' @param table (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`) a table assigned to
    #'   this `TableBlock`
    #'
    #' @return a `TableBlock` object
    initialize = function(table) {
      if (!missing(table)) {
        self$set_content(table)
      }
      invisible(self)
    },
    #' @description Sets content of this `TableBlock`.
    #'
    #' @details throws if argument is not a table-like object.
    #'
    #' @param content (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`) a table assigned to
    #'   this `TableBlock`
    #'
    #' @return invisibly self
    #' @examples
    #' TableBlock <- getFromNamespace("TableBlock", "teal.reporter")
    #' block <- TableBlock$new()
    #' block$set_content(iris)
    #'
    set_content = function(content) {
      checkmate::assert_multi_class(content, private$supported_tables)
      content <- to_flextable(content)
      path <- tempfile(fileext = ".rds")
      saveRDS(content, file = path)
      super$set_content(path)
      invisible(self)
    }
  ),
  private = list(
    supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Reset Button Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for resetting the report content.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param label `character(1)` label before the icon.
#' By default `NULL`.
#' @return `shiny::tagList`
#' @export
reset_report_button_ui <- function(id, label = NULL) {
  checkmate::assert_string(label, null.ok = TRUE)

  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$button(
      id = ns("reset_reporter"),
      type = "button",
      class = "simple_report_button btn btn-warning action-button",
      title = "Reset",
      `data-val` = shiny::restoreInput(id = ns("reset_reporter"), default = NULL),
      NULL,
      shiny::tags$span(
        if (!is.null(label)) label,
        shiny::icon("xmark")
      )
    )
  )
}

#' Reset Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for resetting the Report content.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @return `shiny::moduleServer`
#' @export
reset_report_button_srv <- function(id, reporter) {
  checkmate::assert_class(reporter, "Reporter")

  shiny::moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns
      nr_cards <- length(reporter$get_cards())


      shiny::observeEvent(input$reset_reporter, {
        shiny::showModal(
          shiny::modalDialog(
            shiny::tags$h3("Reset the Report"),
            shiny::tags$hr(),
            shiny::tags$strong(
              shiny::tags$p(
                "Are you sure you want to reset the report? (This will remove ALL previously added cards)."
              )
            ),
            footer = shiny::tagList(
              shiny::tags$button(
                type = "button",
                class = "btn btn-secondary",
                `data-dismiss` = "modal",
                `data-bs-dismiss` = "modal",
                NULL,
                "Cancel"
              ),
              shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn-danger")
            )
          )
        )
      })

      shiny::observeEvent(input$reset_reporter_ok, {
        reporter$reset()
        shiny::removeModal()
      })
    }
  )
}

#' @title `PictureBlock`
#' @keywords internal
#' @noRd
PictureBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "PictureBlock",
  inherit = FileBlock,
  public = list(
    #' @description Returns a new `PictureBlock` object.
    #'
    #' @param plot (`ggplot`, `grid`) a picture in this `PictureBlock`
    #'
    #' @return a `PictureBlock` object
    initialize = function(plot) {
      if (!missing(plot)) {
        self$set_content(plot)
      }
      invisible(self)
    },
    #' @description Sets the content of this `PictureBlock`.
    #'
    #' @details throws if argument is not a `ggplot`, `grob` or `trellis` plot.
    #'
    #' @param content (`ggplot`, `grob`, `trellis`) a picture in this `PictureBlock`
    #'
    #' @return invisibly self
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplot2::ggplot(iris))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(lattice::bwplot(1))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplot2::ggplotGrob(ggplot2::ggplot(iris)))
    set_content = function(content) {
      checkmate::assert_multi_class(content, private$supported_plots)
      path <- tempfile(fileext = ".png")
      grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
      tryCatch(
        expr = {
          if (inherits(content, "grob")) {
            grid::grid.newpage()
            grid::grid.draw(content)
          } else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
            print(content)
          } else if (inherits(content, "trellis")) {
            grid::grid.newpage()
            grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
          }
          super$set_content(path)
        },
        finally = grDevices::dev.off()
      )
      invisible(self)
    },
    #' @description Sets the title of this `PictureBlock`.
    #'
    #' @details throws if argument is not `character(1)`.
    #'
    #' @param title (`character(1)`) a string assigned to this `PictureBlock`
    #'
    #' @return invisibly self
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_title("Title")
    #'
    set_title = function(title) {
      checkmate::assert_string(title)
      private$title <- title
      invisible(self)
    },
    #' @description Returns the title of this `PictureBlock`
    #'
    #' @return the content of this `PictureBlock`
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$get_title()
    #'
    get_title = function() {
      private$title
    },
    #' @description Sets the dimensions of this `PictureBlock`
    #'
    #' @param dim `numeric` figure dimensions (width and height) in pixels, length 2.
    #'
    #' @return `self`
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_dim(c(800, 600))
    #'
    set_dim = function(dim) {
      checkmate::assert_numeric(dim, len = 2)
      private$dim <- dim
      invisible(self)
    },
    #' @description Returns the dimensions of this `PictureBlock`
    #'
    #' @return `numeric` the array of 2 numeric values representing width and height in pixels.
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$get_dim()
    get_dim = function() {
      private$dim
    }
  ),
  private = list(
    supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
    type = character(0),
    title = "",
    dim = c(800, 600)
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `NewpageBlock`
#' @keywords internal
NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "NewpageBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns a `NewpageBlock` object.
    #'
    #' @details Returns a `NewpageBlock` object with no content and the default style.
    #'
    #' @return `NewpageBlock`
    #' @examples
    #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
    #' block <- NewpageBlock$new()
    #'
    initialize = function() {
      super$set_content("\n\\newpage\n")
      invisible(self)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `FileBlock`
#' @keywords internal
FileBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileBlock",
  inherit = ContentBlock,
  public = list(
    #' @description finalize of this `FileBlock`.
    #'
    #' @details Removes the temporary file created in the constructor.
    finalize = function() {
      try(unlink(super$get_content()))
    },
    #' @description Create the `FileBlock` from a list.
    #' The list should contain one named field, `"basename"`.
    #'
    #' @param x `named list` with one field `"basename"`, a name of the file.
    #' @param output_dir `character` with a path to the directory where a file will be copied.
    #'
    #' @return invisibly self
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' file_path <- tempfile(fileext = ".png")
    #' saveRDS(iris, file_path)
    #' block$from_list(list(basename = basename(file_path)), dirname(file_path))
    #'
    from_list = function(x, output_dir) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = "basename")
      path <- file.path(output_dir, x$basename)
      file_type <- paste0(".", tools::file_ext(path))
      checkmate::assert_file_exists(path, extension = file_type)
      new_file_path <- tempfile(fileext = file_type)
      file.copy(path, new_file_path)
      super$set_content(new_file_path)
      invisible(self)
    },
    #' @description Convert the `FileBlock` to a list.
    #'
    #' @param output_dir `character` with a path to the directory where a file will be copied.
    #'
    #' @return `named list` with a `basename` of the file.
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' block$to_list(tempdir())
    #'
    to_list = function(output_dir) {
      base_name <- basename(super$get_content())
      file.copy(super$get_content(), file.path(output_dir, base_name))
      list(basename = base_name)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Simple Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' three buttons for adding cards, downloading and resetting the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny.tag`
#' @export
#'
#' @examples
#' if (interactive()) {
#'   shiny::shinyApp(
#'     ui = shiny::fluidPage(simple_reporter_ui("simple")),
#'     server = function(input, output, session) {
#'       simple_reporter_srv("simple", Reporter$new(), function(card) card)
#'     }
#'   )
#' }
simple_reporter_ui <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$div(
      class = "block mb-4 p-1",
      shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
      shiny::tags$div(
        class = "simple_reporter_container",
        add_card_button_ui(ns("add_report_card_simple")),
        download_report_button_ui(ns("download_button_simple")),
        reset_report_button_ui(ns("reset_button_simple"))
      )
    )
  )
}

#' Simple Reporter Server
#' @description `r lifecycle::badge("experimental")`
#' three buttons for adding cards, downloading and resetting the Report.
#' The add module has `add_report_card_simple` id, the download module the `download_button_simple` id
#' and the reset module the `reset_button_simple` id.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @param card_fun `function` which returns a [`ReportCard`] instance,
#' the function has a `card` argument and an optional `comment` argument.
#' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#' @details `r global_knitr_details()`
#'
#' @return `shiny::moduleServer`
#' @export
simple_reporter_srv <- function(id,
                                reporter,
                                card_fun,
                                global_knitr = getOption("teal.reporter.global_knitr"),
                                rmd_output = c(
                                  "html" = "html_document", "pdf" = "pdf_document",
                                  "powerpoint" = "powerpoint_presentation", "word" = "word_document"
                                ),
                                rmd_yaml_args = list(
                                  author = "NEST", title = "Report",
                                  date = as.character(Sys.Date()), output = "html_document",
                                  toc = FALSE
                                )) {
  shiny::moduleServer(
    id,
    function(input, output, session) {
      add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
      download_report_button_srv(
        "download_button_simple",
        reporter = reporter,
        global_knitr = global_knitr,
        rmd_output = rmd_output,
        rmd_yaml_args = rmd_yaml_args
      )
      reset_report_button_srv("reset_button_simple", reporter = reporter)
    }
  )
}

.onLoad <- function(libname, pkgname) {
  op <- options()
  default_global_knitr <- list(teal.reporter.global_knitr = list(
    echo = TRUE,
    tidy.opts = list(width.cutoff = 60),
    tidy = requireNamespace("formatR", quietly = TRUE)
  ))

  if (!("teal.reporter.global_knitr" %in% names(op))) {
    options(default_global_knitr)
  }

  invisible()
}

.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    if (!requireNamespace("formatR", quietly = TRUE)) {
      "For better code formatting, consider installing the formatR package."
    }
  )
}

#' @title `TextBlock`
#' @keywords internal
TextBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TextBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns a `TextBlock` object.
    #'
    #' @details Returns a `TextBlock` object with no content and the default style.
    #'
    #' @param content (`character(1)` or `character(0)`) a string assigned to this `TextBlock`
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return `TextBlock`
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #'
    initialize = function(content = character(0), style = private$styles[1]) {
      super$set_content(content)
      self$set_style(style)
      invisible(self)
    },
    #' @description Sets the style of this `TextBlock`.
    #'
    #' @details The style has bearing on the rendering of this block.
    #'
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return invisibly self
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$set_style("header2")
    #'
    set_style = function(style) {
      private$style <- match.arg(style, private$styles)
      invisible(self)
    },
    #' @description Returns the style of this `TextBlock`.
    #'
    #' @return `character(1)` the style of this `TextBlock`
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$get_style()
    #'
    get_style = function() {
      private$style
    },
    #' @description Returns an array of styles available to this `TextBlock`.
    #'
    #' @return a `character` array of styles
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$get_available_styles()
    #'
    get_available_styles = function() {
      private$styles
    },
    #' @description Create the `TextBlock` from a list.
    #'
    #' @param x `named list` with two fields `c("text", "style")`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return invisibly self
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$from_list(list(text = "sth", style = "default"))
    #'
    from_list = function(x) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = c("text", "style"))
      self$set_content(x$text)
      self$set_style(x$style)
      invisible(self)
    },
    #' @description Convert the `TextBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$to_list()
    #'
    to_list = function() {
      list(text = self$get_content(), style = self$get_style())
    }
  ),
  private = list(
    style = character(0),
    styles = c("default", "header2", "header3", "verbatim")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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		#' 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		#' 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		#' 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 `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		#' @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		.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		)