teal.reporter coverage - 82.62%

Files
Source

File	Lines	Relevant	Covered	Missed	Hits / Line	Coverage
R/zzz.R	22	11	2	9	0	18.18%
R/utils.R	295	139	79	60	12	56.83%
R/Renderer.R	282	97	66	31	5	68.04%
R/DownloadModule.R	299	159	120	39	4	75.47%
R/Previewer.R	395	221	177	44	7	80.09%
R/ContentBlock.R	94	18	16	2	98	88.89%
R/PictureBlock.R	129	27	25	2	17	92.59%
R/ReportCard.R	269	72	68	4	28	94.44%
R/yaml_utils.R	316	78	76	2	12	97.44%
R/AddCardModule.R	212	105	103	2	8	98.10%
R/Reporter.R	334	89	88	1	14	98.88%
R/ResetModule.R	86	41	41	0	6	100.00%
R/Archiver.R	181	24	24	0	5	100.00%
R/SimpleReporter.R	86	23	23	0	2	100.00%
R/RcodeBlock.R	104	15	15	0	52	100.00%
R/FileBlock.R	61	13	13	0	31	100.00%
R/TextBlock.R	104	13	13	0	78	100.00%
R/TableBlock.R	52	9	9	0	18	100.00%
R/NewpageBlock.R	27	2	2	0	18	100.00%

#' @title `RcodeBlock`
#' @docType class
#' @description
#' Specialized `ContentBlock` designed to embed `R` code in reports.
#'
#' @keywords internal
RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "RcodeBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Initialize 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 Object of class `RcodeBlock`, invisibly.
    #' @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 Configures `rmarkdown` chunk parameters for the `R` code block,
    #' influencing its rendering and execution behavior.
    #'
    #' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
    #'
    #' @return `self`, invisibly.
    #' @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 Get 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 Get available 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 `text` and `params`.
    #' Use the `get_available_params` method to get all possible parameters.
    #'
    #' @return `self`, invisibly.
    #' @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
)

#' Mark strings for quotation in `yaml` serialization
#'
#' This function is designed for use with the `yaml` package to explicitly,
#' It adds an attribute to character strings, indicating that they should be serialized with double quotes.
#'
#' @param x (`character`)
#' @keywords internal
#' @examples
#' library(yaml)
#' 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))
#' )
#' as.yaml(yaml)
yaml_quoted <- function(x) {
  attr(x, "quoted") <- TRUE
  x
}

#' Create `markdown` header from `yaml` string
#'
#' This function wraps a `yaml`-formatted string in Markdown header delimiters.
#'
#' @param x (`character`) `yaml` formatted string.
#' @keywords internal
#' @examples
#' library(yaml)
#' 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(as.yaml(yaml))
md_header <- function(x) {
  paste0("---\n", x, "---\n")
}

#' Convert `yaml` representation of a boolean strings to logical Values
#'
#' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`.
#'
#' @param input (`character(1)`)
#' @param name (`charcter(1)`)
#' @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(1)`) 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
  }
}

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

#' Get document output arguments from the `rmarkdown` package
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Retrieves the arguments for a specified document output type from the `rmarkdown` package.
#'
#' @param output_name (`character`) `rmarkdown` output name.
#' @param default_values (`logical(1)`) 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]]))
  }
}

#' Parse a named list to `yaml` header for an `Rmd` file
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments
#' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers.
#'
#' @details
#' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document.
#' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`,
#'  `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`.
#' Additionally,  it handles `output` field types and arguments as defined in the `rmarkdown` package.
#'
#' @note Only non-nested lists are automatically parsed.
#' Nested lists require direct processing with `yaml::as.yaml`.
#'
#' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header.
#' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`.
#' @param convert_logi (`logical(1)`) convert a character values to logical,
#'  if they are recognized as quoted `yaml` logical values , default `TRUE`.
#' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`.
#' @param silent (`logical(1)`) 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")
}

#' Print method for the `yaml_header` class
#'
#' `r lifecycle::badge("experimental")`
#'
#' @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, ...)
}

#' Extract field from `yaml` text
#'
#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
#' otherwise, the field itself.
#'
#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text.
#' @param field_name (`character`) 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
}

#' @title `Renderer`
#' @docType class
#' @description
#' A class for rendering reports from `ContentBlock` into various formats using `rmarkdown`.
#' It supports `TextBlock`, `PictureBlock`, `RcodeBlock`, `NewpageBlock`, and `TableBlock`.
#'
#' @keywords internal
Renderer <- R6::R6Class( # nolint: object_name_linter.
  classname = "Renderer",
  public = list(
    #' @description Initialize a `Renderer` object.
    #'
    #' @details Creates a new instance of `Renderer`
    #' with a temporary directory for storing report files.
    #'
    #' @return Object of class `Renderer`, invisibly.
    #' @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 `TextBlock`, `PictureBlock` and `NewpageBlock` objects.
    #' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
    #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
    #'  for customizing the rendering process.
    #' @details `r global_knitr_details()`
    #'
    #' @return Character vector constituting `rmarkdown` text (`yaml` header + body), ready to be rendered.
    #' @examples
    #' library(yaml)
    #' library(rtables)
    #' library(ggplot2)
    #'
    #' 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(
    #'  ggplot(iris, aes(x = Petal.Length)) + 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 <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- 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(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 `Report` to the desired output format by compiling the `rmarkdown` file.
    #'
    #' @param blocks (`list`) of `TextBlock`, `PictureBlock` or `NewpageBlock` objects.
    #' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
    #' @param global_knitr (`list`) 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
    #' library(yaml)
    #' library(ggplot2)
    #'
    #' 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(
    #'  ggplot(iris, aes(x = Petal.Length)) + 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 <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- 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(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
)

#' 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
#'
#' `r lifecycle::badge("experimental")`
#'
#' @param title (`character`) title of panel
#' @param ... content of panel
#' @param collapsed (`logical`, optional)
#'  whether to initially collapse panel
#' @param input_id (`character`, optional)
#'  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`
#'
#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
#'
#' Function merges cells with `colspan` > 1,
#' aligns columns to the center and row names to the left,
#' indents 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)
}

#' Divide text block into smaller blocks
#'
#' Split a text block into smaller blocks with a specified number of lines.
#'
#' 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"
  )
}

#' Reset report button module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Provides a button that triggers resetting the report content.
#'
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @name reset_report_button
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param label (`character(1)`) label before the icon.
#' By default `NULL`.
#' @param reporter (`Reporter`) instance.
#' @return `NULL`.
NULL

#' @rdname reset_report_button
#' @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")
      )
    )
  )
}

#' @rdname reset_report_button
#' @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 `TableBlock`
#' @docType class
#' @description
#' Specialized `FileBlock` for managing table content in reports.
#' It's designed to handle various table formats, converting them into a consistent,
#' document-ready format (e.g., `flextable`) for inclusion in reports.
#'
#' @keywords internal
TableBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TableBlock",
  inherit = FileBlock,
  public = list(
    #' @description Initialize a `TableBlock` object.
    #'
    #' @param table (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) a table assigned to
    #'   this `TableBlock`
    #'
    #' @return Object of class `TableBlock`, invisibly.
    initialize = function(table) {
      if (!missing(table)) {
        self$set_content(table)
      }
      invisible(self)
    },
    #' @description Sets content of this `TableBlock`.
    #'
    #' @details Raises error if argument is not a table-like object.
    #'
    #' @param content (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
    #' a table assigned to this `TableBlock`
    #'
    #' @return `self`, invisibly.
    #' @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
)

#' @title `ReportCard`: An `R6` class for building report elements
#' @docType class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This `R6` class that supports creating a report card containing text, plot, table and
#' metadata 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 Initialize a `ReportCard` object.
    #'
    #' @return Object of class `ReportCard`, invisibly.
    #' @examples
    #' card <- ReportCard$new()
    #'
    initialize = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Appends a table to this `ReportCard`.
    #'
    #' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
    #' that can be coerced into a table.
    #' @return `self`, invisibly.
    #' @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 (`ggplot` or `grob` or `trellis`) plot object.
    #' @param dim (`numeric(2)`) width and height in pixels.
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + 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 text paragraph to this `ReportCard`.
    #'
    #' @param text (`character`) The text content to add.
    #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
    #' @return `self`, invisibly.
    #' @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 `R` code chunk to `ReportCard`.
    #'
    #' @param text (`character`) The `R` code to include.
    #' @param ... Additional  `rmarkdown` parameters for formatting the `R` code chunk.
    #' @return `self`, invisibly.
    #' @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 generic `ContentBlock` to this `ReportCard`.
    #'
    #' @param content (`ContentBlock`) object.
    #' @return `self`, invisibly.
    #' @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 Get all content blocks from 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 Clears all content and metadata from `ReportCard`.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Get the metadata associated with `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)`) string specifying the metadata key.
    #' @param value value associated with the metadata key.
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + 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 name of the `ReportCard`.
    #'
    #' @return `character` a card name.
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    get_name = function() {
      private$name
    },
    #' @description Set the name of the `ReportCard`.
    #'
    #' @param name (`character(1)`) a card name.
    #' @return `self`, invisibly.
    #' @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, including content and metadata.
    #' @param output_dir (`character`) with a path to the directory where files will be copied.
    #' @return (`named list`) a `ReportCard` representation.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + 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 Reconstructs the `ReportCard` from a list representation.
    #' @param card (`named list`) a `ReportCard` representation.
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + 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`: A building block for report content
#' @docType class
#' @description This class represents a basic content unit in a report,
#' such as text, images, or other multimedia elements.
#' It serves as a foundation for constructing complex report structures.
#'
#' @keywords internal
ContentBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "ContentBlock",
  public = list(
    #' @description Initialize a `ContentBlock` object.
    #'
    #' @details Returns a `ContentBlock` object with no content and the default style.
    #'
    #' @return Object of class `ContentBlock`, invisibly.
    #' @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)`) string or file path assigned to this `ContentBlock`
    #'
    #' @return `self`, invisibly.
    #' @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 Retrieves the content assigned to this block.
    #'
    #' @return `character` string or file path assigned to 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 `text` and `style`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return `self`, invisibly.
    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 `Archiver`: Base class for data archiving
#' @docType class
#' @description
#' A base `R6` class for implementing data archiving functionality.
#'
#' @keywords internal
Archiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "Archiver",
  public = list(
    #' @description Initialize an `Archiver` object.
    #'
    #' @return Object of class `Archiver`, invisibly.
    #' @examples
    #' Archiver <- getFromNamespace("Archiver", "teal.reporter")
    #' Archiver$new()
    initialize = function() {
      invisible(self)
    },
    #' @description Finalizes an `Archiver` object.
    finalize = function() {
      # destructor
    },
    #' @description Reads data from the `Archiver`.
    #' Pure virtual method that should be implemented by inherited classes.
    read = function() {
      # returns Reporter instance
      stop("Pure virtual method.")
    },
    #' @description Writes data to the `Archiver`.
    #' Pure virtual method that should be implemented by inherited classes.
    write = function() {
      stop("Pure virtual method.")
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `FileArchiver`: A File-based `Archiver`
#' @docType class
#' @description
#' Inherits from `Archiver` to provide file-based archiving functionality.
#' Manages an output directory for storing archived data.
#'
#' @keywords internal
FileArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileArchiver",
  inherit = Archiver,
  public = list(
    #' @description Initialize a `FileArchiver` object with a unique output directory.
    #'
    #' @return Object of class `FileArchiver`, invisibly.
    #' @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.
    #' Cleans up by removing the output directory and its contents.
    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`: A `JSON`-based `Archiver`
#' @docType class
#' @description
#' Inherits from `FileArchiver` to implement `JSON`-based archiving functionality.
#' Convert `Reporter` instances to and from `JSON` format.
#'
#' @keywords internal
JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "JSONArchiver",
  inherit = FileArchiver,
  public = list(
    #' @description Write a `Reporter` instance in `JSON` file.
    #' Serializes a given `Reporter` instance and saves it in the `Archiver`'s output directory,
    #' to this `JSONArchiver` object.
    #'
    #' @param reporter (`Reporter`) instance.
    #'
    #' @return `self`.
    #' @examples
    #' library(ggplot2)
    #'
    #' 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(
    #'  ggplot(iris, aes(x = Petal.Length)) + 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 `JSON` file.
    #' Converts a `Reporter` instance from the `JSON` file in the `JSONArchiver`'s output directory.
    #'
    #' @param path (`character(1)`) a path to the directory with all proper files.
    #'
    #' @return `Reporter` instance.
    #' @examples
    #' library(ggplot2)
    #'
    #' 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(
    #'  ggplot(iris, aes(x = Petal.Length)) + 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 `Reporter`: An `R6` class for managing report cards
#' @docType class
#' @description `r lifecycle::badge("experimental")`
#'
#' This `R6` class is designed to store and manage report cards,
#' facilitating the creation, manipulation, and serialization of report-related data.
#'
#' @export
#'
Reporter <- R6::R6Class( # nolint: object_name_linter.
  classname = "Reporter",
  public = list(
    #' @description Initialize a `Reporter` object.
    #'
    #' @return Object of class `Reporter`, invisibly.
    #' @examples
    #' reporter <- Reporter$new()
    #'
    initialize = function() {
      private$cards <- list()
      private$reactive_add_card <- shiny::reactiveVal(0)
      invisible(self)
    },
    #' @description Append one or more `ReportCard` objects to the `Reporter`.
    #'
    #' @param cards (`ReportCard`) or a list of such objects
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' 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 Retrieves all `ReportCard` objects contained in the `Reporter`.
    #'
    #' @return A (`list`) of [`ReportCard`] objects.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      private$cards
    },
    #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`.
    #'
    #' @param sep An optional separator to insert between each content block.
    #' Default is a `NewpageBlock$new()`object.
    #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' 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 Resets the `Reporter`, removing all [`ReportCard`] objects and metadata.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$cards <- list()
      private$metadata <- list()
      private$reactive_add_card(0)
      invisible(self)
    },
    #' @description Removes specific `ReportCard` objects from the `Reporter` by their indices.
    #'
    #' @param ids (`integer(id)`) the indexes of cards
    #' @return `self`, invisibly.
    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 Swaps the positions of two `ReportCard` objects within the `Reporter`.
    #'
    #' @param start (`integer`) the index of the first card
    #' @param end (`integer`) the index of the second card
    #' @return `self`, invisibly.
    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 Gets the current value of the reactive variable for adding cards.
    #'
    #' @return `reactive_add_card` current `numeric` value of the reactive variable.
    #' @note The function has to be used in the shiny reactive context.
    #' @examples
    #' library(shiny)
    #'
    #' isolate(Reporter$new()$get_reactive_add_card())
    get_reactive_add_card = function() {
      private$reactive_add_card()
    },
    #' @description Get the metadata associated with this `Reporter`.
    #'
    #' @return `named list` of metadata to be appended.
    #' @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 (`named list`) of metadata to be appended.
    #' @return `self`, invisibly.
    #' @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
    #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
    #' @param reporter (`Reporter`) instance to copy from.
    #' @return `self`, invisibly.
    #' @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 any associated files to specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where files will be copied.
    #' @return `named list` representing the `Reporter` instance, including version information,
    #'  metadata, and report cards.
    #'
    #' @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 Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
    #' @param rlist (`named list`) representing a `Reporter` instance.
    #' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
    #' @return `self`, invisibly.
    #' @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 Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics.
    #' @return `output_dir` argument.
    #' @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 Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics.
    #' @return `self`, invisibly.
    #' @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
)

#' Report previewer module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Module offers functionalities to visualize, manipulate,
#' and interact with report cards that have been added to a report.
#' It includes a previewer interface to see the cards and options to modify the report before downloading.
#'
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#'
#' @details `r global_knitr_details()`
#'
#' @name reporter_previewer
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param reporter (`Reporter`) instance.
#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
#'  for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
NULL

#' @rdname reporter_previewer
#' @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"))
        )
      )
    )
  )
}

#' @rdname reporter_previewer
#' @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.")
          shinybusy::block(id = ns("download_data_prev"), text = "", type = "dots")
          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)
          shinybusy::unblock(id = ns("download_data_prev"))
        },
        contentType = "application/zip"
      )
    }
  )
}

#' @noRd
#' @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")
  }
}

#' @noRd
#' @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")))
    )
  )
}

#' @noRd
#' @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")))
    ))
  )
}

#' @noRd
#' @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))
  )
}

#' @noRd
#' @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)
  )
}

#' @noRd
#' @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)
                }
              )
            )
          )
        )
      )
    }
  })
}

#' Download report button module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Provides a button that triggers downloading a report.
#'
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details `r global_knitr_details()`
#'
#' @name download_report_button
#'
#' @param id (`character(1)`) this `shiny` module's id.
#' @param reporter (`Reporter`) instance.
#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
#'  for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
NULL

#' @rdname download_report_button
#' @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")
      )
    )
  )
}

#' @rdname download_report_button
#' @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.")
          shinybusy::block(id = ns("download_data"), text = "", type = "dots")
          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)
          shinybusy::unblock(id = ns("download_data"))
        },
        contentType = "application/zip"
      )
    }
  )
}

#' Render the report
#'
#' 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(1)`) 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 UI inputs
#'
#' @param rmd_output (`character`) vector with `rmarkdown` output types,
#' by default all possible `pdf_document`, `html_document`, `powerpoint_presentation`, and `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 UI 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
      )
    }
  )
}

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

#' Add card button module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Provides a button to add views/cards to a report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details
#' The `card_fun` function is designed to create a new `ReportCard` instance and optionally customize it:
#' - The `card` parameter allows for specifying a custom or default `ReportCard` instance.
#' - Use the `comment` parameter to add a comment to the card via `card$append_text()` - if `card_fun` does not
#' have the `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the
#' card.
#' - The `label` parameter enables customization of the card's name and its content through `card$append_text()`-
#' if `card_fun` does not have the `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`.
#'
#' This module supports using a subclass of [`ReportCard`] for added flexibility.
#' A subclass instance should be passed as the default value of
#' the `card` argument in the `card_fun` function.
#' See below:
#' ```{r}
#' CustomReportCard <- R6::R6Class(
#'   classname = "CustomReportCard",
#'   inherit = teal.reporter::ReportCard
#' )
#'
#' custom_function <- function(card = CustomReportCard$new()) {
#'   card
#' }
#' ```
#' @name add_card_button
#'
#' @param id (`character(1)`) this `shiny` module's id.
#' @param reporter (`Reporter`) instance.
#' @param card_fun (`function`) which returns a [`ReportCard`] instance. See `Details`.
#'
#' @return `NULL`.
NULL

#' @rdname add_card_button
#' @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")
      )
    )
  )
}

#' @rdname add_card_button
#' @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 `PictureBlock`
#' @docType class
#' @description
#' Specialized `FileBlock` for managing picture content in reports.
#' It's designed to handle plots from packages such as `ggplot2`, `grid`, or `lattice`.
#' It can save plots to files, set titles and specify dimensions.
#'
#' @keywords internal
PictureBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "PictureBlock",
  inherit = FileBlock,
  public = list(
    #' @description Initialize a `PictureBlock` object.
    #'
    #' @param plot (`ggplot` or `grid`) a picture in this `PictureBlock`
    #'
    #' @return Object of class `PictureBlock`, invisibly.
    initialize = function(plot) {
      if (!missing(plot)) {
        self$set_content(plot)
      }
      invisible(self)
    },
    #' @description Sets the content of this `PictureBlock`.
    #'
    #' @details Raises error if argument is not a `ggplot`, `grob` or `trellis` plot.
    #'
    #' @param content (`ggplot` or `grob` or `trellis`) a picture in this `PictureBlock`
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #' library(lattice)
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplot(iris))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(bwplot(1))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplotGrob(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 Raises error if argument is not `character(1)`.
    #'
    #' @param title (`character(1)`) a string assigned to this `PictureBlock`
    #'
    #' @return `self`, invisibly.
    #' @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 Get the title of this `PictureBlock`.
    #'
    #' @return The content of this `PictureBlock`.
    #' @examples
    #' 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(2)`) figure dimensions (width and height) in pixels.
    #'
    #' @return `self`, invisibly.
    #' @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 Get `PictureBlock` dimensions as a numeric vector.
    #'
    #' @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
)

#' Simple reporter module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Module provides compact UI and server functions for managing a report in a `shiny` app.
#' This module combines functionalities for [adding cards to a report][add_card_button],
#'  [downloading the report][download_report_button], and [resetting report content][reset_report_button].
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details `r global_knitr_details()`
#'
#' @name simple_reporter
#'
#' @param id (`character(1)`) `shiny` module instance 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
#'
#' @return `NULL`.
#'
#' @examples
#' library(shiny)
#' if (interactive()) {
#'   shinyApp(
#'     ui = fluidPage(simple_reporter_ui("simple")),
#'     server = function(input, output, session) {
#'       simple_reporter_srv("simple", Reporter$new(), function(card) card)
#'     }
#'   )
#' }
NULL

#' @rdname simple_reporter
#' @export
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"))
      )
    )
  )
}

#' @rdname simple_reporter
#' @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)
    }
  )
}

#' @title `NewpageBlock`
#' @docType class
#' @description
#' A `ContentBlock` subclass that represents a page break in a report output.
#'
#' @keywords internal
NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "NewpageBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Initialize a `NewpageBlock` object.
    #'
    #' @details Returns a `NewpageBlock` object with no content and the default style.
    #'
    #' @return Object of class `NewpageBlock`, invisibly.
    #' @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`
#' @docType class
#' @description
#' `FileBlock` manages file-based content in a report,
#'  ensuring appropriate handling of content files.
#'
#' @keywords internal
FileBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Finalize the `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 `self`, invisibly.
    #' @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
)

#' @title `TextBlock`
#' @docType class
#' @description
#' Specialized `ContentBlock` for embedding styled text within reports.
#' It supports multiple styling options to accommodate various text roles,
#' such as headers or verbatim text, in the report content.
#'
#' @keywords internal
TextBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TextBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Initialize a `TextBlock` object.
    #'
    #' @details Constructs a `TextBlock` object with no content and the default style.
    #'
    #' @param content (`character`) a string assigned to this `TextBlock`
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return Object of class `TextBlock`, invisibly.
    #' @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 `self`, invisibly.
    #' @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 Get 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 Get available 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 `text` and `style`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return `self`, invisibly.
    #' @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
)

.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."
    }
  )
}

1		#' @title `RcodeBlock`
2		#' @docType class
3		#' @description
4		#' Specialized `ContentBlock` designed to embed `R` code in reports.
5		#'
6		#' @keywords internal
7		RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
8		classname = "RcodeBlock",
9		inherit = ContentBlock,
10		public = list(
11		#' @description Initialize a `RcodeBlock` object.
12		#'
13		#' @details Returns a `RcodeBlock` object with no content and no parameters.
14		#'
15		#' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock`
16		#' @param ... any `rmarkdown` `R` chunk parameter and it value.
17		#'
18		#' @return Object of class `RcodeBlock`, invisibly.
19		#' @examples
20		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
21		#' block <- RcodeBlock$new()
22		#'
23		initialize = function(content = character(0), ...) {
24	74x	super$set_content(content)
25	74x	self$set_params(list(...))
26	74x	invisible(self)
27		},
28		#' @description Sets the parameters of this `RcodeBlock`.
29		#'
30		#' @details Configures `rmarkdown` chunk parameters for the `R` code block,
31		#' influencing its rendering and execution behavior.
32		#'
33		#' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
34		#'
35		#' @return `self`, invisibly.
36		#' @examples
37		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
38		#' block <- RcodeBlock$new()
39		#' block$set_params(list(echo = TRUE))
40		#'
41		set_params = function(params) {
42	132x	checkmate::assert_list(params, names = "named")
43	132x	checkmate::assert_subset(names(params), self$get_available_params())
44	132x	private$params <- params
45	132x	invisible(self)
46		},
47		#' @description Get the parameters of this `RcodeBlock`.
48		#'
49		#' @return `character` the parameters of this `RcodeBlock`.
50		#' @examples
51		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
52		#' block <- RcodeBlock$new()
53		#' block$get_params()
54		#'
55		get_params = function() {
56	3x	private$params
57		},
58		#' @description Get available array of parameters available to this `RcodeBlock`.
59		#'
60		#' @return A `character` array of parameters.
61		#' @examples
62		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
63		#' block <- RcodeBlock$new()
64		#' block$get_available_params()
65		#'
66		get_available_params = function() {
67	5x	names(knitr::opts_chunk$get())
68		},
69		#' @description Create the `RcodeBlock` from a list.
70		#'
71		#' @param x (`named list`) with two fields `text` and `params`.
72		#' Use the `get_available_params` method to get all possible parameters.
73		#'
74		#' @return `self`, invisibly.
75		#' @examples
76		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
77		#' block <- RcodeBlock$new()
78		#' block$from_list(list(text = "sth", params = list()))
79		#'
80		from_list = function(x) {
81	3x	checkmate::assert_list(x)
82	3x	checkmate::assert_names(names(x), must.include = c("text", "params"))
83	3x	self$set_content(x$text)
84	3x	self$set_params(x$params)
85	3x	invisible(self)
86		},
87		#' @description Convert the `RcodeBlock` to a list.
88		#'
89		#' @return `named list` with a text and `params`.
90		#' @examples
91		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
92		#' block <- RcodeBlock$new()
93		#' block$to_list()
94		#'
95		to_list = function() {
96	3x	list(text = self$get_content(), params = self$get_params())
97		}
98		),
99		private = list(
100		params = list()
101		),
102		lock_objects = TRUE,
103		lock_class = TRUE
104		)

1		#' Mark strings for quotation in `yaml` serialization
2		#'
3		#' This function is designed for use with the `yaml` package to explicitly,
4		#' It adds an attribute to character strings, indicating that they should be serialized with double quotes.
5		#'
6		#' @param x (`character`)
7		#' @keywords internal
8		#' @examples
9		#' library(yaml)
10		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
11		#' yaml <- list(
12		#' author = yaml_quoted("NEST"),
13		#' title = yaml_quoted("Report"),
14		#' date = yaml_quoted("07/04/2019"),
15		#' output = list(pdf_document = list(keep_tex = TRUE))
16		#' )
17		#' as.yaml(yaml)
18		yaml_quoted <- function(x) {
19	2x	attr(x, "quoted") <- TRUE
20	2x	x
21		}
22
23		#' Create `markdown` header from `yaml` string
24		#'
25		#' This function wraps a `yaml`-formatted string in Markdown header delimiters.
26		#'
27		#' @param x (`character`) `yaml` formatted string.
28		#' @keywords internal
29		#' @examples
30		#' library(yaml)
31		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
32		#' yaml <- list(
33		#' author = yaml_quoted("NEST"),
34		#' title = yaml_quoted("Report"),
35		#' date = yaml_quoted("07/04/2019"),
36		#' output = list(pdf_document = list(keep_tex = TRUE))
37		#' )
38		#' md_header <- getFromNamespace("md_header", "teal.reporter")
39		#' md_header(as.yaml(yaml))
40		md_header <- function(x) {
41	14x	paste0("---\n", x, "---\n")
42		}
43
44		#' Convert `yaml` representation of a boolean strings to logical Values
45		#'
46		#' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`.
47		#'
48		#' @param input (`character(1)`)
49		#' @param name (`charcter(1)`)
50		#' @param pos_logi (`character`) vector of `yaml` values which should be treated as `TRUE`.
51		#' @param neg_logi (`character`) vector of `yaml` values which should be treated as `FALSE`.
52		#' @param silent (`logical(1)`) if to suppress the messages and warnings.
53		#' @return `input` argument or the appropriate `logical` value.
54		#' @keywords internal
55		#' @examples
56		#'
57		#' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter")
58		#' conv_str_logi("TRUE")
59		#' conv_str_logi("True")
60		#'
61		#' conv_str_logi("off")
62		#' conv_str_logi("n")
63		#'
64		#' conv_str_logi("sth")
65		conv_str_logi <- function(input,
66		name = "",
67		pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"),
68		neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"),
69		silent = TRUE) {
70	18x	checkmate::assert_string(input)
71	17x	checkmate::assert_string(name)
72	17x	checkmate::assert_character(pos_logi)
73	17x	checkmate::assert_character(neg_logi)
74	17x	checkmate::assert_flag(silent)
75
76	17x	all_logi <- c(pos_logi, neg_logi)
77	17x	if (input %in% all_logi) {
78	15x	if (isFALSE(silent)) {
79	!	message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
80		}
81	15x	input %in% pos_logi
82		} else {
83	2x	input
84		}
85		}
86
87		#' Get document output types from the `rmarkdown` package
88		#'
89		#' @description `r lifecycle::badge("experimental")`
90		#'
91		#' Retrieves vector of available document output types from the `rmarkdown` package,
92		#' such as `pdf_document`, `html_document`, etc.
93		#'
94		#' @return `character` vector.
95		#' @export
96		#' @examples
97		#' rmd_outputs()
98		rmd_outputs <- function() {
99	18x	rmarkdown_namespace <- asNamespace("rmarkdown")
100	18x	ls(rmarkdown_namespace)[grep("_document\|_presentation", ls(rmarkdown_namespace))]
101		}
102
103		#' Get document output arguments from the `rmarkdown` package
104		#'
105		#' @description `r lifecycle::badge("experimental")`
106		#'
107		#' Retrieves the arguments for a specified document output type from the `rmarkdown` package.
108		#'
109		#' @param output_name (`character`) `rmarkdown` output name.
110		#' @param default_values (`logical(1)`) if to return a default values for each argument.
111		#' @export
112		#' @examples
113		#' rmd_output_arguments("pdf_document")
114		#' rmd_output_arguments("pdf_document", TRUE)
115		rmd_output_arguments <- function(output_name, default_values = FALSE) {
116	17x	checkmate::assert_string(output_name)
117	17x	checkmate::assert_subset(output_name, rmd_outputs())
118
119	16x	rmarkdown_namespace <- asNamespace("rmarkdown")
120	16x	if (default_values) {
121	14x	formals(rmarkdown_namespace[[output_name]])
122		} else {
123	2x	names(formals(rmarkdown_namespace[[output_name]]))
124		}
125		}
126
127		#' Parse a named list to `yaml` header for an `Rmd` file
128		#'
129		#' @description `r lifecycle::badge("experimental")`
130		#'
131		#' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments
132		#' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers.
133		#'
134		#' @details
135		#' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document.
136		#' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`,
137		#' `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`.
138		#' Additionally, it handles `output` field types and arguments as defined in the `rmarkdown` package.
139		#'
140		#' @note Only non-nested lists are automatically parsed.
141		#' Nested lists require direct processing with `yaml::as.yaml`.
142		#'
143		#' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header.
144		#' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`.
145		#' @param convert_logi (`logical(1)`) convert a character values to logical,
146		#' if they are recognized as quoted `yaml` logical values , default `TRUE`.
147		#' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`.
148		#' @param silent (`logical(1)`) suppress messages and warnings, default `FALSE`.
149		#' @return `character` with `rmd_yaml_header` class,
150		#' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`.
151		#' @export
152		#' @examples
153		#' # nested so using yaml::as.yaml directly
154		#' as_yaml_auto(
155		#' list(author = "", output = list(pdf_document = list(toc = TRUE)))
156		#' )
157		#'
158		#' # auto parsing for a flat list, like shiny input
159		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
160		#' as_yaml_auto(input)
161		#'
162		#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
163		#'
164		#' as_yaml_auto(list(
165		#' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
166		#' wrong = 2
167		#' ))
168		#'
169		#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
170		#' silent = TRUE
171		#' )
172		#'
173		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
174		#' as_yaml_auto(input)
175		#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
176		#' as_yaml_auto(input, silent = TRUE)
177		#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
178		#'
179		#' as_yaml_auto(
180		#' list(
181		#' author = "", output = "pdf_document",
182		#' output = "html_document", toc = TRUE, keep_tex = TRUE
183		#' ),
184		#' multi_output = TRUE
185		#' )
186		#' as_yaml_auto(
187		#' list(
188		#' author = "", output = "pdf_document",
189		#' output = "html_document", toc = "True", keep_tex = TRUE
190		#' ),
191		#' multi_output = TRUE
192		#' )
193		as_yaml_auto <- function(input_list,
194		as_header = TRUE,
195		convert_logi = TRUE,
196		multi_output = FALSE,
197		silent = FALSE) {
198	16x	checkmate::assert_logical(as_header)
199	16x	checkmate::assert_logical(convert_logi)
200	16x	checkmate::assert_logical(silent)
201	16x	checkmate::assert_logical(multi_output)
202
203	16x	if (multi_output) {
204	1x	checkmate::assert_list(input_list, names = "named")
205		} else {
206	15x	checkmate::assert_list(input_list, names = "unique")
207		}
208
209	13x	is_nested <- function(x) any(unlist(lapply(x, is.list)))
210	13x	if (is_nested(input_list)) {
211	2x	result <- input_list
212		} else {
213	11x	result <- list()
214	11x	input_nams <- names(input_list)
215
216		# top fields
217	11x	top_fields <- c(
218	11x	"author", "date", "title", "subtitle", "abstract",
219	11x	"keywords", "subject", "description", "category", "lang"
220		)
221	11x	for (itop in top_fields) {
222	110x	if (itop %in% input_nams) {
223	20x	result[[itop]] <- switch(itop,
224	20x	date = as.character(input_list[[itop]]),
225	20x	input_list[[itop]]
226		)
227		}
228		}
229
230		# output field
231	11x	doc_types <- unlist(input_list[input_nams == "output"])
232	11x	if (length(doc_types)) {
233	11x	for (dtype in doc_types) {
234	12x	doc_type_args <- rmd_output_arguments(dtype, TRUE)
235	12x	doc_type_args_nams <- names(doc_type_args)
236	12x	any_output_arg <- any(input_nams %in% doc_type_args_nams)
237
238	12x	not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
239	12x	if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
240	1x	warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
241		}
242
243	12x	if (any_output_arg) {
244	11x	doc_list <- list()
245	11x	doc_list[[dtype]] <- list()
246	11x	for (e in intersect(input_nams, doc_type_args_nams)) {
247	17x	if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
248	1x	pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
249	1x	neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
250	1x	all_logi <- c(pos_logi, neg_logi)
251	1x	if (input_list[[e]] %in% all_logi && convert_logi) {
252	1x	input_list[[e]] <- conv_str_logi(input_list[[e]], e,
253	1x	pos_logi = pos_logi,
254	1x	neg_logi = neg_logi, silent = silent
255		)
256		}
257		}
258
259	17x	doc_list[[dtype]][[e]] <- input_list[[e]]
260		}
261	11x	result[["output"]] <- append(result[["output"]], doc_list)
262		} else {
263	1x	result[["output"]] <- append(result[["output"]], input_list[["output"]])
264		}
265		}
266		}
267		}
268
269	13x	result <- yaml::as.yaml(result)
270	13x	if (as_header) {
271	12x	result <- md_header(result)
272		}
273	13x	structure(result, class = "rmd_yaml_header")
274		}
275
276		#' Print method for the `yaml_header` class
277		#'
278		#' `r lifecycle::badge("experimental")`
279		#'
280		#' @param x (`rmd_yaml_header`) class object.
281		#' @param ... optional text.
282		#' @return `NULL`.
283		#' @exportS3Method
284		#' @examples
285		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
286		#' out <- as_yaml_auto(input)
287		#' out
288		#' print(out)
289		print.rmd_yaml_header <- function(x, ...) {
290	!	cat(x, ...)
291		}
292
293		#' Extract field from `yaml` text
294		#'
295		#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
296		#' otherwise, the field itself.
297		#'
298		#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text.
299		#' @param field_name (`character`) the name of the field to extract.
300		#'
301		#' @return If the field is a list, it returns the names of elements in the list; otherwise,
302		#' it returns the extracted field.
303		#'
304		#' @keywords internal
305		get_yaml_field <- function(yaml_text, field_name) {
306	8x	checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
307	8x	checkmate::assert_string(field_name)
308
309	8x	yaml_obj <- yaml::yaml.load(yaml_text)
310
311	8x	result <- yaml_obj[[field_name]]
312	8x	if (is.list(result)) {
313	5x	result <- names(result)
314		}
315	8x	result
316		}

1		#' @title `Renderer`
2		#' @docType class
3		#' @description
4		#' A class for rendering reports from `ContentBlock` into various formats using `rmarkdown`.
5		#' It supports `TextBlock`, `PictureBlock`, `RcodeBlock`, `NewpageBlock`, and `TableBlock`.
6		#'
7		#' @keywords internal
8		Renderer <- R6::R6Class( # nolint: object_name_linter.
9		classname = "Renderer",
10		public = list(
11		#' @description Initialize a `Renderer` object.
12		#'
13		#' @details Creates a new instance of `Renderer`
14		#' with a temporary directory for storing report files.
15		#'
16		#' @return Object of class `Renderer`, invisibly.
17		#' @examples
18		#' Renderer <- getFromNamespace("Renderer", "teal.reporter")
19		#' Renderer$new()
20		#'
21		initialize = function() {
22	10x	tmp_dir <- tempdir()
23	10x	output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
24	10x	dir.create(path = output_dir)
25	10x	private$output_dir <- output_dir
26	10x	invisible(self)
27		},
28		#' @description Finalizes a `Renderer` object.
29		finalize = function() {
30	10x	unlink(private$output_dir, recursive = TRUE)
31		},
32		#' @description Getting the `Rmd` text which could be easily rendered later.
33		#'
34		#' @param blocks (`list`) of `TextBlock`, `PictureBlock` and `NewpageBlock` objects.
35		#' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
36		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
37		#' for customizing the rendering process.
38		#' @details `r global_knitr_details()`
39		#'
40		#' @return Character vector constituting `rmarkdown` text (`yaml` header + body), ready to be rendered.
41		#' @examples
42		#' library(yaml)
43		#' library(rtables)
44		#' library(ggplot2)
45		#'
46		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
47		#' card1 <- ReportCard$new()
48		#'
49		#' card1$append_text("Header 2 text", "header2")
50		#' card1$append_text("A paragraph of default text")
51		#' card1$append_plot(
52		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
53		#' )
54		#'
55		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
56		#' card2 <- ReportCard$new()
57		#'
58		#' card2$append_text("Header 2 text", "header2")
59		#' card2$append_text("A paragraph of default text", "header2")
60		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
61		#' table_res2 <- build_table(lyt, airquality)
62		#' card2$append_table(table_res2)
63		#' card2$append_table(iris)
64		#' card2$append_rcode("2+2", echo = FALSE)
65		#'
66		#' Reporter <- getFromNamespace("Reporter", "teal.reporter")
67		#' reporter <- Reporter$new()
68		#' reporter$append_cards(list(card1, card2))
69		#'
70		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
71		#' yaml_l <- list(
72		#' author = yaml_quoted("NEST"),
73		#' title = yaml_quoted("Report"),
74		#' date = yaml_quoted("07/04/2019"),
75		#' output = list(html_document = list(toc = FALSE))
76		#' )
77		#'
78		#' md_header <- getFromNamespace("md_header", "teal.reporter")
79		#' yaml_header <- md_header(as.yaml(yaml_l))
80		#' Renderer <- getFromNamespace("Renderer", "teal.reporter")
81		#' result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
82		#'
83		renderRmd = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr")) {
84	8x	checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
85	7x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
86
87	7x	if (missing(yaml_header)) {
88	2x	yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
89		}
90
91	7x	private$report_type <- get_yaml_field(yaml_header, "output")
92
93	7x	parsed_global_knitr <- sprintf(
94	7x	"\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n%s\n```\n",
95	7x	capture.output(dput(global_knitr)),
96	7x	if (identical(private$report_type, "powerpoint_presentation")) {
97	!	format_code_block_function <- quote(
98	!	code_block <- function(code_text) {
99	!	df <- data.frame(code_text)
100	!	ft <- flextable::flextable(df)
101	!	ft <- flextable::delete_part(ft, part = "header")
102	!	ft <- flextable::autofit(ft, add_h = 0)
103	!	ft <- flextable::fontsize(ft, size = 7, part = "body")
104	!	ft <- flextable::bg(x = ft, bg = "lightgrey")
105	!	ft <- flextable::border_outer(ft)
106	!	if (flextable::flextable_dim(ft)$widths > 8) {
107	!	ft <- flextable::width(ft, width = 8)
108		}
109	!	ft
110		}
111		)
112	!	paste(deparse(format_code_block_function), collapse = "\n")
113		} else {
114		""
115		}
116		)
117
118	7x	parsed_blocks <- paste(
119	7x	unlist(
120	7x	lapply(blocks, function(b) private$block2md(b))
121		),
122	7x	collapse = "\n\n"
123		)
124
125	7x	rmd_text <- paste0(yaml_header, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
126	7x	tmp <- tempfile(fileext = ".Rmd")
127	7x	input_path <- file.path(
128	7x	private$output_dir,
129	7x	sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
130		)
131	7x	cat(rmd_text, file = input_path)
132	7x	input_path
133		},
134		#' @description Renders the `Report` to the desired output format by compiling the `rmarkdown` file.
135		#'
136		#' @param blocks (`list`) of `TextBlock`, `PictureBlock` or `NewpageBlock` objects.
137		#' @param yaml_header (`character`) an `rmarkdown` `yaml` header.
138		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
139		#' for customizing the rendering process.
140		#' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
141		#' @details `r global_knitr_details()`
142		#'
143		#' @return `character` path to the output.
144		#' @examples
145		#' library(yaml)
146		#' library(ggplot2)
147		#'
148		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
149		#' card1 <- ReportCard$new()
150		#'
151		#' card1$append_text("Header 2 text", "header2")
152		#' card1$append_text("A paragraph of default text")
153		#' card1$append_plot(
154		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
155		#' )
156		#'
157		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
158		#' card2 <- ReportCard$new()
159		#'
160		#' card2$append_text("Header 2 text", "header2")
161		#' card2$append_text("A paragraph of default text", "header2")
162		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
163		#' table_res2 <- build_table(lyt, airquality)
164		#' card2$append_table(table_res2)
165		#' card2$append_table(iris)
166		#' card2$append_rcode("2+2", echo = FALSE)
167		#' Reporter <- getFromNamespace("Reporter", "teal.reporter")$new()
168		#' Reporter$append_cards(list(card1, card2))
169		#'
170		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
171		#' yaml_l <- list(
172		#' author = yaml_quoted("NEST"),
173		#' title = yaml_quoted("Report"),
174		#' date = yaml_quoted("07/04/2019"),
175		#' output = list(html_document = list(toc = FALSE))
176		#' )
177		#'
178		#' md_header <- getFromNamespace("md_header", "teal.reporter")
179		#' yaml_header <- md_header(as.yaml(yaml_l))
180		#' Renderer <- getFromNamespace("Renderer", "teal.reporter")
181		#' result_path <- Renderer$new()$render(Reporter$get_blocks(), yaml_header)
182		#'
183		render = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
184	6x	args <- list(...)
185	6x	input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
186	6x	args <- append(args, list(
187	6x	input = input_path,
188	6x	output_dir = private$output_dir,
189	6x	output_format = "all",
190	6x	quiet = TRUE
191		))
192	6x	args_nams <- unique(names(args))
193	6x	args <- lapply(args_nams, function(x) args[[x]])
194	6x	names(args) <- args_nams
195	6x	do.call(rmarkdown::render, args)
196		},
197		#' @description Get `output_dir` field.
198		#'
199		#' @return `character` a `output_dir` field path.
200		#' @examples
201		#' Renderer <- getFromNamespace("Renderer", "teal.reporter")$new()
202		#' Renderer$get_output_dir()
203		#'
204		get_output_dir = function() {
205	7x	private$output_dir
206		}
207		),
208		private = list(
209		output_dir = character(0),
210		report_type = NULL,
211		# factory method
212		block2md = function(block) {
213	25x	if (inherits(block, "TextBlock")) {
214	14x	private$textBlock2md(block)
215	11x	} else if (inherits(block, "RcodeBlock")) {
216	!	private$rcodeBlock2md(block)
217	11x	} else if (inherits(block, "PictureBlock")) {
218	7x	private$pictureBlock2md(block)
219	4x	} else if (inherits(block, "TableBlock")) {
220	2x	private$tableBlock2md(block)
221	2x	} else if (inherits(block, "NewpageBlock")) {
222	2x	block$get_content()
223		} else {
224	!	stop("Unknown block class")
225		}
226		},
227		# card specific methods
228		textBlock2md = function(block) {
229	14x	text_style <- block$get_style()
230	14x	block_content <- block$get_content()
231	14x	switch(text_style,
232	2x	"default" = block_content,
233	!	"verbatim" = sprintf("\n```\n%s\n```\n", block_content),
234	12x	"header2" = paste0("## ", block_content),
235	!	"header3" = paste0("### ", block_content),
236	!	block_content
237		)
238		},
239		rcodeBlock2md = function(block) {
240	!	params <- block$get_params()
241	!	params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
242	!	if (identical(private$report_type, "powerpoint_presentation")) {
243	!	block_content_list <- split_text_block(block$get_content(), 30)
244	!	paste(
245	!	sprintf(
246	!	"\\newpage\n\n---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
247	!	shQuote(block_content_list, type = "cmd")
248		),
249	!	collapse = "\n\n"
250		)
251		} else {
252	!	sprintf(
253	!	"\\newpage\n\n--- \n\n```{r, %s}\n%s\n```\n",
254	!	paste(names(params), params, sep = "=", collapse = ", "),
255	!	block$get_content()
256		)
257		}
258		},
259		pictureBlock2md = function(block) {
260	7x	basename_pic <- basename(block$get_content())
261	7x	file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
262	7x	params <- c(
263	7x	`out.width` = "'100%'",
264	7x	`out.height` = "'100%'"
265		)
266	7x	title <- block$get_title()
267	7x	if (length(title)) params["fig.cap"] <- shQuote(title)
268	7x	sprintf(
269	7x	"\n```{r, echo = FALSE, %s}\nknitr::include_graphics(path = '%s')\n```\n",
270	7x	paste(names(params), params, sep = "=", collapse = ", "),
271	7x	basename_pic
272		)
273		},
274		tableBlock2md = function(block) {
275	2x	basename_table <- basename(block$get_content())
276	2x	file.copy(block$get_content(), file.path(private$output_dir, basename_table))
277	2x	sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
278		}
279		),
280		lock_objects = TRUE,
281		lock_class = TRUE
282		)

1		#' 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		#'
15		#' `r lifecycle::badge("experimental")`
16		#'
17		#' @param title (`character`) title of panel
18		#' @param ... content of panel
19		#' @param collapsed (`logical`, optional)
20		#' whether to initially collapse panel
21		#' @param input_id (`character`, optional)
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`
114		#'
115		#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
116		#'
117		#' Function merges cells with `colspan` > 1,
118		#' aligns columns to the center and row names to the left,
119		#' indents the row names by 10 times indentation.
120		#'
121		#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
122		#'
123		#' @return `flextable`.
124		#'
125		#' @keywords internal
126		to_flextable <- function(content) {
127	16x	if (inherits(content, c("rtables", "TableTree", "ElementaryTable", "listing_df"))) {
128	3x	mf <- rtables::matrix_form(content)
129	3x	nr_header <- attr(mf, "nrow_header")
130	3x	non_total_coln <- c(TRUE, !grepl("All Patients", names(content)))
131	3x	df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
132	3x	header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
133
134	3x	ft <- flextable::flextable(df)
135	3x	ft <- flextable::delete_part(ft, part = "header")
136	3x	ft <- flextable::add_header(ft, values = header_df)
137
138		# Add titles
139	3x	ft <- flextable::set_caption(ft, flextable::as_paragraph(
140	3x	flextable::as_b(mf$main_title), "\n", paste(mf$subtitles, collapse = "\n")
141		),
142	3x	align_with_table = FALSE
143		)
144
145	3x	merge_index_body <- get_merge_index(mf$spans[seq(nr_header + 1, nrow(mf$spans)), , drop = FALSE])
146	3x	merge_index_header <- get_merge_index(mf$spans[seq_len(nr_header), , drop = FALSE])
147
148	3x	ft <- merge_at_indice(ft, lst = merge_index_body, part = "body")
149	3x	ft <- merge_at_indice(ft, lst = merge_index_header, part = "header")
150	3x	ft <- flextable::align_text_col(ft, align = "center", header = TRUE)
151	3x	ft <- flextable::align(ft, i = seq_len(nrow(content)), j = 1, align = "left")
152	3x	ft <- padding_lst(ft, mf$row_info$indent)
153	3x	ft <- flextable::padding(ft, padding.top = 1, padding.bottom = 1, part = "all")
154	3x	ft <- flextable::autofit(ft, add_h = 0)
155
156	3x	width_vector <- c(
157	3x	dim(ft)$widths[1],
158	3x	rep(sum(dim(ft)$widths[-1]), length(dim(ft)$widths) - 1) / (ncol(mf$strings) - 1)
159		)
160	3x	ft <- flextable::width(ft, width = width_vector)
161	3x	ft <- custom_theme(ft)
162
163		# Add footers
164	3x	ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
165	3x	flextable::as_chunk(mf$main_footer, props = flextable::fp_text_default(font.size = 8))
166		))
167	!	if (length(mf$main_footer) > 0 && length(mf$prov_footer) > 0) ft <- flextable::add_footer_lines(ft, c("\n"))
168	3x	ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
169	3x	flextable::as_chunk(mf$prov_footer, props = flextable::fp_text_default(font.size = 8))
170		))
171	13x	} else if (inherits(content, "data.frame")) {
172	12x	ft <- flextable::flextable(content)
173	12x	ft <- custom_theme(ft)
174		} else {
175	1x	stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
176		}
177
178	15x	if (flextable::flextable_dim(ft)$widths > 10) {
179	!	pgwidth <- 10.5
180	!	width_vector <- dim(ft)$widths * pgwidth / flextable::flextable_dim(ft)$widths
181	!	ft <- flextable::width(ft, width = width_vector)
182		}
183
184	15x	ft
185		}
186
187		#' Apply a custom theme to a `flextable`
188		#' @noRd
189		#' @keywords internal
190		custom_theme <- function(ft) {
191	16x	checkmate::assert_class(ft, "flextable")
192	16x	ft <- flextable::fontsize(ft, size = 8, part = "body")
193	16x	ft <- flextable::bold(ft, part = "header")
194	16x	ft <- flextable::theme_booktabs(ft)
195	16x	ft <- flextable::hline(ft, border = flextable::fp_border_default(width = 1, color = "grey"))
196	16x	ft <- flextable::border_outer(ft)
197	16x	ft
198		}
199
200		#' Get the merge index for a single span.
201		#' This function retrieves the merge index for a single span,
202		#' which is used in merging cells.
203		#' @noRd
204		#' @keywords internal
205		get_merge_index_single <- function(span) {
206	134x	ret <- list()
207	134x	j <- 1
208	134x	while (j < length(span)) {
209	141x	if (span[j] != 1) {
210	3x	ret <- c(ret, list(seq(j, j + span[j] - 1)))
211		}
212	141x	j <- j + span[j]
213		}
214	134x	return(ret)
215		}
216
217		#' Get the merge index for multiple spans.
218		#' This function merges cells in a `flextable` at specified row and column indices.
219		#' @noRd
220		#' @keywords internal
221		get_merge_index <- function(spans) {
222	7x	ret <- lapply(seq_len(nrow(spans)), function(i) {
223	133x	ri <- spans[i, ]
224	133x	r <- get_merge_index_single(ri)
225	133x	lapply(r, function(s) {
226	2x	list(j = s, i = i)
227		})
228		})
229	7x	unlist(ret, recursive = FALSE, use.names = FALSE)
230		}
231
232		#' Merge cells in a `flextable` at specified indices
233		#' @noRd
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		#' @keywords internal
245		padding_lst <- function(ft, indents) {
246	4x	Reduce(function(ft, s) {
247	131x	flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
248	4x	}, seq_len(length(indents)), ft)
249		}
250
251		#' Divide text block into smaller blocks
252		#'
253		#' Split a text block into smaller blocks with a specified number of lines.
254		#'
255		#' A single character string containing a text block of multiple lines (separated by `\n`)
256		#' is split into multiple strings with n or less lines each.
257		#'
258		#' @param x (`character`) string containing the input block of text
259		#' @param n (`integer`) number of lines per block
260		#'
261		#' @return
262		#' List of character strings with up to `n` lines in each element.
263		#'
264		#' @keywords internal
265		split_text_block <- function(x, n) {
266	2x	checkmate::assert_string(x)
267	2x	checkmate::assert_integerish(n, lower = 1L, len = 1L)
268
269	2x	lines <- strsplit(x, "\n")[[1]]
270
271	2x	if (length(lines) <= n) {
272	1x	return(list(x))
273		}
274
275	1x	nblocks <- ceiling(length(lines) / n)
276	1x	ind <- rep(1:nblocks, each = n)[seq_along(lines)]
277	1x	unname(lapply(split(lines, ind), paste, collapse = "\n"))
278		}
279
280		#' Retrieve text details for global_knitr options
281		#' This function returns a character string describing the default settings for the global_knitr options.
282		#' @noRd
283		#' @keywords internal
284		global_knitr_details <- function() {
285	!	paste0(
286	!	c(
287	!	" To access the default values for the `global_knitr` parameter,",
288	!	" use `getOption('teal.reporter.global_knitr')`. These defaults include:",
289	!	" - `echo = TRUE`",
290	!	" - `tidy.opts = list(width.cutoff = 60)`",
291	!	" - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise"
292		),
293	!	collapse = "\n"
294		)
295		}

1		#' Reset report button module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Provides a button that triggers resetting the report content.
6		#'
7		#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
8		#'
9		#' @name reset_report_button
10		#'
11		#' @param id (`character(1)`) `shiny` module instance id.
12		#' @param label (`character(1)`) label before the icon.
13		#' By default `NULL`.
14		#' @param reporter (`Reporter`) instance.
15		#' @return `NULL`.
16		NULL
17
18		#' @rdname reset_report_button
19		#' @export
20		reset_report_button_ui <- function(id, label = NULL) {
21	8x	checkmate::assert_string(label, null.ok = TRUE)
22
23	8x	ns <- shiny::NS(id)
24	8x	shiny::tagList(
25	8x	shiny::singleton(
26	8x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
27		),
28	8x	shiny::tags$button(
29	8x	id = ns("reset_reporter"),
30	8x	type = "button",
31	8x	class = "simple_report_button btn btn-warning action-button",
32	8x	title = "Reset",
33	8x	`data-val` = shiny::restoreInput(id = ns("reset_reporter"), default = NULL),
34	8x	NULL,
35	8x	shiny::tags$span(
36	8x	if (!is.null(label)) label,
37	8x	shiny::icon("xmark")
38		)
39		)
40		)
41		}
42
43		#' @rdname reset_report_button
44		#' @export
45		reset_report_button_srv <- function(id, reporter) {
46	12x	checkmate::assert_class(reporter, "Reporter")
47
48	12x	shiny::moduleServer(
49	12x	id,
50	12x	function(input, output, session) {
51	12x	ns <- session$ns
52	12x	nr_cards <- length(reporter$get_cards())
53
54
55	12x	shiny::observeEvent(input$reset_reporter, {
56	1x	shiny::showModal(
57	1x	shiny::modalDialog(
58	1x	shiny::tags$h3("Reset the Report"),
59	1x	shiny::tags$hr(),
60	1x	shiny::tags$strong(
61	1x	shiny::tags$p(
62	1x	"Are you sure you want to reset the report? (This will remove ALL previously added cards)."
63		)
64		),
65	1x	footer = shiny::tagList(
66	1x	shiny::tags$button(
67	1x	type = "button",
68	1x	class = "btn btn-secondary",
69	1x	`data-dismiss` = "modal",
70	1x	`data-bs-dismiss` = "modal",
71	1x	NULL,
72	1x	"Cancel"
73		),
74	1x	shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn-danger")
75		)
76		)
77		)
78		})
79
80	12x	shiny::observeEvent(input$reset_reporter_ok, {
81	1x	reporter$reset()
82	1x	shiny::removeModal()
83		})
84		}
85		)
86		}

1		#' @title `TableBlock`
2		#' @docType class
3		#' @description
4		#' Specialized `FileBlock` for managing table content in reports.
5		#' It's designed to handle various table formats, converting them into a consistent,
6		#' document-ready format (e.g., `flextable`) for inclusion in reports.
7		#'
8		#' @keywords internal
9		TableBlock <- R6::R6Class( # nolint: object_name_linter.
10		classname = "TableBlock",
11		inherit = FileBlock,
12		public = list(
13		#' @description Initialize a `TableBlock` object.
14		#'
15		#' @param table (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) a table assigned to
16		#' this `TableBlock`
17		#'
18		#' @return Object of class `TableBlock`, invisibly.
19		initialize = function(table) {
20	36x	if (!missing(table)) {
21	6x	self$set_content(table)
22		}
23	36x	invisible(self)
24		},
25		#' @description Sets content of this `TableBlock`.
26		#'
27		#' @details Raises error if argument is not a table-like object.
28		#'
29		#' @param content (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
30		#' a table assigned to this `TableBlock`
31		#'
32		#' @return `self`, invisibly.
33		#' @examples
34		#' TableBlock <- getFromNamespace("TableBlock", "teal.reporter")
35		#' block <- TableBlock$new()
36		#' block$set_content(iris)
37		#'
38		set_content = function(content) {
39	15x	checkmate::assert_multi_class(content, private$supported_tables)
40	14x	content <- to_flextable(content)
41	14x	path <- tempfile(fileext = ".rds")
42	14x	saveRDS(content, file = path)
43	14x	super$set_content(path)
44	14x	invisible(self)
45		}
46		),
47		private = list(
48		supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df")
49		),
50		lock_objects = TRUE,
51		lock_class = TRUE
52		)

1		#' @title `ReportCard`: An `R6` class for building report elements
2		#' @docType class
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' This `R6` class that supports creating a report card containing text, plot, table and
7		#' metadata blocks that can be appended and rendered to form a report output from a `shiny` app.
8		#'
9		#' @export
10		#'
11		ReportCard <- R6::R6Class( # nolint: object_name_linter.
12		classname = "ReportCard",
13		public = list(
14		#' @description Initialize a `ReportCard` object.
15		#'
16		#' @return Object of class `ReportCard`, invisibly.
17		#' @examples
18		#' card <- ReportCard$new()
19		#'
20		initialize = function() {
21	77x	private$content <- list()
22	77x	private$metadata <- list()
23	77x	invisible(self)
24		},
25		#' @description Appends a table to this `ReportCard`.
26		#'
27		#' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
28		#' that can be coerced into a table.
29		#' @return `self`, invisibly.
30		#' @examples
31		#' card <- ReportCard$new()$append_table(iris)
32		#'
33		append_table = function(table) {
34	6x	self$append_content(TableBlock$new(table))
35	6x	invisible(self)
36		},
37		#' @description Appends a plot to this `ReportCard`.
38		#'
39		#' @param plot (`ggplot` or `grob` or `trellis`) plot object.
40		#' @param dim (`numeric(2)`) width and height in pixels.
41		#' @return `self`, invisibly.
42		#' @examples
43		#' library(ggplot2)
44		#'
45		#' card <- ReportCard$new()$append_plot(
46		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
47		#' )
48		#'
49		append_plot = function(plot, dim = NULL) {
50	19x	pb <- PictureBlock$new()
51	19x	if (!is.null(dim) && length(dim) == 2) {
52	1x	pb$set_dim(dim)
53		}
54	19x	pb$set_content(plot)
55	19x	self$append_content(pb)
56	19x	invisible(self)
57		},
58		#' @description Appends a text paragraph to this `ReportCard`.
59		#'
60		#' @param text (`character`) The text content to add.
61		#' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
62		#' @return `self`, invisibly.
63		#' @examples
64		#' card <- ReportCard$new()$append_text("A paragraph of default text")
65		#'
66		append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
67	52x	self$append_content(TextBlock$new(text, style))
68	52x	invisible(self)
69		},
70		#' @description Appends an `R` code chunk to `ReportCard`.
71		#'
72		#' @param text (`character`) The `R` code to include.
73		#' @param ... Additional `rmarkdown` parameters for formatting the `R` code chunk.
74		#' @return `self`, invisibly.
75		#' @examples
76		#' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
77		#'
78		append_rcode = function(text, ...) {
79	4x	self$append_content(RcodeBlock$new(text, ...))
80	4x	invisible(self)
81		},
82		#' @description Appends a generic `ContentBlock` to this `ReportCard`.
83		#'
84		#' @param content (`ContentBlock`) object.
85		#' @return `self`, invisibly.
86		#' @examples
87		#' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
88		#' card <- ReportCard$new()$append_content(NewpageBlock$new())
89		#'
90		append_content = function(content) {
91	141x	checkmate::assert_class(content, "ContentBlock")
92	141x	private$content <- append(private$content, content)
93	141x	invisible(self)
94		},
95		#' @description Get all content blocks from this `ReportCard`.
96		#'
97		#' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
98		#' @examples
99		#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
100		#'
101		#' card$get_content()
102		#'
103		#'
104		get_content = function() {
105	85x	private$content
106		},
107		#' @description Clears all content and metadata from `ReportCard`.
108		#'
109		#' @return `self`, invisibly.
110		#'
111		reset = function() {
112	17x	private$content <- list()
113	17x	private$metadata <- list()
114	17x	invisible(self)
115		},
116		#' @description Get the metadata associated with `ReportCard`.
117		#'
118		#' @return `named list` list of elements.
119		#' @examples
120		#' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
121		#'
122		#' card$get_metadata()
123		#'
124		get_metadata = function() {
125	11x	private$metadata
126		},
127		#' @description Appends metadata to this `ReportCard`.
128		#'
129		#' @param key (`character(1)`) string specifying the metadata key.
130		#' @param value value associated with the metadata key.
131		#' @return `self`, invisibly.
132		#' @examples
133		#' library(ggplot2)
134		#'
135		#' card <- ReportCard$new()$append_text("Some text")$append_plot(
136		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
137		#' )$append_text("Some text")$append_metadata(key = "lm",
138		#' value = lm(Ozone ~ Solar.R, airquality))
139		#' card$get_content()
140		#' card$get_metadata()
141		#'
142		append_metadata = function(key, value) {
143	16x	checkmate::assert_character(key, min.len = 0, max.len = 1)
144	13x	checkmate::assert_false(key %in% names(private$metadata))
145	12x	meta_list <- list()
146	12x	meta_list[[key]] <- value
147	11x	private$metadata <- append(private$metadata, meta_list)
148	11x	invisible(self)
149		},
150		#' @description Get the name of the `ReportCard`.
151		#'
152		#' @return `character` a card name.
153		#' @examples
154		#' ReportCard$new()$set_name("NAME")$get_name()
155		get_name = function() {
156	16x	private$name
157		},
158		#' @description Set the name of the `ReportCard`.
159		#'
160		#' @param name (`character(1)`) a card name.
161		#' @return `self`, invisibly.
162		#' @examples
163		#' ReportCard$new()$set_name("NAME")$get_name()
164		set_name = function(name) {
165	1x	checkmate::assert_string(name)
166	1x	private$name <- name
167	1x	invisible(self)
168		},
169		#' @description Convert the `ReportCard` to a list, including content and metadata.
170		#' @param output_dir (`character`) with a path to the directory where files will be copied.
171		#' @return (`named list`) a `ReportCard` representation.
172		#' @examples
173		#' library(ggplot2)
174		#'
175		#' card <- ReportCard$new()$append_text("Some text")$append_plot(
176		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
177		#' )$append_text("Some text")$append_metadata(key = "lm",
178		#' value = lm(Ozone ~ Solar.R, airquality))
179		#' card$get_content()
180		#'
181		#' card$to_list(tempdir())
182		#'
183		to_list = function(output_dir) {
184	7x	new_blocks <- list()
185	7x	for (block in self$get_content()) {
186	25x	block_class <- class(block)[1]
187	25x	cblock <- if (inherits(block, "FileBlock")) {
188	10x	block$to_list(output_dir)
189	25x	} else if (inherits(block, "ContentBlock")) {
190	15x	block$to_list()
191		} else {
192	!	list()
193		}
194	25x	new_block <- list()
195	25x	new_block[[block_class]] <- cblock
196	25x	new_blocks <- c(new_blocks, new_block)
197		}
198	7x	new_card <- list()
199	7x	new_card[["blocks"]] <- new_blocks
200	7x	new_card[["metadata"]] <- self$get_metadata()
201	7x	new_card
202		},
203		#' @description Reconstructs the `ReportCard` from a list representation.
204		#' @param card (`named list`) a `ReportCard` representation.
205		#' @param output_dir (`character`) with a path to the directory where a file will be copied.
206		#' @return `self`, invisibly.
207		#' @examples
208		#' library(ggplot2)
209		#'
210		#' card <- ReportCard$new()$append_text("Some text")$append_plot(
211		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
212		#' )$append_text("Some text")$append_metadata(key = "lm",
213		#' value = lm(Ozone ~ Solar.R, airquality))
214		#' card$get_content()
215		#'
216		#' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
217		#'
218		from_list = function(card, output_dir) {
219	17x	self$reset()
220	17x	blocks <- card$blocks
221	17x	metadata <- card$metadata
222	17x	blocks_names <- names(blocks)
223	17x	blocks_names <- gsub("[.][0-9]*$", "", blocks_names)
224	17x	for (iter_b in seq_along(blocks)) {
225	60x	block_class <- blocks_names[iter_b]
226	60x	block <- blocks[[iter_b]]
227	60x	cblock <- eval(str2lang(sprintf("%s$new()", block_class)))
228	60x	if (inherits(cblock, "FileBlock")) {
229	25x	cblock$from_list(block, output_dir)
230	35x	} else if (inherits(cblock, "ContentBlock")) {
231	35x	cblock$from_list(block)
232		} else {
233	!	NULL
234		}
235	60x	self$append_content(cblock)
236		}
237	17x	for (meta in names(metadata)) {
238	!	self$append_metadata(meta, metadata[[meta]])
239		}
240	17x	invisible(self)
241		}
242		),
243		private = list(
244		content = list(),
245		metadata = list(),
246		name = character(0),
247		# @description The copy constructor.
248		#
249		# @param name the name of the field
250		# @param value the value of the field
251		# @return the new value of the field
252		#
253		deep_clone = function(name, value) {
254	57x	if (name == "content") {
255	3x	lapply(value, function(content_block) {
256	5x	if (inherits(content_block, "R6")) {
257	5x	content_block$clone(deep = TRUE)
258		} else {
259	!	content_block
260		}
261		})
262		} else {
263	54x	value
264		}
265		}
266		),
267		lock_objects = TRUE,
268		lock_class = TRUE
269		)

1		#' @title `ContentBlock`: A building block for report content
2		#' @docType class
3		#' @description This class represents a basic content unit in a report,
4		#' such as text, images, or other multimedia elements.
5		#' It serves as a foundation for constructing complex report structures.
6		#'
7		#' @keywords internal
8		ContentBlock <- R6::R6Class( # nolint: object_name_linter.
9		classname = "ContentBlock",
10		public = list(
11		#' @description Initialize a `ContentBlock` object.
12		#'
13		#' @details Returns a `ContentBlock` object with no content and the default style.
14		#'
15		#' @return Object of class `ContentBlock`, invisibly.
16		#' @examples
17		#' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
18		#' ContentBlock$new()
19		#'
20		initialize = function() {
21	17x	private$content <- character(0)
22	17x	invisible(self)
23		},
24		#' @description Sets content of this `ContentBlock`.
25		#'
26		#' @param content (`character(0)` or `character(1)`) string or file path assigned to this `ContentBlock`
27		#'
28		#' @return `self`, invisibly.
29		#' @examples
30		#' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
31		#' block <- ContentBlock$new()
32		#' block$set_content("Base64 encoded picture")
33		#'
34		set_content = function(content) {
35	361x	checkmate::assert_character(content, min.len = 0, max.len = 1)
36	358x	private$content <- content
37	358x	invisible(self)
38		},
39		#' @description Retrieves the content assigned to this block.
40		#'
41		#' @return `character` string or file path assigned to this `ContentBlock`.
42		#' @examples
43		#' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
44		#' block <- ContentBlock$new()
45		#' block$get_content()
46		#'
47		get_content = function() {
48	266x	private$content
49		},
50		#' @description Create the `ContentBlock` from a list.
51		#'
52		#' @param x (`named list`) with two fields `text` and `style`.
53		#' Use the `get_available_styles` method to get all possible styles.
54		#'
55		#' @return `self`, invisibly.
56		from_list = function(x) {
57	!	invisible(self)
58		},
59		#' @description Convert the `ContentBlock` to a list.
60		#'
61		#' @return `named list` with a text and style.
62		to_list = function() {
63	!	list()
64		}
65		),
66		private = list(
67		content = character(0),
68		# @description The copy constructor.
69		#
70		# @param name (`character(1)`) the name of the field
71		# @param value the value assigned to the field
72		#
73		# @return the value of the copied field
74		deep_clone = function(name, value) {
75	168x	if (name == "content" && checkmate::test_file_exists(value)) {
76	7x	extension <- ""
77	7x	split <- strsplit(basename(value), split = "\\.")
78		# The below ensures no extension is found for files such as this: .gitignore but is found for files like
79		# .gitignore.txt
80	7x	if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
81	5x	extension <- split[[1]][length(split[[1]])]
82	5x	extension <- paste0(".", extension)
83		}
84	7x	copied_file <- tempfile(fileext = extension)
85	7x	file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
86	7x	copied_file
87		} else {
88	161x	value
89		}
90		}
91		),
92		lock_objects = TRUE,
93		lock_class = TRUE
94		)

1		#' @title `Archiver`: Base class for data archiving
2		#' @docType class
3		#' @description
4		#' A base `R6` class for implementing data archiving functionality.
5		#'
6		#' @keywords internal
7		Archiver <- R6::R6Class( # nolint: object_name_linter.
8		classname = "Archiver",
9		public = list(
10		#' @description Initialize an `Archiver` object.
11		#'
12		#' @return Object of class `Archiver`, invisibly.
13		#' @examples
14		#' Archiver <- getFromNamespace("Archiver", "teal.reporter")
15		#' Archiver$new()
16		initialize = function() {
17	3x	invisible(self)
18		},
19		#' @description Finalizes an `Archiver` object.
20		finalize = function() {
21		# destructor
22		},
23		#' @description Reads data from the `Archiver`.
24		#' Pure virtual method that should be implemented by inherited classes.
25		read = function() {
26		# returns Reporter instance
27	1x	stop("Pure virtual method.")
28		},
29		#' @description Writes data to the `Archiver`.
30		#' Pure virtual method that should be implemented by inherited classes.
31		write = function() {
32	1x	stop("Pure virtual method.")
33		}
34		),
35		lock_objects = TRUE,
36		lock_class = TRUE
37		)
38
39		#' @title `FileArchiver`: A File-based `Archiver`
40		#' @docType class
41		#' @description
42		#' Inherits from `Archiver` to provide file-based archiving functionality.
43		#' Manages an output directory for storing archived data.
44		#'
45		#' @keywords internal
46		FileArchiver <- R6::R6Class( # nolint: object_name_linter.
47		classname = "FileArchiver",
48		inherit = Archiver,
49		public = list(
50		#' @description Initialize a `FileArchiver` object with a unique output directory.
51		#'
52		#' @return Object of class `FileArchiver`, invisibly.
53		#' @examples
54		#' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
55		#' FileArchiver$new()
56		initialize = function() {
57	10x	tmp_dir <- tempdir()
58	10x	output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
59	10x	dir.create(path = output_dir)
60	10x	private$output_dir <- output_dir
61	10x	invisible(self)
62		},
63		#' @description Finalizes a `FileArchiver` object.
64		#' Cleans up by removing the output directory and its contents.
65		finalize = function() {
66	10x	unlink(private$output_dir, recursive = TRUE)
67		},
68		#' @description Get `output_dir` field.
69		#'
70		#' @return `character` a `output_dir` field path.
71		#' @examples
72		#' FileArchiver <- getFromNamespace("FileArchiver", "teal.reporter")
73		#' FileArchiver$new()$get_output_dir()
74		get_output_dir = function() {
75	9x	private$output_dir
76		}
77		),
78		private = list(
79		output_dir = character(0)
80		)
81		)
82
83		#' @title `JSONArchiver`: A `JSON`-based `Archiver`
84		#' @docType class
85		#' @description
86		#' Inherits from `FileArchiver` to implement `JSON`-based archiving functionality.
87		#' Convert `Reporter` instances to and from `JSON` format.
88		#'
89		#' @keywords internal
90		JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
91		classname = "JSONArchiver",
92		inherit = FileArchiver,
93		public = list(
94		#' @description Write a `Reporter` instance in `JSON` file.
95		#' Serializes a given `Reporter` instance and saves it in the `Archiver`'s output directory,
96		#' to this `JSONArchiver` object.
97		#'
98		#' @param reporter (`Reporter`) instance.
99		#'
100		#' @return `self`.
101		#' @examples
102		#' library(ggplot2)
103		#'
104		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
105		#' card1 <- ReportCard$new()
106		#'
107		#' card1$append_text("Header 2 text", "header2")
108		#' card1$append_text("A paragraph of default text", "header2")
109		#' card1$append_plot(
110		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
111		#' )
112		#'
113		#' Reporter <- getFromNamespace("Reporter", "teal.reporter")
114		#' reporter <- Reporter$new()
115		#' reporter$append_cards(list(card1))
116		#'
117		#' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
118		#' archiver <- JSONArchiver$new()
119		#' archiver$write(reporter)
120		#' archiver$get_output_dir()
121		write = function(reporter) {
122	1x	checkmate::assert_class(reporter, "Reporter")
123	1x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
124	1x	reporter$to_jsondir(private$output_dir)
125	1x	self
126		},
127		#' @description Read a `Reporter` instance from a `JSON` file.
128		#' Converts a `Reporter` instance from the `JSON` file in the `JSONArchiver`'s output directory.
129		#'
130		#' @param path (`character(1)`) a path to the directory with all proper files.
131		#'
132		#' @return `Reporter` instance.
133		#' @examples
134		#' library(ggplot2)
135		#'
136		#' ReportCard <- getFromNamespace("ReportCard", "teal.reporter")
137		#' card1 <- ReportCard$new()
138		#'
139		#' card1$append_text("Header 2 text", "header2")
140		#' card1$append_text("A paragraph of default text", "header2")
141		#' card1$append_plot(
142		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
143		#' )
144		#'
145		#' Reporter <- getFromNamespace("Reporter", "teal.reporter")
146		#' reporter <- Reporter$new()
147		#' reporter$append_cards(list(card1))
148		#'
149		#' JSONArchiver <- getFromNamespace("JSONArchiver", "teal.reporter")
150		#' archiver <- JSONArchiver$new()
151		#' archiver$write(reporter)
152		#' archiver$get_output_dir()
153		#'
154		#' archiver$read()$get_cards()[[1]]$get_content()
155		#' Reporter <- getFromNamespace("Reporter", "teal.reporter")
156		#' blocks <- Reporter$new()
157		#' blocks <- blocks$from_reporter(archiver$read())$get_blocks()
158		#' Renderer <- getFromNamespace("Renderer", "teal.reporter")
159		#' doc <- Renderer$new()$render(blocks)
160		read = function(path = NULL) {
161	7x	checkmate::assert(
162	7x	checkmate::check_null(path),
163	7x	checkmate::check_directory_exists(path)
164		)
165
166	7x	if (!is.null(path) && !identical(path, private$output_dir)) {
167	3x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
168	3x	file.copy(list.files(path, full.names = TRUE), private$output_dir)
169		}
170
171	7x	if (length(list.files(private$output_dir))) {
172	6x	Reporter$new()$from_jsondir(private$output_dir)
173		} else {
174	1x	warning("The directory provided to the Archiver is empty.")
175	1x	Reporter$new()
176		}
177		}
178		),
179		lock_objects = TRUE,
180		lock_class = TRUE
181		)

1		#' @title `Reporter`: An `R6` class for managing report cards
2		#' @docType class
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' This `R6` class is designed to store and manage report cards,
6		#' facilitating the creation, manipulation, and serialization of report-related data.
7		#'
8		#' @export
9		#'
10		Reporter <- R6::R6Class( # nolint: object_name_linter.
11		classname = "Reporter",
12		public = list(
13		#' @description Initialize a `Reporter` object.
14		#'
15		#' @return Object of class `Reporter`, invisibly.
16		#' @examples
17		#' reporter <- Reporter$new()
18		#'
19		initialize = function() {
20	44x	private$cards <- list()
21	44x	private$reactive_add_card <- shiny::reactiveVal(0)
22	44x	invisible(self)
23		},
24		#' @description Append one or more `ReportCard` objects to the `Reporter`.
25		#'
26		#' @param cards (`ReportCard`) or a list of such objects
27		#' @return `self`, invisibly.
28		#' @examples
29		#' library(ggplot2)
30		#' library(rtables)
31		#'
32		#' card1 <- ReportCard$new()
33		#'
34		#' card1$append_text("Header 2 text", "header2")
35		#' card1$append_text("A paragraph of default text", "header2")
36		#' card1$append_plot(
37		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
38		#' )
39		#'
40		#' card2 <- ReportCard$new()
41		#'
42		#' card2$append_text("Header 2 text", "header2")
43		#' card2$append_text("A paragraph of default text", "header2")
44		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
45		#' table_res2 <- build_table(lyt, airquality)
46		#' card2$append_table(table_res2)
47		#' card2$append_table(iris)
48		#'
49		#' reporter <- Reporter$new()
50		#' reporter$append_cards(list(card1, card2))
51		append_cards = function(cards) {
52	41x	checkmate::assert_list(cards, "ReportCard")
53	41x	private$cards <- append(private$cards, cards)
54	41x	private$reactive_add_card(length(private$cards))
55	41x	invisible(self)
56		},
57		#' @description Retrieves all `ReportCard` objects contained in the `Reporter`.
58		#'
59		#' @return A (`list`) of [`ReportCard`] objects.
60		#' @examples
61		#' library(ggplot2)
62		#' library(rtables)
63		#'
64		#' card1 <- ReportCard$new()
65		#'
66		#' card1$append_text("Header 2 text", "header2")
67		#' card1$append_text("A paragraph of default text", "header2")
68		#' card1$append_plot(
69		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
70		#' )
71		#'
72		#' card2 <- ReportCard$new()
73		#'
74		#' card2$append_text("Header 2 text", "header2")
75		#' card2$append_text("A paragraph of default text", "header2")
76		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
77		#' table_res2 <- build_table(lyt, airquality)
78		#' card2$append_table(table_res2)
79		#' card2$append_table(iris)
80		#'
81		#' reporter <- Reporter$new()
82		#' reporter$append_cards(list(card1, card2))
83		#' reporter$get_cards()
84		get_cards = function() {
85	72x	private$cards
86		},
87		#' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`.
88		#'
89		#' @param sep An optional separator to insert between each content block.
90		#' Default is a `NewpageBlock$new()`object.
91		#' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`.
92		#' @examples
93		#' library(ggplot2)
94		#' library(rtables)
95		#'
96		#' card1 <- ReportCard$new()
97		#'
98		#' card1$append_text("Header 2 text", "header2")
99		#' card1$append_text("A paragraph of default text", "header2")
100		#' card1$append_plot(
101		#' ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
102		#' )
103		#'
104		#' card2 <- ReportCard$new()
105		#'
106		#' card2$append_text("Header 2 text", "header2")
107		#' card2$append_text("A paragraph of default text", "header2")
108		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
109		#' table_res2 <- build_table(lyt, airquality)
110		#' card2$append_table(table_res2)
111		#' card2$append_table(iris)
112		#'
113		#' reporter <- Reporter$new()
114		#' reporter$append_cards(list(card1, card2))
115		#' reporter$get_blocks()
116		#'
117		get_blocks = function(sep = NewpageBlock$new()) {
118	36x	blocks <- list()
119	36x	if (length(private$cards) > 0) {
120	33x	for (card_idx in head(seq_along(private$cards), -1)) {
121	14x	blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
122		}
123	33x	blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
124		}
125	36x	blocks
126		},
127		#' @description Resets the `Reporter`, removing all [`ReportCard`] objects and metadata.
128		#'
129		#' @return `self`, invisibly.
130		#'
131		reset = function() {
132	27x	private$cards <- list()
133	27x	private$metadata <- list()
134	27x	private$reactive_add_card(0)
135	27x	invisible(self)
136		},
137		#' @description Removes specific `ReportCard` objects from the `Reporter` by their indices.
138		#'
139		#' @param ids (`integer(id)`) the indexes of cards
140		#' @return `self`, invisibly.
141		remove_cards = function(ids = NULL) {
142	1x	checkmate::assert(
143	1x	checkmate::check_null(ids),
144	1x	checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
145		)
146	1x	if (!is.null(ids)) {
147	1x	private$cards <- private$cards[-ids]
148		}
149	1x	private$reactive_add_card(length(private$cards))
150	1x	invisible(self)
151		},
152		#' @description Swaps the positions of two `ReportCard` objects within the `Reporter`.
153		#'
154		#' @param start (`integer`) the index of the first card
155		#' @param end (`integer`) the index of the second card
156		#' @return `self`, invisibly.
157		swap_cards = function(start, end) {
158	6x	checkmate::assert(
159	6x	checkmate::check_integer(start,
160	6x	min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
161		),
162	6x	checkmate::check_integer(end,
163	6x	min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
164		),
165	6x	combine = "and"
166		)
167	6x	start_val <- private$cards[[start]]$clone()
168	6x	end_val <- private$cards[[end]]$clone()
169	6x	private$cards[[start]] <- end_val
170	6x	private$cards[[end]] <- start_val
171	6x	invisible(self)
172		},
173		#' @description Gets the current value of the reactive variable for adding cards.
174		#'
175		#' @return `reactive_add_card` current `numeric` value of the reactive variable.
176		#' @note The function has to be used in the shiny reactive context.
177		#' @examples
178		#' library(shiny)
179		#'
180		#' isolate(Reporter$new()$get_reactive_add_card())
181		get_reactive_add_card = function() {
182	23x	private$reactive_add_card()
183		},
184		#' @description Get the metadata associated with this `Reporter`.
185		#'
186		#' @return `named list` of metadata to be appended.
187		#' @examples
188		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
189		#' reporter$get_metadata()
190		#'
191		get_metadata = function() {
192	17x	private$metadata
193		},
194		#' @description Appends metadata to this `Reporter`.
195		#'
196		#' @param meta (`named list`) of metadata to be appended.
197		#' @return `self`, invisibly.
198		#' @examples
199		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
200		#' reporter$get_metadata()
201		#'
202		append_metadata = function(meta) {
203	25x	checkmate::assert_list(meta, names = "unique")
204	22x	checkmate::assert_true(length(meta) == 0 \|\| all(!names(meta) %in% names(private$metadata)))
205	21x	private$metadata <- append(private$metadata, meta)
206	21x	invisible(self)
207		},
208		#' @description
209		#' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
210		#' @param reporter (`Reporter`) instance to copy from.
211		#' @return `self`, invisibly.
212		#' @examples
213		#' reporter <- Reporter$new()
214		#' reporter$from_reporter(reporter)
215		from_reporter = function(reporter) {
216	8x	checkmate::assert_class(reporter, "Reporter")
217	8x	self$reset()
218	8x	self$append_cards(reporter$get_cards())
219	8x	self$append_metadata(reporter$get_metadata())
220	8x	invisible(self)
221		},
222		#' @description Convert a `Reporter` to a list and transfer any associated files to specified directory.
223		#' @param output_dir (`character(1)`) a path to the directory where files will be copied.
224		#' @return `named list` representing the `Reporter` instance, including version information,
225		#' metadata, and report cards.
226		#'
227		#' @examples
228		#' reporter <- Reporter$new()
229		#' tmp_dir <- file.path(tempdir(), "testdir")
230		#' dir.create(tmp_dir)
231		#' reporter$to_list(tmp_dir)
232		to_list = function(output_dir) {
233	8x	checkmate::assert_directory_exists(output_dir)
234	6x	rlist <- list(version = "1", cards = list())
235	6x	rlist[["metadata"]] <- self$get_metadata()
236	6x	for (card in self$get_cards()) {
237		# we want to have list names being a class names to indicate the class for $from_list
238	6x	card_class <- class(card)[1]
239	6x	u_card <- list()
240	6x	u_card[[card_class]] <- card$to_list(output_dir)
241	6x	rlist$cards <- c(rlist$cards, u_card)
242		}
243	6x	rlist
244		},
245		#' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
246		#' @param rlist (`named list`) representing a `Reporter` instance.
247		#' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
248		#' @return `self`, invisibly.
249		#' @examples
250		#' reporter <- Reporter$new()
251		#' tmp_dir <- file.path(tempdir(), "testdir")
252		#' unlink(tmp_dir, recursive = TRUE)
253		#' dir.create(tmp_dir)
254		#' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
255		from_list = function(rlist, output_dir) {
256	10x	checkmate::assert_list(rlist)
257	10x	checkmate::assert_directory_exists(output_dir)
258	10x	if (rlist$version == "1") {
259	10x	new_cards <- list()
260	10x	cards_names <- names(rlist$cards)
261	10x	cards_names <- gsub("[.][0-9]*$", "", cards_names)
262	10x	for (iter_c in seq_along(rlist$cards)) {
263	16x	card_class <- cards_names[iter_c]
264	16x	card <- rlist$cards[[iter_c]]
265	16x	new_card <- eval(str2lang(sprintf("%s$new()", card_class)))
266	16x	new_card$from_list(card, output_dir)
267	16x	new_cards <- c(new_cards, new_card)
268		}
269		} else {
270	!	stop("The provided version is not supported")
271		}
272	10x	self$reset()
273	10x	self$append_cards(new_cards)
274	10x	self$append_metadata(rlist$metadata)
275	10x	invisible(self)
276		},
277		#' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory.
278		#' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics.
279		#' @return `output_dir` argument.
280		#' @examples
281		#' reporter <- Reporter$new()
282		#' tmp_dir <- file.path(tempdir(), "jsondir")
283		#' dir.create(tmp_dir)
284		#' reporter$to_jsondir(tmp_dir)
285		to_jsondir = function(output_dir) {
286	5x	checkmate::assert_directory_exists(output_dir)
287	3x	json <- self$to_list(output_dir)
288	3x	cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
289	3x	file = file.path(output_dir, "Report.json")
290		)
291	3x	output_dir
292		},
293		#' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory.
294		#' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics.
295		#' @return `self`, invisibly.
296		#' @examples
297		#' reporter <- Reporter$new()
298		#' tmp_dir <- file.path(tempdir(), "jsondir")
299		#' dir.create(tmp_dir)
300		#' unlink(list.files(tmp_dir, recursive = TRUE))
301		#' reporter$to_jsondir(tmp_dir)
302		#' reporter$from_jsondir(tmp_dir)
303		from_jsondir = function(output_dir) {
304	8x	checkmate::assert_directory_exists(output_dir)
305	8x	checkmate::assert_true(length(list.files(output_dir)) > 0)
306	8x	dir_files <- list.files(output_dir)
307	8x	which_json <- grep("json$", dir_files)
308	8x	json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
309	8x	self$reset()
310	8x	self$from_list(json, output_dir)
311	8x	invisible(self)
312		}
313		),
314		private = list(
315		cards = list(),
316		metadata = list(),
317		reactive_add_card = NULL,
318		# @description The copy constructor.
319		#
320		# @param name the name of the field
321		# @param value the value of the field
322		# @return the new value of the field
323		#
324		deep_clone = function(name, value) {
325	20x	if (name == "cards") {
326	1x	lapply(value, function(card) card$clone(deep = TRUE))
327		} else {
328	19x	value
329		}
330		}
331		),
332		lock_objects = TRUE,
333		lock_class = TRUE
334		)

1		#' Report previewer module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Module offers functionalities to visualize, manipulate,
6		#' and interact with report cards that have been added to a report.
7		#' It includes a previewer interface to see the cards and options to modify the report before downloading.
8		#'
9		#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
10		#'
11		#' @details `r global_knitr_details()`
12		#'
13		#' @name reporter_previewer
14		#'
15		#' @param id (`character(1)`) `shiny` module instance id.
16		#' @param reporter (`Reporter`) instance.
17		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
18		#' for customizing the rendering process.
19		#' @inheritParams reporter_download_inputs
20		#'
21		#' @return `NULL`.
22		NULL
23
24		#' @rdname reporter_previewer
25		#' @export
26		reporter_previewer_ui <- function(id) {
27	1x	ns <- shiny::NS(id)
28
29	1x	shiny::fluidRow(
30	1x	add_previewer_js(ns),
31	1x	add_previewer_css(),
32	1x	shiny::tagList(
33	1x	shiny::tags$div(
34	1x	class = "col-md-3",
35	1x	shiny::tags$div(class = "well", shiny::uiOutput(ns("encoding")))
36		),
37	1x	shiny::tags$div(
38	1x	class = "col-md-9",
39	1x	shiny::tags$div(
40	1x	id = "reporter_previewer",
41	1x	shiny::uiOutput(ns("pcards"))
42		)
43		)
44		)
45		)
46		}
47
48		#' @rdname reporter_previewer
49		#' @export
50		reporter_previewer_srv <- function(id,
51		reporter,
52		global_knitr = getOption("teal.reporter.global_knitr"),
53		rmd_output = c(
54		"html" = "html_document", "pdf" = "pdf_document",
55		"powerpoint" = "powerpoint_presentation",
56		"word" = "word_document"
57		), rmd_yaml_args = list(
58		author = "NEST", title = "Report",
59		date = as.character(Sys.Date()), output = "html_document",
60		toc = FALSE
61		)) {
62	12x	checkmate::assert_class(reporter, "Reporter")
63	12x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
64	12x	checkmate::assert_subset(
65	12x	rmd_output,
66	12x	c(
67	12x	"html_document", "pdf_document",
68	12x	"powerpoint_presentation", "word_document"
69		),
70	12x	empty.ok = FALSE
71		)
72	12x	checkmate::assert_list(rmd_yaml_args, names = "named")
73	12x	checkmate::assert_names(
74	12x	names(rmd_yaml_args),
75	12x	subset.of = c("author", "title", "date", "output", "toc"),
76	12x	must.include = "output"
77		)
78	10x	checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
79
80	9x	shiny::moduleServer(
81	9x	id,
82	9x	function(input, output, session) {
83	9x	ns <- session$ns
84
85	9x	teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter)
86
87	9x	output$encoding <- shiny::renderUI({
88	7x	reporter$get_reactive_add_card()
89	7x	shiny::tagList(
90	7x	shiny::tags$h3("Download the Report"),
91	7x	shiny::tags$hr(),
92	7x	reporter_download_inputs(
93	7x	rmd_yaml_args = rmd_yaml_args,
94	7x	rmd_output = rmd_output,
95	7x	showrcode = any_rcode_block(reporter),
96	7x	session = session
97		),
98	7x	htmltools::tagAppendAttributes(
99	7x	shiny::tags$a(
100	7x	id = ns("download_data_prev"),
101	7x	class = "btn btn-primary shiny-download-link",
102	7x	href = "",
103	7x	target = "_blank",
104	7x	download = NA,
105	7x	shiny::tags$span("Download Report", shiny::icon("download"))
106		),
107	7x	class = if (length(reporter$get_cards())) "" else "disabled"
108		),
109	7x	teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
110		)
111		})
112
113	9x	output$pcards <- shiny::renderUI({
114	9x	reporter$get_reactive_add_card()
115	9x	input$card_remove_id
116	9x	input$card_down_id
117	9x	input$card_up_id
118
119	9x	cards <- reporter$get_cards()
120
121	9x	if (length(cards)) {
122	8x	shiny::tags$div(
123	8x	class = "panel-group accordion",
124	8x	id = "reporter_previewer_panel",
125	8x	lapply(seq_along(cards), function(ic) {
126	14x	previewer_collapse_item(ic, cards[[ic]]$get_name(), cards[[ic]]$get_content())
127		})
128		)
129		} else {
130	1x	shiny::tags$div(
131	1x	id = "reporter_previewer_panel_no_cards",
132	1x	shiny::tags$p(
133	1x	class = "text-danger mt-4",
134	1x	shiny::tags$strong("No Cards added")
135		)
136		)
137		}
138		})
139
140	9x	shiny::observeEvent(input$card_remove_id, {
141	1x	shiny::showModal(
142	1x	shiny::modalDialog(
143	1x	title = "Remove the Report Card",
144	1x	shiny::tags$p(
145	1x	shiny::HTML(
146	1x	sprintf(
147	1x	"Do you really want to remove <strong>the card %s</strong> from the Report?",
148	1x	input$card_remove_id
149		)
150		)
151		),
152	1x	footer = shiny::tagList(
153	1x	shiny::tags$button(
154	1x	type = "button",
155	1x	class = "btn btn-secondary",
156	1x	`data-dismiss` = "modal",
157	1x	`data-bs-dismiss` = "modal",
158	1x	NULL,
159	1x	"Cancel"
160		),
161	1x	shiny::actionButton(ns("remove_card_ok"), "OK", class = "btn-danger")
162		)
163		)
164		)
165		})
166
167	9x	shiny::observeEvent(input$remove_card_ok, {
168	1x	reporter$remove_cards(input$card_remove_id)
169	1x	shiny::removeModal()
170		})
171
172	9x	shiny::observeEvent(input$card_up_id, {
173	3x	if (input$card_up_id > 1) {
174	2x	reporter$swap_cards(
175	2x	as.integer(input$card_up_id),
176	2x	as.integer(input$card_up_id - 1)
177		)
178		}
179		})
180
181	9x	shiny::observeEvent(input$card_down_id, {
182	3x	if (input$card_down_id < length(reporter$get_cards())) {
183	2x	reporter$swap_cards(
184	2x	as.integer(input$card_down_id),
185	2x	as.integer(input$card_down_id + 1)
186		)
187		}
188		})
189
190	9x	output$download_data_prev <- shiny::downloadHandler(
191	9x	filename = function() {
192	1x	paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
193		},
194	9x	content = function(file) {
195	1x	shiny::showNotification("Rendering and Downloading the document.")
196	1x	shinybusy::block(id = ns("download_data_prev"), text = "", type = "dots")
197	1x	input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
198	1x	names(input_list) <- names(rmd_yaml_args)
199	!	if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
200	1x	report_render_and_compress(reporter, input_list, global_knitr, file)
201	1x	shinybusy::unblock(id = ns("download_data_prev"))
202		},
203	9x	contentType = "application/zip"
204		)
205		}
206		)
207		}
208
209		#' @noRd
210		#' @keywords internal
211		block_to_html <- function(b) {
212	42x	b_content <- b$get_content()
213	42x	if (inherits(b, "TextBlock")) {
214	28x	switch(b$get_style(),
215	!	header1 = shiny::tags$h1(b_content),
216	28x	header2 = shiny::tags$h2(b_content),
217	!	header3 = shiny::tags$h3(b_content),
218	!	header4 = shiny::tags$h4(b_content),
219	!	verbatim = shiny::tags$pre(b_content),
220	!	shiny::tags$pre(b_content)
221		)
222	14x	} else if (inherits(b, "RcodeBlock")) {
223	!	panel_item("R Code", shiny::tags$pre(b_content))
224	14x	} else if (inherits(b, "PictureBlock")) {
225	14x	shiny::tags$img(src = knitr::image_uri(b_content))
226	!	} else if (inherits(b, "TableBlock")) {
227	!	b_table <- readRDS(b_content)
228	!	shiny::tags$pre(
229	!	flextable::htmltools_value(b_table)
230		)
231	!	} else if (inherits(b, "NewpageBlock")) {
232	!	shiny::tags$br()
233		} else {
234	!	stop("Unknown block class")
235		}
236		}
237
238		#' @noRd
239		#' @keywords internal
240		add_previewer_css <- function() {
241	1x	shiny::tagList(
242	1x	shiny::singleton(
243	1x	shiny::tags$head(shiny::includeCSS(system.file("css/Previewer.css", package = "teal.reporter")))
244		),
245	1x	shiny::singleton(
246	1x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
247		)
248		)
249		}
250
251		#' @noRd
252		#' @keywords internal
253		add_previewer_js <- function(ns) {
254	1x	shiny::singleton(
255	1x	shiny::tags$head(shiny::tags$script(
256	1x	shiny::HTML(sprintf('
257	1x	$(document).ready(function(event) {
258	1x	$("body").on("click", "span.card_remove_id", function() {
259	1x	let val = $(this).data("cardid");
260	1x	Shiny.setInputValue("%s", val, {priority: "event"});
261		});
262
263	1x	$("body").on("click", "span.card_up_id", function() {
264	1x	let val = $(this).data("cardid");
265	1x	Shiny.setInputValue("%s", val, {priority: "event"});
266		});
267
268	1x	$("body").on("click", "span.card_down_id", function() {
269	1x	let val = $(this).data("cardid");
270	1x	Shiny.setInputValue("%s", val, {priority: "event"});
271		});
272		});
273	1x	', ns("card_remove_id"), ns("card_up_id"), ns("card_down_id")))
274		))
275		)
276		}
277
278		#' @noRd
279		#' @keywords internal
280		nav_previewer_icon <- function(name, icon_name, idx, size = 1L) {
281	42x	checkmate::assert_string(name)
282	42x	checkmate::assert_string(icon_name)
283	42x	checkmate::assert_int(size)
284
285	42x	shiny::tags$span(
286	42x	class = paste(name, "icon_previewer"),
287		# data field needed to record clicked card on the js side
288	42x	`data-cardid` = idx,
289	42x	shiny::icon(icon_name, sprintf("fa-%sx", size))
290		)
291		}
292
293		#' @noRd
294		#' @keywords internal
295		nav_previewer_icons <- function(idx, size = 1L) {
296	14x	shiny::tags$span(
297	14x	class = "preview_card_control",
298	14x	nav_previewer_icon(name = "card_remove_id", icon_name = "xmark", idx = idx, size = size),
299	14x	nav_previewer_icon(name = "card_up_id", icon_name = "arrow-up", idx = idx, size = size),
300	14x	nav_previewer_icon(name = "card_down_id", icon_name = "arrow-down", idx = idx, size = size)
301		)
302		}
303
304		#' @noRd
305		#' @keywords internal
306		previewer_collapse_item <- function(idx, card_name, card_blocks) {
307	14x	shiny::tags$div(.renderHook = function(x) {
308		# get bs version
309	14x	version <- get_bs_version()
310
311	14x	if (version == "3") {
312	14x	shiny::tags$div(
313	14x	id = paste0("panel_card_", idx),
314	14x	class = "panel panel-default",
315	14x	shiny::tags$div(
316	14x	class = "panel-heading overflow-auto",
317	14x	shiny::tags$div(
318	14x	class = "panel-title",
319	14x	shiny::tags$span(
320	14x	nav_previewer_icons(idx = idx),
321	14x	shiny::tags$a(
322	14x	class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
323	14x	`data-toggle` = "collapse",
324	14x	`data-parent` = "#reporter_previewer_panel",
325	14x	href = paste0("#collapse", idx),
326	14x	shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down"))
327		)
328		)
329		)
330		),
331	14x	shiny::tags$div(
332	14x	id = paste0("collapse", idx), class = "collapse out",
333	14x	shiny::tags$div(
334	14x	class = "panel-body",
335	14x	shiny::tags$div(
336	14x	id = paste0("card", idx),
337	14x	lapply(
338	14x	card_blocks,
339	14x	function(b) {
340	42x	block_to_html(b)
341		}
342		)
343		)
344		)
345		)
346		)
347		} else {
348	!	shiny::tags$div(
349	!	id = paste0("panel_card_", idx),
350	!	class = "card",
351	!	shiny::tags$div(
352	!	class = "overflow-auto",
353	!	shiny::tags$div(
354	!	class = "card-header",
355	!	shiny::tags$span(
356	!	nav_previewer_icons(idx = idx),
357	!	shiny::tags$a(
358	!	class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
359		# bs4
360	!	`data-toggle` = "collapse",
361		# bs5
362	!	`data-bs-toggle` = "collapse",
363	!	href = paste0("#collapse", idx),
364	!	shiny::tags$h4(
365	!	paste0("Card ", idx, ": ", card_name),
366	!	shiny::icon("caret-down")
367		)
368		)
369		)
370		)
371		),
372	!	shiny::tags$div(
373	!	id = paste0("collapse", idx),
374	!	class = "collapse out",
375		# bs4
376	!	`data-parent` = "#reporter_previewer_panel",
377		# bs5
378	!	`data-bs-parent` = "#reporter_previewer_panel",
379	!	shiny::tags$div(
380	!	class = "card-body",
381	!	shiny::tags$div(
382	!	id = paste0("card", idx),
383	!	lapply(
384	!	card_blocks,
385	!	function(b) {
386	!	block_to_html(b)
387		}
388		)
389		)
390		)
391		)
392		)
393		}
394		})
395		}

1		#' Download report button module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Provides a button that triggers downloading a report.
6		#'
7		#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
8		#'
9		#' @details `r global_knitr_details()`
10		#'
11		#' @name download_report_button
12		#'
13		#' @param id (`character(1)`) this `shiny` module's id.
14		#' @param reporter (`Reporter`) instance.
15		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
16		#' for customizing the rendering process.
17		#' @inheritParams reporter_download_inputs
18		#'
19		#' @return `NULL`.
20		NULL
21
22		#' @rdname download_report_button
23		#' @export
24		download_report_button_ui <- function(id) {
25	2x	ns <- shiny::NS(id)
26	2x	shiny::tagList(
27	2x	shiny::singleton(
28	2x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
29		),
30	2x	shiny::tags$button(
31	2x	id = ns("download_button"),
32	2x	type = "button",
33	2x	class = "simple_report_button btn btn-primary action-button",
34	2x	title = "Download",
35	2x	`data-val` = shiny::restoreInput(id = ns("download_button"), default = NULL),
36	2x	NULL,
37	2x	shiny::tags$span(
38	2x	shiny::icon("download")
39		)
40		)
41		)
42		}
43
44		#' @rdname download_report_button
45		#' @export
46		download_report_button_srv <- function(id,
47		reporter,
48		global_knitr = getOption("teal.reporter.global_knitr"),
49		rmd_output = c(
50		"html" = "html_document", "pdf" = "pdf_document",
51		"powerpoint" = "powerpoint_presentation", "word" = "word_document"
52		),
53		rmd_yaml_args = list(
54		author = "NEST", title = "Report",
55		date = as.character(Sys.Date()), output = "html_document",
56		toc = FALSE
57		)) {
58	10x	checkmate::assert_class(reporter, "Reporter")
59	10x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
60	10x	checkmate::assert_subset(
61	10x	rmd_output,
62	10x	c(
63	10x	"html_document", "pdf_document",
64	10x	"powerpoint_presentation", "word_document"
65		),
66	10x	empty.ok = FALSE
67		)
68	10x	checkmate::assert_list(rmd_yaml_args, names = "named")
69	10x	checkmate::assert_names(
70	10x	names(rmd_yaml_args),
71	10x	subset.of = c("author", "title", "date", "output", "toc"),
72	10x	must.include = "output"
73		)
74	8x	checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
75
76	7x	shiny::moduleServer(
77	7x	id,
78	7x	function(input, output, session) {
79	7x	ns <- session$ns
80
81	7x	download_modal <- function() {
82	1x	nr_cards <- length(reporter$get_cards())
83	1x	downb <- shiny::tags$a(
84	1x	id = ns("download_data"),
85	1x	class = paste("btn btn-primary shiny-download-link", if (nr_cards) NULL else "disabled"),
86	1x	style = if (nr_cards) NULL else "pointer-events: none;",
87	1x	href = "",
88	1x	target = "_blank",
89	1x	download = NA,
90	1x	shiny::icon("download"),
91	1x	"Download"
92		)
93	1x	shiny::modalDialog(
94	1x	easyClose = TRUE,
95	1x	shiny::tags$h3("Download the Report"),
96	1x	shiny::tags$hr(),
97	1x	if (length(reporter$get_cards()) == 0) {
98	!	shiny::tags$div(
99	!	class = "mb-4",
100	!	shiny::tags$p(
101	!	class = "text-danger",
102	!	shiny::tags$strong("No Cards Added")
103		)
104		)
105		} else {
106	1x	shiny::tags$div(
107	1x	class = "mb-4",
108	1x	shiny::tags$p(
109	1x	class = "text-success",
110	1x	shiny::tags$strong(paste("Number of cards: ", nr_cards))
111		),
112		)
113		},
114	1x	reporter_download_inputs(
115	1x	rmd_yaml_args = rmd_yaml_args,
116	1x	rmd_output = rmd_output,
117	1x	showrcode = any_rcode_block(reporter),
118	1x	session = session
119		),
120	1x	footer = shiny::tagList(
121	1x	shiny::tags$button(
122	1x	type = "button",
123	1x	class = "btn btn-secondary",
124	1x	`data-dismiss` = "modal",
125	1x	`data-bs-dismiss` = "modal",
126	1x	NULL,
127	1x	"Cancel"
128		),
129	1x	downb
130		)
131		)
132		}
133
134	7x	shiny::observeEvent(input$download_button, {
135	1x	shiny::showModal(download_modal())
136		})
137
138	7x	output$download_data <- shiny::downloadHandler(
139	7x	filename = function() {
140	2x	paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
141		},
142	7x	content = function(file) {
143	2x	shiny::showNotification("Rendering and Downloading the document.")
144	2x	shinybusy::block(id = ns("download_data"), text = "", type = "dots")
145	2x	input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
146	2x	names(input_list) <- names(rmd_yaml_args)
147	!	if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
148	2x	report_render_and_compress(reporter, input_list, global_knitr, file)
149	2x	shinybusy::unblock(id = ns("download_data"))
150		},
151	7x	contentType = "application/zip"
152		)
153		}
154		)
155		}
156
157		#' Render the report
158		#'
159		#' Render the report and zip the created directory.
160		#'
161		#' @param reporter (`Reporter`) instance.
162		#' @param input_list (`list`) like `shiny` input converted to a regular named list.
163		#' @param global_knitr (`list`) a global `knitr` parameters, like echo.
164		#' But if local parameter is set it will have priority.
165		#' @param file (`character(1)`) where to copy the returned directory.
166		#'
167		#' @return `file` argument, invisibly.
168		#'
169		#' @keywords internal
170		report_render_and_compress <- function(reporter, input_list, global_knitr, file = tempdir()) {
171	8x	checkmate::assert_class(reporter, "Reporter")
172	8x	checkmate::assert_list(input_list, names = "named")
173	7x	checkmate::assert_string(file)
174
175		if (
176	5x	identical("pdf_document", input_list$output) &&
177	5x	inherits(try(system2("pdflatex", "--version", stdout = TRUE), silent = TRUE), "try-error")
178		) {
179	!	shiny::showNotification(
180	!	ui = "pdflatex is not available so the pdf_document could not be rendered. Please use other output type.",
181	!	action = "Please contact app developer",
182	!	type = "error"
183		)
184	!	stop("pdflatex is not available so the pdf_document could not be rendered.")
185		}
186
187	5x	yaml_header <- as_yaml_auto(input_list)
188	5x	renderer <- Renderer$new()
189
190	5x	tryCatch(
191	5x	renderer$render(reporter$get_blocks(), yaml_header, global_knitr),
192	5x	warning = function(cond) {
193	!	shiny::showNotification(
194	!	ui = "Render document warning!",
195	!	action = "Please contact app developer",
196	!	type = "warning"
197		)
198		},
199	5x	error = function(cond) {
200	!	shiny::showNotification(
201	!	ui = "Render document error!",
202	!	action = "Please contact app developer",
203	!	type = "error"
204		)
205		}
206		)
207
208	5x	temp_zip_file <- tempfile(fileext = ".zip")
209	5x	tryCatch(
210	5x	expr = zip::zipr(temp_zip_file, renderer$get_output_dir()),
211	5x	warning = function(cond) {
212	!	shiny::showNotification(
213	!	ui = "Zipping folder warning!",
214	!	action = "Please contact app developer",
215	!	type = "warning"
216		)
217		},
218	5x	error = function(cond) {
219	!	shiny::showNotification(
220	!	ui = "Zipping folder error!",
221	!	action = "Please contact app developer",
222	!	type = "error"
223		)
224		}
225		)
226
227	5x	tryCatch(
228	5x	expr = file.copy(temp_zip_file, file),
229	5x	warning = function(cond) {
230	!	shiny::showNotification(
231	!	ui = "Copying file warning!",
232	!	action = "Please contact app developer",
233	!	type = "warning"
234		)
235		},
236	5x	error = function(cond) {
237	!	shiny::showNotification(
238	!	ui = "Copying file error!",
239	!	action = "Please contact app developer",
240	!	type = "error"
241		)
242		}
243		)
244
245	5x	rm(renderer)
246	5x	invisible(file)
247		}
248
249		#' Get the custom list of UI inputs
250		#'
251		#' @param rmd_output (`character`) vector with `rmarkdown` output types,
252		#' by default all possible `pdf_document`, `html_document`, `powerpoint_presentation`, and `word_document`.
253		#' If vector is named then those names will appear in the `UI`.
254		#' @param rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their default values.
255		#' This `list` will result in the custom subset of UI inputs for the download reporter functionality.
256		#' Default `list(author = "NEST", title = "Report", date = Sys.Date(), output = "html_document", toc = FALSE)`.
257		#' The `list` must include at least `"output"` field.
258		#' The default value for `"output"` has to be in the `rmd_output` argument.
259		#'
260		#' @keywords internal
261		reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, session) {
262	8x	shiny::tagList(
263	8x	lapply(names(rmd_yaml_args), function(e) {
264	40x	switch(e,
265	8x	author = shiny::textInput(session$ns("author"), label = "Author:", value = rmd_yaml_args$author),
266	8x	title = shiny::textInput(session$ns("title"), label = "Title:", value = rmd_yaml_args$title),
267	8x	date = shiny::dateInput(session$ns("date"), "Date:", value = rmd_yaml_args$date),
268	8x	output = shiny::tags$div(
269	8x	shinyWidgets::pickerInput(
270	8x	inputId = session$ns("output"),
271	8x	label = "Choose a document type: ",
272	8x	choices = rmd_output,
273	8x	selected = rmd_yaml_args$output
274		)
275		),
276	8x	toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc)
277		)
278		}),
279	8x	if (showrcode) {
280	!	shiny::checkboxInput(
281	!	session$ns("showrcode"),
282	!	label = "Include R Code",
283	!	value = FALSE
284		)
285		}
286		)
287		}
288
289		#' @noRd
290		#' @keywords internal
291		any_rcode_block <- function(reporter) {
292	10x	any(
293	10x	vapply(
294	10x	reporter$get_blocks(),
295	10x	function(e) inherits(e, "RcodeBlock"),
296	10x	logical(1)
297		)
298		)
299		}

1		#' Add card button module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Provides a button to add views/cards to a report.
6		#'
7		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
8		#'
9		#' @details
10		#' The `card_fun` function is designed to create a new `ReportCard` instance and optionally customize it:
11		#' - The `card` parameter allows for specifying a custom or default `ReportCard` instance.
12		#' - Use the `comment` parameter to add a comment to the card via `card$append_text()` - if `card_fun` does not
13		#' have the `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the
14		#' card.
15		#' - The `label` parameter enables customization of the card's name and its content through `card$append_text()`-
16		#' if `card_fun` does not have the `label` parameter, then card name will be set to the name passed in
17		#' `Add Card UI` module, but no text will be added to the content of the `card`.
18		#'
19		#' This module supports using a subclass of [`ReportCard`] for added flexibility.
20		#' A subclass instance should be passed as the default value of
21		#' the `card` argument in the `card_fun` function.
22		#' See below:
23		#' ```{r}
24		#' CustomReportCard <- R6::R6Class(
25		#' classname = "CustomReportCard",
26		#' inherit = teal.reporter::ReportCard
27		#' )
28		#'
29		#' custom_function <- function(card = CustomReportCard$new()) {
30		#' card
31		#' }
32		#' ```
33		#' @name add_card_button
34		#'
35		#' @param id (`character(1)`) this `shiny` module's id.
36		#' @param reporter (`Reporter`) instance.
37		#' @param card_fun (`function`) which returns a [`ReportCard`] instance. See `Details`.
38		#'
39		#' @return `NULL`.
40		NULL
41
42		#' @rdname add_card_button
43		#' @export
44		add_card_button_ui <- function(id) {
45	2x	ns <- shiny::NS(id)
46
47		# Buttons with custom css and
48		# js code to disable the add card button when clicked to prevent multi-clicks
49	2x	shiny::tagList(
50	2x	shiny::singleton(
51	2x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
52		),
53	2x	shiny::singleton(
54	2x	shiny::tags$head(
55	2x	shiny::tags$script(
56	2x	shiny::HTML(
57	2x	sprintf(
58		'
59	2x	$(document).ready(function(event) {
60	2x	$("body").on("click", "#%s", function() {
61	2x	$(this).addClass("disabled");
62		})
63		})',
64	2x	ns("add_card_ok")
65		)
66		)
67		)
68		)
69		),
70	2x	shiny::tags$button(
71	2x	id = ns("add_report_card_button"),
72	2x	type = "button",
73	2x	class = "simple_report_button btn btn-primary action-button",
74	2x	title = "Add Card",
75	2x	`data-val` = shiny::restoreInput(id = ns("add_report_card_button"), default = NULL),
76	2x	NULL,
77	2x	shiny::tags$span(
78	2x	shiny::icon("plus")
79		)
80		)
81		)
82		}
83
84		#' @rdname add_card_button
85		#' @export
86		add_card_button_srv <- function(id, reporter, card_fun) {
87	13x	checkmate::assert_function(card_fun)
88	13x	checkmate::assert_class(reporter, "Reporter")
89	13x	checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)
90
91	13x	shiny::moduleServer(
92	13x	id,
93	13x	function(input, output, session) {
94	13x	ns <- session$ns
95	13x	add_modal <- function() {
96	11x	shiny::modalDialog(
97	11x	easyClose = TRUE,
98	11x	shiny::tags$h3("Add a Card to the Report"),
99	11x	shiny::tags$hr(),
100	11x	shiny::textInput(
101	11x	ns("label"),
102	11x	"Card Name",
103	11x	value = "",
104	11x	placeholder = "Add the card title here",
105	11x	width = "100%"
106		),
107	11x	shiny::textAreaInput(
108	11x	ns("comment"),
109	11x	"Comment",
110	11x	value = "",
111	11x	placeholder = "Add a comment here...",
112	11x	width = "100%"
113		),
114	11x	shiny::tags$script(
115	11x	shiny::HTML(
116	11x	sprintf(
117		"
118	11x	$('#shiny-modal').on('shown.bs.modal', () => {
119	11x	$('#%s').focus()
120		})
121		",
122	11x	ns("label")
123		)
124		)
125		),
126	11x	footer = shiny::div(
127	11x	shiny::tags$button(
128	11x	type = "button",
129	11x	class = "btn btn-secondary",
130	11x	`data-dismiss` = "modal",
131	11x	`data-bs-dismiss` = "modal",
132	11x	NULL,
133	11x	"Cancel"
134		),
135	11x	shiny::tags$button(
136	11x	id = ns("add_card_ok"),
137	11x	type = "button",
138	11x	class = "btn btn-primary action-button",
139	11x	`data-val` = shiny::restoreInput(id = ns("add_card_ok"), default = NULL),
140	11x	NULL,
141	11x	"Add Card"
142		)
143		)
144		)
145		}
146
147	13x	shiny::observeEvent(input$add_report_card_button, {
148	11x	shiny::showModal(add_modal())
149		})
150
151		# the add card button is disabled when clicked to prevent multi-clicks
152		# please check the ui part for more information
153	13x	shiny::observeEvent(input$add_card_ok, {
154	11x	card_fun_args_nams <- names(formals(card_fun))
155	11x	has_card_arg <- "card" %in% card_fun_args_nams
156	11x	has_comment_arg <- "comment" %in% card_fun_args_nams
157	11x	has_label_arg <- "label" %in% card_fun_args_nams
158
159	11x	arg_list <- list()
160
161	11x	if (has_comment_arg) {
162	4x	arg_list <- c(arg_list, list(comment = input$comment))
163		}
164	11x	if (has_label_arg) {
165	!	arg_list <- c(arg_list, list(label = input$label))
166		}
167
168	11x	if (has_card_arg) {
169		# The default_card is defined here because formals() returns a pairedlist object
170		# of formal parameter names and their default values. The values are missing
171		# if not defined and the missing check does not work if supplied formals(card_fun)[[1]]
172	8x	default_card <- formals(card_fun)$card
173	8x	card <- `if`(
174	8x	missing(default_card),
175	8x	ReportCard$new(),
176	8x	eval(default_card, envir = environment(card_fun))
177		)
178	8x	arg_list <- c(arg_list, list(card = card))
179		}
180
181	11x	card <- try(do.call(card_fun, arg_list))
182
183	11x	if (inherits(card, "try-error")) {
184	3x	msg <- paste0(
185	3x	"The card could not be added to the report. ",
186	3x	"Have the outputs for the report been created yet? If not please try again when they ",
187	3x	"are ready. Otherwise contact your application developer"
188		)
189	3x	warning(msg)
190	3x	shiny::showNotification(
191	3x	msg,
192	3x	type = "error"
193		)
194		} else {
195	8x	checkmate::assert_class(card, "ReportCard")
196	8x	if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
197	1x	card$append_text("Comment", "header3")
198	1x	card$append_text(input$comment)
199		}
200
201	8x	if (!has_label_arg && length(input$label) == 1 && input$label != "") {
202	!	card$set_name(input$label)
203		}
204
205	8x	reporter$append_cards(list(card))
206	8x	shiny::showNotification(sprintf("The card added successfully."), type = "message")
207	8x	shiny::removeModal()
208		}
209		})
210		}
211		)
212		}

1		#' @title `PictureBlock`
2		#' @docType class
3		#' @description
4		#' Specialized `FileBlock` for managing picture content in reports.
5		#' It's designed to handle plots from packages such as `ggplot2`, `grid`, or `lattice`.
6		#' It can save plots to files, set titles and specify dimensions.
7		#'
8		#' @keywords internal
9		PictureBlock <- R6::R6Class( # nolint: object_name_linter.
10		classname = "PictureBlock",
11		inherit = FileBlock,
12		public = list(
13		#' @description Initialize a `PictureBlock` object.
14		#'
15		#' @param plot (`ggplot` or `grid`) a picture in this `PictureBlock`
16		#'
17		#' @return Object of class `PictureBlock`, invisibly.
18		initialize = function(plot) {
19	52x	if (!missing(plot)) {
20	!	self$set_content(plot)
21		}
22	52x	invisible(self)
23		},
24		#' @description Sets the content of this `PictureBlock`.
25		#'
26		#' @details Raises error if argument is not a `ggplot`, `grob` or `trellis` plot.
27		#'
28		#' @param content (`ggplot` or `grob` or `trellis`) a picture in this `PictureBlock`
29		#'
30		#' @return `self`, invisibly.
31		#' @examples
32		#' library(ggplot2)
33		#' library(lattice)
34		#'
35		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
36		#' block <- PictureBlock$new()
37		#' block$set_content(ggplot(iris))
38		#'
39		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
40		#' block <- PictureBlock$new()
41		#' block$set_content(bwplot(1))
42		#'
43		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
44		#' block <- PictureBlock$new()
45		#' block$set_content(ggplotGrob(ggplot(iris)))
46		set_content = function(content) {
47	31x	checkmate::assert_multi_class(content, private$supported_plots)
48	29x	path <- tempfile(fileext = ".png")
49	29x	grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
50	29x	tryCatch(
51	29x	expr = {
52	29x	if (inherits(content, "grob")) {
53	1x	grid::grid.newpage()
54	1x	grid::grid.draw(content)
55	28x	} else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
56	27x	print(content)
57	1x	} else if (inherits(content, "trellis")) {
58	1x	grid::grid.newpage()
59	1x	grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
60		}
61	29x	super$set_content(path)
62		},
63	29x	finally = grDevices::dev.off()
64		)
65	29x	invisible(self)
66		},
67		#' @description Sets the title of this `PictureBlock`.
68		#'
69		#' @details Raises error if argument is not `character(1)`.
70		#'
71		#' @param title (`character(1)`) a string assigned to this `PictureBlock`
72		#'
73		#' @return `self`, invisibly.
74		#' @examples
75		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
76		#' block <- PictureBlock$new()
77		#' block$set_title("Title")
78		#'
79		set_title = function(title) {
80	5x	checkmate::assert_string(title)
81	4x	private$title <- title
82	4x	invisible(self)
83		},
84		#' @description Get the title of this `PictureBlock`.
85		#'
86		#' @return The content of this `PictureBlock`.
87		#' @examples
88		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
89		#' block <- PictureBlock$new()
90		#' block$get_title()
91		#'
92		get_title = function() {
93	9x	private$title
94		},
95		#' @description Sets the dimensions of this `PictureBlock`.
96		#'
97		#' @param dim (`numeric(2)`) figure dimensions (width and height) in pixels.
98		#'
99		#' @return `self`, invisibly.
100		#' @examples
101		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
102		#' block <- PictureBlock$new()
103		#' block$set_dim(c(800, 600))
104		#'
105		set_dim = function(dim) {
106	6x	checkmate::assert_numeric(dim, len = 2)
107	4x	private$dim <- dim
108	4x	invisible(self)
109		},
110		#' @description Get `PictureBlock` dimensions as a numeric vector.
111		#'
112		#' @return `numeric` the array of 2 numeric values representing width and height in pixels.
113		#' @examples
114		#' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
115		#' block <- PictureBlock$new()
116		#' block$get_dim()
117		get_dim = function() {
118	!	private$dim
119		}
120		),
121		private = list(
122		supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
123		type = character(0),
124		title = "",
125		dim = c(800, 600)
126		),
127		lock_objects = TRUE,
128		lock_class = TRUE
129		)

1		#' Simple reporter module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Module provides compact UI and server functions for managing a report in a `shiny` app.
6		#' This module combines functionalities for [adding cards to a report][add_card_button],
7		#' [downloading the report][download_report_button], and [resetting report content][reset_report_button].
8		#'
9		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
10		#'
11		#' @details `r global_knitr_details()`
12		#'
13		#' @name simple_reporter
14		#'
15		#' @param id (`character(1)`) `shiny` module instance id.
16		#' @param reporter (`Reporter`) instance.
17		#' @param card_fun (`function`) which returns a [`ReportCard`] instance,
18		#' the function has a `card` argument and an optional `comment` argument.
19		#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
20		#' @inheritParams reporter_download_inputs
21		#'
22		#' @return `NULL`.
23		#'
24		#' @examples
25		#' library(shiny)
26		#' if (interactive()) {
27		#' shinyApp(
28		#' ui = fluidPage(simple_reporter_ui("simple")),
29		#' server = function(input, output, session) {
30		#' simple_reporter_srv("simple", Reporter$new(), function(card) card)
31		#' }
32		#' )
33		#' }
34		NULL
35
36		#' @rdname simple_reporter
37		#' @export
38		simple_reporter_ui <- function(id) {
39	1x	ns <- shiny::NS(id)
40	1x	shiny::tagList(
41	1x	shiny::singleton(
42	1x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
43		),
44	1x	shiny::tags$div(
45	1x	class = "block mb-4 p-1",
46	1x	shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
47	1x	shiny::tags$div(
48	1x	class = "simple_reporter_container",
49	1x	add_card_button_ui(ns("add_report_card_simple")),
50	1x	download_report_button_ui(ns("download_button_simple")),
51	1x	reset_report_button_ui(ns("reset_button_simple"))
52		)
53		)
54		)
55		}
56
57		#' @rdname simple_reporter
58		#' @export
59		simple_reporter_srv <- function(id,
60		reporter,
61		card_fun,
62		global_knitr = getOption("teal.reporter.global_knitr"),
63		rmd_output = c(
64		"html" = "html_document", "pdf" = "pdf_document",
65		"powerpoint" = "powerpoint_presentation", "word" = "word_document"
66		),
67		rmd_yaml_args = list(
68		author = "NEST", title = "Report",
69		date = as.character(Sys.Date()), output = "html_document",
70		toc = FALSE
71		)) {
72	3x	shiny::moduleServer(
73	3x	id,
74	3x	function(input, output, session) {
75	3x	add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
76	3x	download_report_button_srv(
77	3x	"download_button_simple",
78	3x	reporter = reporter,
79	3x	global_knitr = global_knitr,
80	3x	rmd_output = rmd_output,
81	3x	rmd_yaml_args = rmd_yaml_args
82		)
83	3x	reset_report_button_srv("reset_button_simple", reporter = reporter)
84		}
85		)
86		}

1		#' @title `NewpageBlock`
2		#' @docType class
3		#' @description
4		#' A `ContentBlock` subclass that represents a page break in a report output.
5		#'
6		#' @keywords internal
7		NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
8		classname = "NewpageBlock",
9		inherit = ContentBlock,
10		public = list(
11		#' @description Initialize a `NewpageBlock` object.
12		#'
13		#' @details Returns a `NewpageBlock` object with no content and the default style.
14		#'
15		#' @return Object of class `NewpageBlock`, invisibly.
16		#' @examples
17		#' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
18		#' block <- NewpageBlock$new()
19		#'
20		initialize = function() {
21	18x	super$set_content("\n\\newpage\n")
22	18x	invisible(self)
23		}
24		),
25		lock_objects = TRUE,
26		lock_class = TRUE
27		)

1		#' @title `FileBlock`
2		#' @docType class
3		#' @description
4		#' `FileBlock` manages file-based content in a report,
5		#' ensuring appropriate handling of content files.
6		#'
7		#' @keywords internal
8		FileBlock <- R6::R6Class( # nolint: object_name_linter.
9		classname = "FileBlock",
10		inherit = ContentBlock,
11		public = list(
12		#' @description Finalize the `FileBlock`.
13		#'
14		#' @details Removes the temporary file created in the constructor.
15		finalize = function() {
16	97x	try(unlink(super$get_content()))
17		},
18		#' @description Create the `FileBlock` from a list.
19		#' The list should contain one named field, `"basename"`.
20		#'
21		#' @param x (`named list`) with one field `"basename"`, a name of the file.
22		#' @param output_dir (`character`) with a path to the directory where a file will be copied.
23		#'
24		#' @return `self`, invisibly.
25		#' @examples
26		#' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
27		#' block <- FileBlock$new()
28		#' file_path <- tempfile(fileext = ".png")
29		#' saveRDS(iris, file_path)
30		#' block$from_list(list(basename = basename(file_path)), dirname(file_path))
31		#'
32		from_list = function(x, output_dir) {
33	28x	checkmate::assert_list(x)
34	28x	checkmate::assert_names(names(x), must.include = "basename")
35	28x	path <- file.path(output_dir, x$basename)
36	28x	file_type <- paste0(".", tools::file_ext(path))
37	28x	checkmate::assert_file_exists(path, extension = file_type)
38	28x	new_file_path <- tempfile(fileext = file_type)
39	28x	file.copy(path, new_file_path)
40	28x	super$set_content(new_file_path)
41	28x	invisible(self)
42		},
43		#' @description Convert the `FileBlock` to a list.
44		#'
45		#' @param output_dir (`character`) with a path to the directory where a file will be copied.
46		#'
47		#' @return `named list` with a `basename` of the file.
48		#' @examples
49		#' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
50		#' block <- FileBlock$new()
51		#' block$to_list(tempdir())
52		#'
53		to_list = function(output_dir) {
54	18x	base_name <- basename(super$get_content())
55	18x	file.copy(super$get_content(), file.path(output_dir, base_name))
56	18x	list(basename = base_name)
57		}
58		),
59		lock_objects = TRUE,
60		lock_class = TRUE
61		)

1		#' @title `TextBlock`
2		#' @docType class
3		#' @description
4		#' Specialized `ContentBlock` for embedding styled text within reports.
5		#' It supports multiple styling options to accommodate various text roles,
6		#' such as headers or verbatim text, in the report content.
7		#'
8		#' @keywords internal
9		TextBlock <- R6::R6Class( # nolint: object_name_linter.
10		classname = "TextBlock",
11		inherit = ContentBlock,
12		public = list(
13		#' @description Initialize a `TextBlock` object.
14		#'
15		#' @details Constructs a `TextBlock` object with no content and the default style.
16		#'
17		#' @param content (`character`) a string assigned to this `TextBlock`
18		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
19		#'
20		#' @return Object of class `TextBlock`, invisibly.
21		#' @examples
22		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
23		#' block <- TextBlock$new()
24		#'
25		initialize = function(content = character(0), style = private$styles[1]) {
26	130x	super$set_content(content)
27	130x	self$set_style(style)
28	130x	invisible(self)
29		},
30		#' @description Sets the style of this `TextBlock`.
31		#'
32		#' @details The style has bearing on the rendering of this block.
33		#'
34		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
35		#'
36		#' @return `self`, invisibly.
37		#' @examples
38		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
39		#' block <- TextBlock$new()
40		#' block$set_style("header2")
41		#'
42		set_style = function(style) {
43	174x	private$style <- match.arg(style, private$styles)
44	173x	invisible(self)
45		},
46		#' @description Get the style of this `TextBlock`.
47		#'
48		#' @return `character(1)` the style of this `TextBlock`.
49		#' @examples
50		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
51		#' block <- TextBlock$new()
52		#' block$get_style()
53		#'
54		get_style = function() {
55	59x	private$style
56		},
57		#' @description Get available an array of styles available to this `TextBlock`.
58		#'
59		#' @return A `character` array of styles.
60		#' @examples
61		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
62		#' block <- TextBlock$new()
63		#' block$get_available_styles()
64		#'
65		get_available_styles = function() {
66	23x	private$styles
67		},
68		#' @description Create the `TextBlock` from a list.
69		#'
70		#' @param x (`named list`) with two fields `text` and `style`.
71		#' Use the `get_available_styles` method to get all possible styles.
72		#'
73		#' @return `self`, invisibly.
74		#' @examples
75		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
76		#' block <- TextBlock$new()
77		#' block$from_list(list(text = "sth", style = "default"))
78		#'
79		from_list = function(x) {
80	36x	checkmate::assert_list(x)
81	36x	checkmate::assert_names(names(x), must.include = c("text", "style"))
82	36x	self$set_content(x$text)
83	36x	self$set_style(x$style)
84	36x	invisible(self)
85		},
86		#' @description Convert the `TextBlock` to a list.
87		#'
88		#' @return `named list` with a text and style.
89		#' @examples
90		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
91		#' block <- TextBlock$new()
92		#' block$to_list()
93		#'
94		to_list = function() {
95	16x	list(text = self$get_content(), style = self$get_style())
96		}
97		),
98		private = list(
99		style = character(0),
100		styles = c("default", "header2", "header3", "verbatim")
101		),
102		lock_objects = TRUE,
103		lock_class = TRUE
104		)

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		}