teal.reporter coverage - 77.57%

Files
Source

.content_to_rmd <- function(block, ...) {
  path <- basename(tempfile(pattern = "report_item_", fileext = ".rds"))
  suppressWarnings(saveRDS(block, file = path))
  sprintf("```{r echo = FALSE, eval = TRUE}\nreadRDS('%s')\n```", path)
}

.plot_to_rmd <- function(block, ...) {
  path <- basename(tempfile(pattern = "report_item_", fileext = ".rds"))
  suppressWarnings(saveRDS(block, file = path))
  dims <- .determine_default_dimensions(block, convert_to_inches = TRUE)

  chunk <- if (inherits(block, "grob")) {
    "```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\n._figure <- readRDS('%s')\ngrid::grid.newpage()\ngrid::grid.draw(._figure)\n```" # nolint line_length_linter.
  } else {
    "```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```"
  }

  sprintf(
    chunk,
    dims$width,
    dims$height,
    path
  )
}

#' Convert `ReporterCard`/`teal_card` content to `rmarkdown`
#'
#' This is an S3 generic that is used to generate content in `rmarkdown` format
#' from various types of blocks in a `ReporterCard` or `teal_card` object.
#'
#' # Customize `to_rmd`
#' The methods for this S3 generic can be extended by the app developer or even overwritten.
#' For this a function with the name `to_rmd.<class>` should be defined in the
#' Global Environment, where `<class>` is the class of the object to be converted.
#'
#' For example, to override the default behavior for `code_chunk` class, you can use:
#'
#' ```r
#' to_rmd.code_chunk <- function(block, ..., output_format) {
#'   # custom implementation
#'   sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block)
#' }
#' ```
#'
#' Alternatively, you can register the S3 method using `registerS3method("to_rmd", "<class>", fun)`
#'
#' @param block (`any`) content which can be represented in Rmarkdown syntax.
#' @return `character(1)` containing a content or Rmarkdown document.
#' @keywords internal
to_rmd <- function(block, ...) {
  UseMethod("to_rmd")
}

#' @method to_rmd default
#' @keywords internal
to_rmd.default <- function(block, ...) {
  .to_rmd(block, ...)
}

.to_rmd <- function(block, ...) {
  UseMethod(".to_rmd")
}

#' @method .to_rmd default
#' @keywords internal
.to_rmd.default <- function(block, ...) {
  block
}

#' @method .to_rmd teal_report
#' @keywords internal
.to_rmd.teal_report <- function(block, ...) {
  to_rmd(teal_card(block), ...)
}

#' @method .to_rmd teal_card
#' @keywords internal
.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation")
  powerpoint_exception_parsed <- if (is_powerpoint) {
    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
      }
    )
    deparse1(format_code_block_function, collapse = "\n")
  } else {
    NULL
  }
  global_knitr_parsed <- sprintf(
    "knitr::opts_chunk$set(%s)",
    paste(utils::capture.output(dput(global_knitr)), collapse = "")
  )
  global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE)

  m_yaml <- metadata(block)
  if ("SRC" %in% names(m_yaml)) {
    m_yaml$SRC <- NULL # TODO: remove when *Block functions are removed from `previewer_deprecated.R`
  }
  paste(
    c(
      if (length(m_yaml)) as_yaml_auto(m_yaml),
      if (length(global_knitr) || is_powerpoint) to_rmd(global_knitr_code_chunk),
      unlist(lapply(
        block,
        function(x) to_rmd(x, output_format = m_yaml$output, ...)
      ))
    ),
    collapse = "\n\n"
  )
}

#' @method .to_rmd code_chunk
#' @keywords internal
.to_rmd.code_chunk <- function(block, ..., output_format = NULL) {
  params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l)
  block_str <- format(block)
  lang <- attr(block, "lang", exact = TRUE)
  if (identical(output_format, "powerpoint_presentation")) {
    block_content_list <- lapply(
      split_text_block(block, 30),
      function(x, lang) {
        code_block <- sprintf("code_block(\n%s)", shQuote(x, type = "cmd"))
        format(code_chunk(code_block, echo = FALSE, lang = lang))
      },
      lang = lang
    )
    paste(sprintf("\\newpage\n\n---\n\n%s\n", block_content_list), collapse = "\n\n")
  } else {
    format(block)
  }
}

#' @method .to_rmd character
#' @keywords internal
.to_rmd.character <- function(block, ...) {
  block
}

#' @method .to_rmd chunk_output
#' @keywords internal
.to_rmd.chunk_output <- function(block, ..., include_chunk_output) {
  if (!missing(include_chunk_output) && isTRUE(include_chunk_output)) {
    new_block <- block[[1]]
    mostattributes(new_block) <- c(attributes(unclass(block)), attributes(new_block))
    to_rmd(new_block, ..., include_chunk_output = include_chunk_output)
  }
}

#' @method .to_rmd condition
#' @keywords internal
.to_rmd.condition <- function(block, ...) {
  conditionMessage(block)
}

#' @method .to_rmd gg
#' @keywords internal
.to_rmd.gg <- .plot_to_rmd

#' @method .to_rmd trellis
#' @keywords internal
.to_rmd.trellis <- .plot_to_rmd

#' @method .to_rmd recordedplot
#' @keywords internal
.to_rmd.recordedplot <- .plot_to_rmd

#' @method .to_rmd grob
#' @keywords internal
.to_rmd.grob <- .plot_to_rmd

#' @method .to_rmd Heatmap
#' @keywords internal
.to_rmd.Heatmap <- .plot_to_rmd

#' @method .to_rmd datatables
#' @keywords internal
.to_rmd.datatables <- .content_to_rmd

#' @method .to_rmd summary.lm
#' @keywords internal
.to_rmd.summary.lm <- .content_to_rmd

#' @method .to_rmd rtables
#' @keywords internal
.to_rmd.rtables <- function(block, ...) {
  flextable_block <- to_flextable(block)
  attr(flextable_block, "keep") <- attr(block, "keep")
  to_rmd(flextable_block, ...)
}

#' @method .to_rmd flextable
#' @keywords internal
.to_rmd.flextable <- .content_to_rmd

#' @method .to_rmd TableTree
#' @keywords internal
.to_rmd.TableTree <- .to_rmd.rtables

#' @method .to_rmd ElementaryTable
#' @keywords internal
.to_rmd.ElementaryTable <- .to_rmd.rtables

#' @method .to_rmd rlisting
#' @keywords internal
.to_rmd.rlisting <- .to_rmd.rtables

#' @method .to_rmd data.frame
#' @keywords internal
.to_rmd.data.frame <- .to_rmd.rtables

#' @method .to_rmd gtsummary
#' @keywords internal
.to_rmd.gtsummary <- function(block, ...) {
  to_rmd(gtsummary::as_flex_table(block), ...)
}

#' @method .to_rmd listing_df
#' @keywords internal
.to_rmd.listing_df <- function(block, ...) {
  to_rmd(flextable::as_flextable(block), ...)
}

#' @method .to_rmd ContentBlock
#' @keywords internal
.to_rmd.ContentBlock <- function(block, ...) {
  to_rmd(block$get_content(), ...)
}

#' @method .to_rmd RcodeBlock
#' @keywords internal
.to_rmd.RcodeBlock <- function(block, ...) {
  to_rmd(code_chunk(block$get_content(), lang = "R"), ...)
}

#' @title `ReportCard`: An `R6` class for building report elements
#' @docType class
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' 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.
#'
#' @section Lifecycle:
#' This class is deprecated. Use `teal_report` class instead for new implementations.
#' See `vignette("teal-report-class", "teal.reporter")` for more information.
#'
#' @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() {
      lifecycle::deprecate_warn(
        when = "0.6.0",
        what = "ReportCard$new()",
        with = "teal_card()",
        details = "Use teal_report class instead. See vignette('teal-report-class', 'teal.reporter') for more information." # nolint: line_length_linter.
      )
      private$content <- teal_card()
      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(table),
    #' @description Appends a html content to this `ReportCard`.
    #'
    #' @param content An object that can be rendered as a HTML content.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_html(shiny::div("HTML Content"))
    #'
    append_html = function(content) self$append_content(content),
    #' @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.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    append_plot = function(plot, dim = NULL) {
      checkmate::assert_numeric(dim, len = 2, any.missing = FALSE, null.ok = TRUE)
      if (!is.null(dim)) {
        if (!inherits(plot, "chunk_output")) {
          plot <- structure(list(plot), class = c("chunk_output"))
        }
        attr(plot, "dev.width") <- dim[1]
        attr(plot, "dev.height") <- dim[2]
      }
      self$append_content(plot)
    },
    #' @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.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_text("A paragraph of default text")
    #'
    append_text = function(text, style = c("default", "header2", "header3", "verbatim")) {
      styled <- switch(match.arg(style),
        "default" = text,
        "verbatim" = sprintf("\n```\n%s\n```\n", text),
        "header2" = paste0("## ", text),
        "header3" = paste0("### ", text),
        text
      )
      self$append_content(styled)
    },
    #' @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(code_chunk(code = text, lang = "R", ...))
    },
    #' @description Appends a generic content to this `ReportCard`.
    #'
    #' @param content (Object.)
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_content(code_chunk("foo <- 2"))
    #'
    append_content = function(content) {
      private$content <- c(private$content, content)
      invisible(self)
    },
    #' @description Get all content blocks from this `ReportCard`.
    #'
    #' @return `teal_card()` containing appended elements.
    #' @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 <- teal_card()
      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() {
      metadata(private$content)
    },
    #' @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.
    #' @examplesIf require("ggplot2")
    #' 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(metadata(private$content)))
      metadata(private$content, key) <- value
      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() {
      metadata(private$content, "title") %||% character(0L)
    },
    #' @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) {
      metadata(private$content, "title") <- name
      invisible(self)
    },
    #' @description Set content block names for compatibility with newer `teal_card`
    #' @param new_names (`character`) vector of new names.
    set_content_names = function(new_names) {
      names(private$content) <- new_names
    },
    #' @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.
    #' @examplesIf require("ggplot2")
    #' 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 = lifecycle::deprecated()) {
      if (lifecycle::is_present(output_dir)) {
        lifecycle::deprecate_soft("0.6.0", "ReportCard$to_list(output_dir)")
      }
      private$content
    },
    #' @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.
    #' @examplesIf require("ggplot2")
    #' 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 = lifecycle::deprecated()) {
      if (lifecycle::is_present(output_dir)) {
        lifecycle::deprecate_soft("0.6.0", "ReportCard$to_list(output_dir)")
      }
      self$reset()
      private$content <- card
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    name = character(0L),
    id = character(0L),
    # @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") {
        content <- Reduce(
          f = function(result, this) {
            if (inherits(this, "R6")) {
              this <- this$clone(deep = TRUE)
            }
            c(result, this)
          },
          init = teal_card(),
          x = value
        )

        metadata(content) <- metadata(value)
        content
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @export
length.ReportCard <- function(x) {
  length(x$get_content())
}

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

# deprecated ------------------------------------------------------------------------------------------------------

#' Report previewer module
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' 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.
#'
#' Cards are saved by the `shiny` bookmarking mechanism.
#'
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#'
#' This function is deprecated and will be removed in the next release.
#' Please use `preview_report_button_ui()` and `preview_report_button_srv()`
#' to create a preview button that opens a modal with the report preview.
#'
#' @details `r global_knitr_details()`
#'
#' @name reporter_previewer_deprecated
#'
#' @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.
#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible
#' values and `"download"` is required.
#' Default `c("download", "load", "reset")`
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
NULL

#' @rdname reporter_previewer_deprecated
#' @export
reporter_previewer_ui <- function(id) {
  ns <- shiny::NS(id)
  lifecycle::deprecate_soft(
    when = "0.6.0",
    what = "reporter_previewer_ui()",
    details = paste(
      "Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n",
      "Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,",
      "and `preview_report_button_ui()` instead."
    )
  )
  bslib::page_fluid(
    shiny::tagList(
      shinyjs::useShinyjs(),
      shiny::singleton(
        shiny::tags$head(
          shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")),
          shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter"))
        )
      ),

      # Extend shinyjs::js to include function defined in extendShinyJs.js
      shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
      shiny::tags$div(
        class = "well",
        style = "display: inline-flex; flex-direction: row; gap: 10px;",
        shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")),
        shiny::tags$span(
          id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report")
        ),
        shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report"))
      ),
      shiny::tags$div(reporter_previewer_content_ui(ns("previewer")))
    )
  )
}

#' @rdname reporter_previewer_deprecated
#' @export
reporter_previewer_srv <- function(id,
                                   reporter,
                                   global_knitr = getOption("teal.reporter.global_knitr"),
                                   rmd_output = getOption("teal.reporter.rmd_output"),
                                   rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"),
                                   previewer_buttons = c("download", "load", "reset")) {
  lifecycle::deprecate_soft(
    when = "0.6.0",
    what = "reporter_previewer_srv()",
    details = paste(
      "Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n",
      "Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,",
      "and `preview_report_button_srv()` instead."
    )
  )
  checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE)
  checkmate::assert_true("download" %in% previewer_buttons)
  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) {
    if (!"load" %in% previewer_buttons) {
      shinyjs::hide(id = "load_span")
    }
    if (!"download" %in% previewer_buttons) {
      shinyjs::hide(id = "download_span")
    }
    if (!"reset" %in% previewer_buttons) {
      shinyjs::hide(id = "reset_span")
    }
    report_load_srv("load", reporter = reporter)
    download_report_button_srv(
      "download",
      reporter = reporter,
      global_knitr = global_knitr,
      rmd_output = rmd_output,
      rmd_yaml_args = rmd_yaml_args
    )
    reset_report_button_srv("reset", reporter = reporter)
    reporter_previewer_content_srv("previewer", reporter = reporter)
  })
}

#' @noRd
ContentBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "ContentBlock",
  public = list(
    set_content = function(content) {
      private$content <- content
      invisible(self)
    },
    get_content = function() private$content,
    from_list = function(x) invisible(self),
    to_list = function() list()
  ),
  private = list(
    content = NULL,
    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
)

#' @noRd
RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "RcodeBlock",
  inherit = ContentBlock,
  public = list(
    initialize = function(content = character(0), ...) {
      checkmate::assert_class(content, "character")
      super$set_content(content)
      self$set_params(list(...))
      invisible(self)
    },
    set_content = function(content) {
      checkmate::assert_string(content)
      super$set_content(content)
    },
    set_params = function(params) {
      checkmate::assert_list(params, names = "named")
      checkmate::assert_subset(names(params), self$get_available_params())
      private$params <- params
      invisible(self)
    },
    get_params = function() private$params,
    get_available_params = function() names(knitr::opts_chunk$get()),
    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)
    },
    to_list = function() list(text = self$get_content(), params = self$get_params())
  ),
  private = list(
    content = character(0),
    params = list()
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @noRd
TextBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TextBlock",
  inherit = ContentBlock,
  public = list(
    initialize = function(content = character(0), style = private$styles[1]) {
      super$set_content(content)
      self$set_style(style)
      invisible(self)
    },
    set_content = function(content) {
      checkmate::assert_string(content)
      super$set_content(content)
    },
    get_content = function() {
      if (private$style == "verbatim") {
        return(sprintf("```\n%s\n```\n", private$content))
      }
      sprintf(
        "%s%s",
        switch(private$style,
          header2 = "## ",
          header3 = "### ",
          ""
        ),
        private$content
      )
    },
    set_style = function(style) {
      private$style <- match.arg(style, private$styles)
      invisible(self)
    },
    get_style = function() private$style,
    get_available_styles = function() private$styles,
    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)
    },
    to_list = function() list(text = self$get_content(), style = self$get_style())
  ),
  private = list(
    content = character(0),
    style = character(0),
    styles = c("default", "header2", "header3", "verbatim")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Add card button module
#'
#' @description
#'
#' 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 `teal_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 `teal_card`.
#'
#' This module supports using a subclass of [`ReportCard`] for added flexibility.
#' A subclass instance should be passed as the default value of
#' the `teal_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 label (`character(1)`) label of the button. By default it is empty.
#' @param card_fun (`function`) which returns a [`ReportCard`] instance. See `Details`.
#' @param card_title (`character(1)`) default value for the card title input field. By default it is empty.
#'
#' @return `NULL`.
NULL

#' @rdname add_card_button
#' @export
add_card_button_ui <- function(id, label = NULL) {
  checkmate::assert_string(label, null.ok = TRUE)
  .action_button_busy(
    shiny::NS(id, "add_report_card_button"),
    icon = "plus-lg",
    label = label,
    type = "primary",
    outline = TRUE
  )
}

#' @rdname add_card_button
#' @export
add_card_button_srv <- function(id, reporter, card_fun, card_title = "") {
  checkmate::assert_function(card_fun)
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_string(card_title)
  checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)

  shiny::moduleServer(id, function(input, output, session) {
    shiny::setBookmarkExclude(c(
      "add_report_card_button", "download_button", "reset_reporter",
      "add_card_ok", "download_data", "reset_reporter_ok",
      "label", "comment"
    ))

    ns <- session$ns

    title_r <- shiny::reactiveVal(card_title)
    shiny::observeEvent(input$label, title_r(input$label))

    add_modal <- function() {
      shiny::div(
        class = "teal-reporter reporter-modal",
        .custom_css_dependency(),
        shiny::modalDialog(
          easyClose = TRUE,
          shiny::tags$h3("Add a Card to the Report"),
          shiny::tags$hr(),
          shiny::textInput(
            ns("label"),
            "Card Title",
            value = shiny::isolate(title_r()),
            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("shinyjs.autoFocusModal('%s');", ns("label")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("label"), ns("add_card_ok")) # See extendShinyJs.js
            )
          ),
          footer = shiny::div(
            shiny::tags$button(
              type = "button",
              class = "btn btn-outline-secondary",
              `data-bs-dismiss` = "modal",
              NULL,
              "Dismiss"
            ),
            shiny::tags$button(
              id = ns("add_card_ok"),
              type = "button",
              class = "btn btn-primary action-button",
              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 = title_r()))
      }

      shinyjs::disable("add_card_ok")

      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"
        )
        shinyjs::enable("add_card_ok")
      } else {
        checkmate::assert_multi_class(card, c("ReportCard", "teal_card"))
        if (inherits(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(title_r()) == 1 && title_r() != "") {
            card$set_name(title_r())
          }
        } else if (inherits(card, "teal_card")) {
          if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
            card <- c(card, "### Comment", input$comment)
          }
          if (!has_label_arg && length(title_r()) == 1 && title_r() != "") {
            metadata(card, "title") <- title_r()
          }
        }

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

#' Download report button module
#'
#' @description
#'
#' 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 label (`character(1)`) label before the icon. By default `NULL`.
#' @param reporter (`Reporter`) instance.
#' @param label (`character(1)`) label of the button. By default it is empty.
#' @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, label = NULL) {
  checkmate::assert_string(label, null.ok = TRUE)
  .action_button_busy(
    shiny::NS(id, "download_button"),
    label = label,
    icon = "download",
    outline = TRUE
  )
}

#' @rdname download_report_button
#' @export
download_report_button_srv <- function(id,
                                       reporter,
                                       global_knitr = getOption("teal.reporter.global_knitr"),
                                       rmd_output = getOption("teal.reporter.rmd_output"),
                                       rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")) {
  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) {
    shiny::setBookmarkExclude(c("download_button"))

    ns <- session$ns

    download_modal <- function() {
      nr_cards <- length(reporter$get_cards())
      downb <- shiny::downloadButton(
        outputId = ns("download_data"),
        label = "Download",
        class = c(
          "btn", "teal-reporter", "download-ok", "btn-primary", "shiny-download-link",
          if (nr_cards == 0) "disabled"
        ),
        icon = shiny::icon("download")
      )
      shiny::tags$div(
        class = "teal-reporter reporter-modal",
        .custom_css_dependency(),
        shiny::modalDialog(
          easyClose = TRUE,
          shiny::tags$h3("Download the Report"),
          shiny::tags$hr(),
          if (length(reporter$get_cards()) == 0) {
            shiny::tags$div(
              shiny::tags$p(
                class = "text-danger",
                shiny::tags$strong("No Cards Added")
              ),
              shiny::tags$br()
            )
          } else {
            shiny::tags$div(
              shiny::tags$p(
                class = "text-success",
                shiny::tags$strong(paste("Number of cards: ", nr_cards))
              ),
              shiny::tags$br()
            )
          },
          reporter_download_inputs(
            rmd_yaml_args = rmd_yaml_args,
            rmd_output = rmd_output,
            showrcode = any_rcode_block(reporter),
            session = session
          ),
          shiny::tags$script(
            shiny::HTML(
              sprintf("shinyjs.autoFocusModal('%s');", ns("author")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("author"), ns("download_data")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("title"), ns("download_data")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("date"), ns("download_data")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("output"), ns("download_data")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("toc"), ns("download_data")), # See extendShinyJs.js
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("showrcode"), ns("download_data")) # See extendShinyJs.js
            )
          ),
          footer = shiny::tagList(
            shiny::tags$button(
              type = "button",
              class = "btn btn-outline-secondary",
              `data-bs-dismiss` = "modal",
              NULL,
              "Dismiss"
            ),
            shiny::tags$a(
              id = ns("download_data"),
              class = "btn btn-primary shiny-download-link",
              href = "",
              target = "_blank",
              download = NA,
              shiny::icon("download"),
              "Download"
            )
          )
        )
      )
    }

    shiny::observeEvent(reporter$get_cards(), {
      shinyjs::toggleState(length(reporter$get_cards()) > 0, id = "download_button")
    })

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

    output$download_data <- shiny::downloadHandler(
      filename = function() paste0(.report_identifier(reporter), ".zip"),
      content = function(file) {
        shiny::showNotification("Rendering and Downloading the document.")
        shinybusy::block(id = ns("download_data"), text = "", type = "dots")
        rmd_yaml_with_inputs <- lapply(names(rmd_yaml_args), function(x) input[[x]])
        names(rmd_yaml_with_inputs) <- names(rmd_yaml_args)
        if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
        report_render_and_compress(
          reporter = reporter,
          rmd_yaml_args = rmd_yaml_with_inputs,
          global_knitr = global_knitr,
          file = 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 rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their values.
#' @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 created zip file.
#'
#' @return `file` argument, invisibly.
#'
#' @keywords internal
report_render_and_compress <- function(reporter, rmd_yaml_args, global_knitr, file = tempfile()) {
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_list(rmd_yaml_args, names = "named")
  checkmate::assert_string(file)

  tmp_dir <- file.path(tempdir(), .report_identifier(reporter))

  cards_combined <- reporter$get_blocks()
  metadata(cards_combined) <- utils::modifyList(metadata(cards_combined), rmd_yaml_args)

  tryCatch(
    render(
      input = cards_combined,
      output_dir = tmp_dir,
      global_knitr = global_knitr,
      quiet = TRUE
    ),
    warning = function(cond) message("Render document warning: ", cond),
    error = function(cond) {
      message("Render document error: ", cond)
      do.call("return", args = list(), envir = parent.frame(2))
    }
  )

  tryCatch(
    reporter$to_jsondir(tmp_dir),
    warning = function(cond) message("Archive document warning: ", cond),
    error = function(cond) message("Archive document error: ", cond)
  )

  tryCatch(
    reporter$write_figures(tmp_dir),
    warning = function(cond) message("Save reporter images warning: ", cond),
    error = function(cond) message("Save reporter images error: ", cond)
  )

  temp_zip_file <- tempfile(fileext = ".zip")
  tryCatch(
    zip::zipr(temp_zip_file, tmp_dir),
    warning = function(cond) message("Zipping folder warning: ", cond),
    error = function(cond) message("Zipping folder error: ", cond)
  )

  tryCatch(
    {
      file.copy(temp_zip_file, file)
      unlink(tmp_dir, recursive = TRUE)
    },
    warning = function(cond) message("Copying file warning: ", cond),
    error = function(cond) message("Copying file error: ", cond)
  )
  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(), inherits, logical(1), what = "code_chunk"))
}

.report_identifier <- function(reporter) {
  id <- paste0("_", reporter$get_id()) %||% ""
  timestamp <- format(Sys.time(), "_%y%m%d%H%M%S")
  sprintf("reporter%s%s", id, timestamp)
}

#' @title `teal_card`: An `S3` class for managing `teal` reports
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' The `teal_card` `S3` class provides functionality to store, manage, edit, and adjust report contents.
#' It enables users to create, manipulate, and serialize report-related data efficiently.
#'
#' The `teal_card()` function serves two purposes:
#' 1. When called with a `teal_report` object, it acts as a getter and returns the card slot.
#' 2. When called with other arguments, it creates a new `teal_card` object from those arguments.
#'
#' @return An `S3` `list` of class `teal_card`.
#' @param ... Elements from which `teal_card` will be combined.
#'
#' @details The `teal_card` class supports `c()` and `x[i]` methods for combining and subsetting elements.
#' However, these methods only function correctly when the first element is a `teal_card`.
#'
#' @seealso [code_chunk()], [render()], [toHTML()]
#'
#' @examples
#' # create an empty card
#' report <- teal_card()
#'
#' # Create a card with content
#' report <- teal_card(
#'   "## Headline",
#'   "This is `iris` table",
#'   code_chunk("print(iris)", lang = "R"),
#'   iris
#' )
#'
#' # Add elements to the report
#' report <- c(
#'   report,
#'   list("## mtcars Table"),
#'   code_chunk("print(mtcars)", lang = "R"),
#'   mtcars
#' )
#'
#' # Subset the report to keep only the first two elements
#' report[1:2]
#'
#' # Replace element
#' report[[1]] <- "## Iris Table"
#'
#' # Append element
#' report <- append(report, teal_card("# Awesome Report"), after = 0)
#' tools::toHTML(report)
#'
#' if (interactive()) {
#'   render(report, output_format = rmarkdown::pdf_document())
#' }
#'
#' @aliases teal_card
#' @name teal_card
#'
#' @export
teal_card <- function(...) {
  UseMethod("teal_card")
}

#' @export
#' @keywords internal
teal_card.default <- function(...) {
  x <- lapply(list(...), .convert_teal_card_input)

  if (length(x) > 0) {
    names(x) <- vapply(
      sample.int(.Machine$integer.max, size = length(x)),
      function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8),
      character(1)
    )
  }
  structure(x, class = "teal_card")
}

#' @export
#' @keywords internal
teal_card.teal_card <- function(...) {
  dots <- list(...)
  c(dots[[1]], dots[-1])
}

#' @export
#' @keywords internal
teal_card.teal_report <- function(...) {
  dots <- list(...)
  dots[[1]] <- dots[[1]]@teal_card
  do.call(teal_card, args = dots)
}

#' @export
#' @keywords internal
teal_card.qenv <- function(...) {
  dots <- list(...)
  dots[[1]] <- .code_to_card(dots[[1]]@code)
  do.call(teal_card, args = dots)
}

#' @rdname teal_card
#' @param value (`teal_card`) object to set in the `teal_report`.
#' @export
`teal_card<-` <- function(x, value) {
  x <- methods::as(x, "teal_report")
  checkmate::assert_class(x, "teal_report")
  x@teal_card <- as.teal_card(value)
  x
}

#' @export
`[[<-.teal_card` <- function(x, index, value) {
  new_card <- as.teal_card(value)
  value <- new_card[[1]]
  new_x <- NextMethod()
  if (checkmate::test_integerish(index)) {
    names(new_x)[[index]] <- names(new_card)[[1]]
  }
  new_x
}

#' Create or coerce to a teal_card
#'
#' This function ensures that input is converted to a teal_card object.
#' It accepts various input types and converts them appropriately.
#'
#' @param x Object to convert to teal_card
#' @return A teal_card object
#' @rdname teal_card
#' @export
as.teal_card <- function(x) { # nolint: object_name.
  if (inherits(x, "teal_card")) {
    if (length(x) && !checkmate::test_names(names(x), type = "unique")) { # Fix names if not unique or missing
      names(x) <- substr(
        vapply(seq_len(length(x)), function(ix) rlang::hash(list(ix, Sys.time(), x[[ix]])), character(1L)),
        1,
        8
      )
    }
    return(x)
  }
  if (identical(class(x), "list")) {
    return(do.call(teal_card, unname(x)))
  }
  teal_card(x)
}

#' @rdname teal_card
#' @export
c.teal_card <- function(...) {
  dots <- list(...)
  structure(
    Reduce(
      f = function(u, v) {
        v <- as.teal_card(v)
        if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u
          if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v`
            v
          } else {
            warning(
              "Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n",
              "Restoring original content and adding only new items to the end of the card."
            )
            utils::modifyList(u, v)
          }
        } else {
          attrs <- utils::modifyList(attributes(u) %||% list(), attributes(v))
          attrs$names <- union(names(u), names(v))
          attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %||% list(), metadata(v))
          result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass
          attributes(result) <- attrs
          result
        }
      },
      x = dots,
      init = list()
    ),
    class = "teal_card"
  )
}

#' @param i index specifying elements to extract or replace
#' @rdname teal_card
#' @export
`[.teal_card` <- function(x, i) {
  out <- NextMethod()
  class(out) <- "teal_card"
  attr(out, "metadata") <- metadata(x)
  out
}

#' Access metadata from a `teal_card` or `ReportCard`
#'
#' This function retrieves metadata from a `teal_card` or `ReportCard` object.
#' When `which` is `NULL`, it returns all metadata fields as a list.
#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata.
#' @param which (`character` or `NULL`) The name of the metadata field to extract.
#' @return A list of metadata fields or a specific field if `which` is provided.
#' @export
metadata <- function(object, which = NULL) {
  checkmate::assert_string(which, null.ok = TRUE)
  UseMethod("metadata", object)
}

#' @rdname metadata
#' @export
metadata.teal_card <- function(object, which = NULL) {
  metadata <- attr(object, which = "metadata", exact = TRUE)
  result <- metadata %||% list()
  if (is.null(which)) {
    return(result)
  }
  result[[which]]
}

#' @rdname metadata
#' @export
metadata.ReportCard <- function(object, which = NULL) {
  result <- list(title = object$get_name())
  if (is.null(which)) {
    return(result)
  }
  result[[which]]
}

#' Set metadata for a `teal_card` or `ReportCard`
#'
#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object.
#' It can be used to add new metadata or update existing fields.
#' @param object (`teal_card` or `ReportCard`) The object to modify.
#' @param which (`character`) The name of the metadata field to set.
#' @param value The value to assign to the specified metadata field.
#' @return The modified object with updated metadata.
#' @export
`metadata<-` <- function(object, which = NULL, value) {
  checkmate::assert_string(which, null.ok = TRUE)
  UseMethod("metadata<-", object)
}

#' @rdname metadata-set
#' @export
`metadata<-.teal_card` <- function(object, which = NULL, value) {
  if (missing(which)) {
    checkmate::assert_list(value, names = "named")
    attr(object, which = "metadata") <- value
    return(object)
  }
  attr(object, which = "metadata") <- utils::modifyList(
    metadata(object), structure(list(value), names = which)
  )
  object
}

#' @rdname metadata-set
#' @details
#' The `ReportCard` class only supports the `title` field in metadata.
#' @export
`metadata<-.ReportCard` <- function(object, which, value) {
  if (missing(which)) {
    if (!is.null(value[["title"]])) {
      object$set_name(value[["title"]])
    }
    if (length(value) >= 2 || length(value) == 1 && is.null(value[["title"]])) {
      warning("ReportCard class only supports `title` in metadata.")
    }
    return(object)
  }

  if (isFALSE(identical(which, "title"))) {
    warning("ReportCard class only supports `title` in metadata.")
  } else {
    object$set_name(value)
  }
  object
}

#' Generate a code chunk
#'
#' @description
#' This function creates a `code_chunk` object that represents code to be displayed
#' in a report. It stores the code of any language (see `lang` argument) and any
#' specified chunk options (e.g., `echo`, `eval`).
#'
#' @details
#' **Important Notes:**
#' - The code is **not evaluated**; it is only stored as text with formatting attributes.
#' - When converted to output, `code_chunk` produces markdown code block syntax
#'   (` ```{lang} ... ``` `) or HTML `<pre><code>...</code></pre>` blocks.
#' - The document is **not rendered** using `rmarkdown::render`. The `code_chunk` is part
#'   of the `teal_card` API for building reproducible documents that are produced as-is.
#'
#' **Typical Workflow:**
#' 1. Create a `code_chunk` object with your code and options
#' 2. Add it to a `teal_card` using `teal_card()` or `c()`
#' 3. The card produces the formatted code block in the final document output
#'
#' @param code (`character`) The code to be displayed in the code chunk.
#' @param ... Additional named parameters to be included as chunk options. These control
#'   how the chunk behaves when rendered (e.g., `echo = TRUE`, `eval = FALSE`,
#'   `message = FALSE`). See [`knitr` options](https://yihui.org/knitr/options/) for
#'   available options.
#' @param lang (`character(1)`) The language of the code chunk. Defaults to `"R"`.
#'   See [`knitr::knit_engines`] for supported languages (e.g., "python", "bash").
#'
#' @return An object of class `code_chunk`
#' @seealso
#' - [teal_card()] for creating report cards that can contain `code_chunk` objects
#'
#' @examples
#' # Basic code chunk with options
#' code_chunk("x <- 1:10", echo = TRUE, message = FALSE)
#'
#' # Python code chunk
#' code_chunk("import pandas as pd", lang = "python", eval = FALSE)
#'
#' # Code chunk with multiple knitr options
#' code_chunk(
#'   "plot(mtcars$mpg, mtcars$hp)",
#'   echo = TRUE,
#'   eval = TRUE,
#'   fig.width = 7,
#'   fig.height = 5,
#'   warning = FALSE
#' )
#'
#' @export
code_chunk <- function(code, ..., lang = "R") {
  checkmate::assert_character(code)
  checkmate::assert_string(lang)
  params <- list(...)
  checkmate::assert_list(params, names = "named", .var.name = "...")
  structure(
    paste(code, collapse = "\n"),
    params = params,
    lang = lang,
    class = "code_chunk"
  )
}


#' Builds `teal_card` from code and outputs in `qenv` object
#'
#' Builds a `teal_card` from the code and outputs of a `teal_data`
#' object, preserving the order of code execution and output display.
#'
#' @inheritParams eval_code-teal_report
#' @param x (`list`) object from `qenv@code`.
#' @return A `teal_card` built from the code and outputs in a `qenv` object.
#' @keywords internal
.code_to_card <- function(x, code_block_opts = list()) {
  elems <- Reduce(
    function(items, code_elem) {
      this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts))
      this_outs <- Filter( # intentionally remove warnings,messages from the generated report
        function(x) !inherits(x[[1]], "condition"),
        lapply(
          attr(code_elem, "outputs"),
          function(x) structure(list(x), class = c("chunk_output"))
        )
      )
      c(items, list(this_chunk), this_outs)
    },
    init = list(),
    x = x
  )
  do.call(teal_card, args = elems)
}

#' Internal helper for `teal_card`` input conversion
#'
#' Converts input values to a format compatible with `teal_card`.
#' This function is used internally to handle common inputs, such as `ggplot` objects,
#' ensuring they are appropriately converted to an "evaluable output" blocks that can
#' be saved to `RDS` file efficiently.
#'
#' This function performs the following conversions:
#' - `ggplot` objects are converted to `recordedplot` objects.
#'
#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`,
#' no conversion is applied.
#'
#' @param x (`object`) An object to be converted.
#'
#' @return The processed object, possibly converted or left unchanged.
#'
#' @keywords internal
.convert_teal_card_input <- function(x) {
  if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) {
    return(x)
  }
  if (inherits(x, "chunk_output")) {
    res <- structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output"))
    attributes(res) <- attributes(x) # keep same attributes
    res
  } else if (inherits(x, "ggplot")) {
    .ggplot_to_recordedplot(x)
  } else {
    x
  }
}

#' @noRd
.ggplot_to_recordedplot <- function(x) {
  checkmate::assert_class(x, "ggplot")
  grDevices::pdf(file = NULL)
  grDevices::dev.control(displaylist = "enable")
  dev <- grDevices::dev.cur()
  on.exit(grDevices::dev.off(dev))
  print(x)
  grDevices::recordPlot()
}

#' Determine default dimensions for report figures
#'
#' @param x An object, typically a `recordedplot` or `ggplot`, that has an
#' optional attributes `dev.width` and `dev.height` that override the default
#' dims set as options `teal.reporter.dev.fig.width` and
#' `teal.reporter.dev.fig.height`.
#' @return List with `width` and `height` elements.
#' @keywords internal
.determine_default_dimensions <- function(x, convert_to_inches = FALSE, dpi = 96) {
  checkmate::assert_flag(convert_to_inches)
  width <- attr(x, "dev.width") %||% getOption("teal.reporter.dev.fig.width", 800)
  height <- attr(x, "dev.height") %||% getOption("teal.reporter.dev.fig.height", 600)
  if (width < 150 || height < 150) {
    warning("Figure dimensions too small, setting to minimum of 150x150 pixels.")
    width <- max(width, 150)
    height <- max(height, 150)
  }

  if (convert_to_inches) {
    width <- width / dpi
    height <- height / dpi
  }
  list(width = width, height = height)
}

#' Concatenate `teal_report` objects
#'
#' @param ... (`teal_report`) objects to concatenate
#'
#' @return A [`teal_report`] object with combined [`teal_card`] elements.
#'
#' @export
#' @method c teal_report
c.teal_report <- function(...) {
  result <- NextMethod()
  l <- Filter(function(x) inherits(x, "teal_report"), list(...))
  if (length(l) > 1) {
    teal_card(result) <- do.call(c, lapply(l, teal_card))
  }
  result
}

#' @title `Reporter`: An `R6` class for managing reports
#' @docType class
#' @description
#'
#' This `R6` class is designed to store and manage reports,
#' facilitating the creation, manipulation, and serialization of report-related data.
#' It supports both `ReportCard` and `teal_card` objects, allowing flexibility
#' in the types of reports that can be stored and managed.
#'
#' @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 <- shiny::reactiveValues()
      private$cached_html <- shiny::reactiveValues()
      private$open_previewer_r <- shiny::reactiveVal(NULL)
      invisible(self)
    },
    #' @description Append one or more `ReportCard` or `teal_card` objects to the `Reporter`.
    #'
    #' @param cards (`ReportCard` or `teal_card`) or a list of such objects
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #'
    #' card1 <- teal_card("## Header 2 text", "A paragraph of default text")
    #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram())
    #' metadata(card1, "title") <- "Card1"
    #'
    #' card2 <- teal_card("Document introduction")
    #' metadata(card2, "title") <- "Card2"
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    append_cards = function(cards) {
      if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) {
        cards <- list(cards)
      }

      checkmate::assert_list(cards, types = c("ReportCard", "teal_card"))
      new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content())

      if (!is.null(self$get_template())) {
        new_cards <- lapply(new_cards, self$get_template())
      }

      # Set up unique id for each card
      names(new_cards) <- vapply(new_cards, function(card) {
        sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8))
      }, character(1L))

      for (card_id in names(new_cards)) {
        card <- new_cards[[card_id]]
        private$cards[[card_id]] <- card
        private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
      }
      invisible(self)
    },
    #' @description Reorders `teal_card` objects in `Reporter`.
    #' @param new_order `character` vector with names of `teal_card` objects to
    #' be set in this order.
    #' @description Reorders `teal_card` objects in `Reporter`.
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2") && require("rtables")
    #' library(rtables)
    #' # With the card1 from above
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2 <- teal_card(
    #'   "## Header 2 text",
    #'   "A paragraph of default text",
    #'   table_res2
    #' )
    #' metadata(card2, "title") <- "Card2"
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #'
    #' names(reporter$get_cards())
    #' reporter$reorder_cards(c("Card2", "Card1"))
    #' names(reporter$get_cards())
    reorder_cards = function(new_order) {
      private$override_order <- new_order
      invisible(self)
    },
    #' @description Sets `ReportCard` or `teal_card` content.
    #' @param card_id (`character(1)`) the unique id of the card to be replaced.
    #' @param card The new object (`ReportCard` or `teal_card`) to replace the existing one.
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2")
    #' # With card1 and card2 from above
    #'
    #' metadata(reporter$get_cards()[[1]], "title")
    #' reporter$replace_card(card2, names(reporter$get_cards())[[1]])
    #' metadata(reporter$get_cards()[[1]], "title")
    replace_card = function(card, card_id) {
      if (inherits(card, "ReportCard")) {
        card <- card$get_content()
      }
      private$cards[[card_id]] <- card
      private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
      invisible(self)
    },
    #' @description Retrieves all `teal_card` objects contained in `Reporter`.
    #' @return A (`list`) of [`teal_card`] objects.
    #' @examplesIf require("ggplot2")
    #' # With card1 and card2 from above
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      result <- if (shiny::isRunning()) {
        shiny::reactiveValuesToList(private$cards)
      } else {
        shiny::isolate(shiny::reactiveValuesToList(private$cards))
      }
      result <- Filter(Negate(is.null), result) # Exclude all cards that were removed
      # Ensure that cards added after reorder are returned (as well as reordered ones that were removed are excluded)
      result[union(intersect(private$override_order, names(result)), names(result))]
    },
    #' @description Compiles and returns all content blocks from the `teal_card`
    #'  objects in the `Reporter`.
    #' @param sep An optional separator to insert between each content block.
    #' Default is a `\n\\newpage\n` markdown.
    #' @return `list()` of `teal_card`
    #' @examplesIf require("ggplot2")
    #' # With card1 and card2 from above
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_blocks()
    get_blocks = function(sep = "\\newpage") {
      cards <- self$get_cards()
      blocks <- teal_card()
      for (idx in seq_along(cards)) {
        card <- unname(cards[[idx]]) # unname to avoid names conflict in c()
        title <- trimws(metadata(card, "title"))
        metadata(card)$title <- NULL

        card_title <- if (length(title) > 0 && nzchar(title)) {
          sprintf("# %s", title)
        } else {
          sprintf("# _Unnamed Card (%d)_", idx)
        }
        blocks <- c(blocks, as.teal_card(card_title), card)
        if (idx != length(cards) && length(sep)) blocks <- c(blocks, trimws(sep))
      }
      blocks
    },
    #' @description Resets the `Reporter`, removing all `teal_card` objects and metadata.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      if (shiny::isRunning()) {
        for (card_id in names(private$cards)) private$cards[[card_id]] <- NULL
      } else {
        private$cards <- shiny::reactiveValues()
      }
      private$override_order <- character(0L)
      private$metadata <- list()
      invisible(self)
    },
    #' @description Removes specific `teal_card` objects from the `Reporter` by their indices.
    #'
    #' @param ids (`integer`, `character`) the indexes of cards (either name)
    #' @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)),
        checkmate::check_character(ids, min.len = 1, max.len = length(private$cards))
      )
      for (card_id in ids) {
        private$cards[[card_id]] <- NULL
      }
      invisible(self)
    },
    #' @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 invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' reporter$from_reporter(reporter)
    from_reporter = function(reporter) {
      lifecycle::deprecate_warn("0.6.0", "Reporter$from_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(name = "teal Reporter", version = "1", id = self$get_id(), cards = list())
      rlist[["metadata"]] <- self$get_metadata()
      cards <- self$get_cards()
      for (i in seq_along(cards)) {
        # we want to have list names being a class names to indicate the class for $from_list
        card <- cards[[i]]
        card_class <- class(card)[1]
        u_card <- list()
        tmp <- tempfile(fileext = ".rds")
        suppressWarnings(saveRDS(card, file = tmp))
        tmp_base <- basename(tmp)
        file.copy(tmp, file.path(output_dir, tmp_base))
        u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base)
        rlist$cards <- c(rlist$cards, u_card)
      }
      rlist
    },
    #' @description Extracts and saves all figure elements from the `teal_card` objects in the
    #' `Reporter` to a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where figures will be saved.
    #' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures.
    write_figures = function(output_dir, sub_directory = "figures") {
      figures_dir <- file.path(output_dir, sub_directory)
      dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
      cards <- self$get_cards()
      for (card_id in names(cards)) {
        card <- cards[[card_id]]
        cached_html <- self$get_cached_html(card_id)
        for (element_ix in seq_along(card)) {
          card_element <- card[[element_ix]]
          if (
            inherits(card_element, "chunk_output") &&
              checkmate::test_multi_class(
                card_element[[1]],
                classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap")
              )
          ) {
            base64_image <- cached_html[[names(card)[[element_ix]]]]
            if ( # Ensure we only save valid base64 images
              !is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") &&
                !is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src)
            ) {
              b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src)
              writeBin(
                jsonlite::base64_dec(b64),
                file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix))
              )
            }
          }
        }
      }
    },
    #' @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.
    #' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
    #' @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) {
      id <- self$get_id()
      checkmate::assert_list(rlist)
      checkmate::assert_directory_exists(output_dir)
      stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter")
      stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id)
      if (rlist$version %in% c("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]]
          if (card_class == "teal_card") {
            new_card <- readRDS(file.path(output_dir, card$path))
            class(new_card) <- "teal_card"
            new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards
            names(new_card) <- card$name
          } else {
            new_card <- eval(str2lang(card_class))$new()
            new_card$from_list(card, output_dir)
          }
          new_cards <- c(new_cards, new_card)
        }
      } else {
        stop(
          sprintf(
            "The provided %s reporter version is not supported.",
            rlist$version
          )
        )
      }
      self$reset()
      self$set_id(rlist$id)
      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.
    #' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
    #' @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)
      dir_files <- list.files(output_dir)
      stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0)
      stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files))
      json <- jsonlite::read_json(file.path(output_dir, "Report.json"))
      self$reset()
      self$from_list(json, output_dir)
      invisible(self)
    },
    #' @description Set the `Reporter` id
    #' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list.
    #' The id is added to the downloaded file name.
    #' @param id (`character(1)`) a Report id.
    #' @return `self`, invisibly.
    set_id = function(id) {
      private$id <- id
      invisible(self)
    },
    #' @description Get or set the reactive trigger to open the previewer modal.
    #' @param  val value to the passed to the reactive trigger.
    #' @return `reactiveVal` value
    open_previewer = function(val) {
      if (missing(val)) {
        private$open_previewer_r()
      } else {
        private$open_previewer_r(val)
      }
    },
    #' @description Get cached HTML for a specific `teal_card` by its id.
    #' @param card_id (`character(1)`) the unique id of the card.
    get_cached_html = function(card_id) {
      if (shiny::isRunning()) {
        private$cached_html[[card_id]]
      } else {
        shiny::isolate(private$cached_html[[card_id]])
      }
    },
    #' @description Get the `Reporter` id
    #' @return `character(1)` the `Reporter` id.
    get_id = function() private$id,
    #' @description Set template function for `teal_card`
    #' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards`
    #' @param template (`function`) a template function.
    #' @return `self`, invisibly.
    #' @examples
    #'
    #' reporter <- teal.reporter::Reporter$new()
    #' template_fun <- function(document) {
    #'   disclaimer <- teal.reporter::teal_card("Here comes disclaimer text")
    #'   c(disclaimer, document)
    #' }
    #' reporter$set_template(template_fun)
    #' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text")
    #' metadata(doc1, "title") <- "Welcome card"
    #' reporter$append_cards(doc1)
    #' reporter$get_cards()
    set_template = function(template) {
      private$template <- template
      invisible(self)
    },
    #' @description Get the `Reporter` template
    #' @return a template `function`.
    get_template = function() private$template
  ),
  private = list(
    id = "",
    cards = NULL, # reactiveValues
    cached_html = NULL, # reactiveValues
    open_previewer_r = NULL, # reactiveVal to trigger reactive contexts
    override_order = character(0L), # to sort cards (reactiveValues are not sortable)
    metadata = list(),
    template = 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) {
      shiny::isolate({
        if (name == "cards") {
          new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) {
            if (R6::is.R6(card)) card$clone(deep = TRUE) else card
          })
          do.call(shiny::reactiveValues, new_cards)
        } else {
          value
        }
      })
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

ui_previewer_card_actions <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::actionLink(
      inputId = ns("toggle_code_action"),
      class = "btn btn-outline-secondary btn-sm float-end p-3 card-code-toggle",
      style = "background-color: white !important; z-index: 10 !important; position: relative !important;",
      label = NULL,
      title = "Toggle code chunks",
      icon = shiny::icon("code")
    ),
    shiny::actionLink(
      inputId = ns("edit_action"),
      class = "btn btn-primary btn-sm float-end p-3",
      label = NULL,
      title = "Edit card",
      icon = shiny::icon("edit")
    ),
    shiny::actionLink(
      inputId = ns("remove_action"),
      class = "btn btn-danger btn-sm float-end p-3",
      label = NULL,
      icon = shiny::icon("trash-alt"),
    )
  )
}

srv_previewer_card_actions <- function(id, card_r, card_id, reporter) {
  shiny::moduleServer(id, function(input, output, session) {
    new_card_rv <- shiny::reactiveVal()

    shiny::observeEvent(
      ignoreInit = TRUE,
      input$edit_action,
      {
        template_card <- card_r()
        new_card_rv(template_card)
        title <- metadata(template_card, "title")
        if (is.null(title) || isFALSE(nzchar(title))) {
          title <- shiny::tags$span(class = "text-muted", "(Empty title)")
        }

        shiny::showModal(
          shiny::modalDialog(
            title = shiny::tags$span(
              class = "edit_title_container",
              "Editing Card:",
              shiny::tags$span(id = session$ns("static_title"), title),
              shiny::actionButton(
                session$ns("edit_title"),
                label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"),
                class = "fs-6",
                title = "Edit title"
              ),
              shinyjs::hidden(
                shiny::textInput(
                  session$ns("new_title"),
                  label = NULL, value = metadata(template_card, "title")
                )
              )
            ),
            size = "l",
            easyClose = TRUE,
            shiny::tagList(
              ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)),
              shiny::uiOutput(session$ns("add_text_element_button_ui"))
            ),
            footer = shiny::tagList(
              shiny::actionButton(session$ns("edit_save"), label = "Save"),
              shiny::modalButton("Close")
            )
          )
        )
      }
    )

    block_input_names_rvs <- srv_card_editor("editor", new_card_rv)

    shiny::observeEvent(input$edit_title, {
      shinyjs::hide("edit_title")
      shinyjs::hide("static_title")
      shinyjs::show("new_title")
      shinyjs::js$jumpToFocus(session$ns("new_title"))
    })

    # Handle
    shiny::observeEvent(input$edit_save, {
      new_card <- shiny::req(new_card_rv())
      input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs))
      for (name in names(input_r)) {
        new_card[[name]] <- shiny::isolate(input_r[[name]]())
      }
      if (isFALSE(is.null(input$new_title))) {
        metadata(new_card, "title") <- input$new_title
      }
      if (isFALSE(identical(new_card, card_r()))) {
        tryCatch(
          {
            reporter$replace_card(card = new_card, card_id = card_id)
            new_card_rv(NULL)
            reporter$open_previewer(Sys.time())
            shiny::showNotification("Card was successfully updated.", type = "message")
          },
          error = function(err) {
            shiny::showNotification(
              sprintf(
                "A card with the name '%s' already exists. Please use a different name.",
                metadata(new_card, "title")
              ),
              type = "error",
              duration = 5
            )
            shinyjs::enable("edit_save")
          }
        )
      } else {
        new_card_rv(NULL)
        reporter$open_previewer(Sys.time())
      }
    })

    shiny::observeEvent(input$toggle_code_action, {
      shinyjs::runjs(sprintf("toggleRCodeAccordions('%s');", card_id))
    })

    # Handle remove button
    shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id))
  })
}

#' Simple reporter module
#'
#' @description
#'
#' 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 (`reactive` or `function`) which returns a [`teal_card`] or [`ReportCard`] instance.
#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
#'
#' @examples
#' if (interactive()) {
#'   library(shiny)
#'
#'   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(
    .custom_css_dependency(),
    shiny::tags$div(
      shiny::tags$label(class = "text-primary", 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")),
        report_load_ui(ns("archive_load_simple")),
        reset_report_button_ui(ns("reset_button_simple"))
      ),
      shiny::tags$br()
    )
  )
}

#' @rdname simple_reporter
#' @export
simple_reporter_srv <- function(
  id,
  reporter,
  card_fun,
  global_knitr = getOption("teal.reporter.global_knitr"),
  rmd_output = getOption("teal.reporter.rmd_output"),
  rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")
) {
  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
      )
      report_load_srv("archive_load_simple", reporter = reporter)
      reset_report_button_srv("reset_button_simple", reporter = reporter)
    }
  )
}

.onLoad <- function(libname, pkgname) {
  op <- options()

  teal_reporter_default_options <- list(
    teal.reporter.global_knitr = list(
      echo = TRUE,
      tidy.opts = list(width.cutoff = 60),
      tidy = requireNamespace("formatR", quietly = TRUE)
    ),
    teal.reporter.devices.dev.width = 800,
    teal.reporter.devices.dev.height = 600,
    teal.reporter.rmd_output = c(
      "html" = "html_document", "pdf" = "pdf_document",
      "powerpoint" = "powerpoint_presentation",
      "word" = "word_document"
    ),
    teal.reporter.rmd_yaml_args = list(
      author = "NEST", title = "Report",
      date = as.character(Sys.Date()), output = "html_document",
      toc = FALSE
    ),
    teal.reporter.max_request_size = 10 * 1024^2
  )

  toset <- !(names(teal_reporter_default_options) %in% names(op))
  if (any(toset)) options(teal_reporter_default_options[toset])

  # Manual import instead of using backports and adding 1 more dependency
  if (getRversion() < "4.4") {
    assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname))
  }

  invisible()
}

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

#' Show report previewer button module
#'
#' @description `r lifecycle::badge("experimental")`
#' Provides a button that triggers showing the report preview in a modal.
#'
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#'
#' @name reporter_previewer
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param label (`character(1)`) label of the button. By default it is "Preview Report".
#' @param reporter (`Reporter`) instance.
#'
#' @return `NULL`.
NULL

#' @rdname reporter_previewer
#' @export
preview_report_button_ui <- function(id, label = "Preview Report") {
  checkmate::assert_string(label, null.ok = TRUE)
  ns <- shiny::NS(id)
  shiny::tagList(
    .action_button_busy(
      ns("preview_button"),
      label = shiny::tags$span(
        label,
        shiny::uiOutput(ns("preview_button_counter"))
      ),
      icon = "file-earmark-text",
      outline = TRUE
    )
  )
}

#' @rdname reporter_previewer
#' @export
preview_report_button_srv <- function(id, reporter) {
  checkmate::assert_class(reporter, "Reporter")

  shiny::moduleServer(id, function(input, output, session) {
    shiny::setBookmarkExclude(c("preview_button"))

    shiny::observeEvent(reporter$get_cards(), {
      shinyjs::toggleClass(
        id = "preview_button", condition = length(reporter$get_cards()) == 0, class = "disabled"
      )
    })

    output$preview_button_counter <- shiny::renderUI({
      shiny::tags$span(
        class = "badge rounded-pill bg-primary",
        length(reporter$get_cards())
      )
    })

    preview_modal <- function() {
      shiny::tags$div(
        class = "teal-reporter reporter-previewer-modal",
        .custom_css_dependency(),
        .accordion_toggle_js_dependency(),
        shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
        shiny::modalDialog(
          easyClose = TRUE,
          size = "xl",
          title = "Report Preview",
          reporter_previewer_content_ui(session$ns("preview_content")),
          footer = shiny::tagList(
            shiny::tags$button(
              type = "button",
              class = "btn btn-outline-secondary",
              "data-bs-dismiss" = "modal",
              "Dismiss"
            )
          )
        )
      )
    }

    reporter_previewer_content_srv(id = "preview_content", reporter = reporter)

    srv_list <- shiny::reactiveValues()
    shiny::observeEvent(
      list(input$preview_button, reporter$open_previewer()),
      ignoreInit = TRUE,
      {
        shiny::req(input$preview_button != 0 || !is.null(reporter$open_previewer())) # prevent unnecessary triggering.
        shiny::showModal(preview_modal())

        panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards"))
        lapply(
          names(reporter$get_cards()),
          function(card_id) {
            # Only show loading placeholder for cards that are being initialized for the first time
            first_run <- is.null(srv_list[[card_id]])

            bslib::accordion_panel_insert(
              id = panel_ns(NULL),
              previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id, show_loading = first_run)
            )

            if (first_run) { # Only initialize srv once per card_id
              previewer_card_srv(
                id = panel_ns(card_id),
                card_r = shiny::reactive(reporter$get_cards()[[card_id]]),
                card_id = card_id,
                reporter = reporter
              )
              srv_list[[card_id]] <- card_id
            }
          }
        )
      }
    )
  })
}

#' Load `Reporter` button module
#'
#' @description
#'
#' Provides a button to upload `ReporterCard`(s) to the `Reporter`.
#'
#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @name load_report_button
#'
#' @param id `character(1)` this `shiny` module's id.
#' @param label (`character(1)`) label of the button. By default it is empty.
#' @param reporter [`Reporter`] instance.
NULL

#' @rdname load_report_button
#' @return `shiny::tagList`
#' @export
report_load_ui <- function(id, label = NULL) {
  checkmate::assert_string(label, null.ok = TRUE)
  .action_button_busy(
    shiny::NS(id, "reporter_load"),
    label = label,
    icon = "upload",
    outline = TRUE
  )
}

#' @rdname load_report_button
#' @return `shiny::moduleServer`
#' @export
report_load_srv <- function(id, reporter) {
  checkmate::assert_class(reporter, "Reporter")

  shiny::moduleServer(
    id,
    function(input, output, session) {
      shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load"))
      ns <- session$ns

      # Set max request size from package option
      max_size <- getOption("teal.reporter.max_request_size", 10 * 1024^2)
      options(shiny.maxRequestSize = max_size)

      archiver_modal <- function() {
        nr_cards <- length(reporter$get_cards())
        shiny::div(
          class = "teal-reporter reporter-modal",
          .custom_css_dependency(),
          shiny::modalDialog(
            easyClose = TRUE,
            shiny::tags$h3("Load the Report"),
            shiny::tags$hr(),
            shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)",
              multiple = FALSE,
              accept = c(".zip")
            ),
            footer = shiny::div(
              shiny::tags$button(
                type = "button",
                class = "btn btn-outline-secondary",
                `data-bs-dismiss` = "modal",
                NULL,
                "Dismiss"
              ),
              shinyjs::disabled(
                shiny::tags$button(
                  id = ns("reporter_load_main"),
                  type = "button",
                  class = "btn btn-primary action-button",
                  NULL,
                  "Load"
                )
              )
            )
          )
        )
      }

      shiny::observeEvent(input$archiver_zip, {
        shinyjs::enable(id = "reporter_load_main")
      })

      shiny::observeEvent(input$reporter_load, {
        shiny::showModal(archiver_modal())
      })

      shiny::observeEvent(input$reporter_load_main, {
        load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]])
        shiny::removeModal()
      })
    }
  )
}

#' @keywords internal
load_json_report <- function(reporter, zip_path, filename) {
  tmp_dir <- tempdir()
  output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
  dir.create(path = output_dir)
  if (!is.null(zip_path) && grepl("report(er)?_", filename)) {
    tryCatch(
      expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE),
      warning = function(cond) {
        print(cond)
        shiny::showNotification(
          ui = "Unzipping folder warning!",
          action = "Please contact app developer",
          type = "warning"
        )
      },
      error = function(cond) {
        print(cond)
        shiny::showNotification(
          ui = "Unzipping folder error!",
          action = "Please contact app developer",
          type = "error"
        )
      }
    )
    tryCatch(
      reporter$from_jsondir(output_dir),
      warning = function(cond) {
        print(cond)
        shiny::showNotification(
          ui = "Loading reporter warning!",
          action = "Please contact app developer",
          type = "warning"
        )
      },
      error = function(cond) {
        print(cond)
        shiny::showNotification(
          ui = "Loading reporter error!",
          action = "Please contact app developer",
          type = "error"
        )
      }
    )
  } else {
    shiny::showNotification(
      paste(
        "Failed to load the Reporter file.",
        "Please make sure that the filename starts with `report_`."
      ),
      type = "error"
    )
  }
}
1 + 1

#' @importFrom tools toHTML
NULL

#' Convert report objects to HTML
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' The `toHTML` S3 generic method converts various report objects into HTML representations.
#' This is the primary method for rendering report content for display in web browsers,
#' IDE Viewer, or for inclusion in Shiny applications.
#'
#' @param x The object to convert to HTML. Supported types include:
#'   - `teal_card`: A list-like structure containing report elements
#'   - `teal_report`: A report object containing a `teal_card`
#'   - `ReportCard`: Deprecated R6 class for report cards
#'   - `code_chunk`: Code blocks created with [code_chunk()]
#'   - `chunk_output`: Output from evaluated code chunks
#'   - Plot objects: `ggplot`, `recordedplot`, `trellis`, `grob`
#'   - Table objects: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`,
#'     `listing_df`, `gtsummary`, `flextable`, `datatables`
#'   - Text: `character` strings (rendered as markdown)
#'   - Other objects: Conditions, model summaries, etc.
#' @param ... Additional arguments passed to methods.
#'
#' @details
#' ## Relationship with `teal_card`
#'
#' The `teal_card` class is a central component in the `teal.reporter` ecosystem. It is an S3 list
#' where each element represents a piece of report content (text, plots, tables, code chunks, etc.).
#' The `toHTML` method for `teal_card` objects:
#'
#' 1. Iterates through each element in the `teal_card` list
#' 2. Calls `toHTML()` recursively on each element based on its class
#' 3. Wraps all converted elements in a [bslib::card()] container
#'
#' This hierarchical conversion allows complex report structures to be rendered as styled HTML
#' with proper formatting for each content type.
#'
#' ## Content Type Conversions
#'
#' **Text and Markdown:** Character strings are converted to HTML using `CommonMark` markdown syntax.
#' Supports headers, lists, code blocks, emphasis, and other markdown features.
#'
#' **Code Chunks:** Created with [code_chunk()], these are rendered as collapsible Bootstrap
#' accordions with syntax highlighting. The accordion includes the programming language indicator
#' and an icon.
#'
#' **Plots:** Plot objects (`ggplot`, `recordedplot`, `trellis`, `grob`) are converted to PNG
#' images with base64-encoded data URIs, making them self-contained in the HTML output.
#'
#' **Tables:** Table objects are converted to styled HTML tables, typically via `flextable`
#' for consistent formatting.
#'
#' ## Viewer Integration
#'
#' All HTML output is wrapped with [htmltools::browsable()], which enables:
#' - Automatic render in IDE Viewer when displayed interactively
#' - Proper HTML dependency injection (Bootstrap CSS/JavaScript, Font Awesome icons, etc.)
#' - Standalone HTML files with all required resources
#'
#' You can override the `browsable` behavior with:
#' ```r
#' print(toHTML(x), browse = FALSE)  # Print markup to console instead
#' ```
#'
#' @return An HTML representation of the input object. The exact return type depends on the
#'   input class:
#'   - For `teal_card`: A `bslib::card()` containing all elements
#'   - For `code_chunk`: A `bslib::accordion()` with the code
#'   - For plots: A `shiny::tags$img()` tag
#'   - For text: HTML markup from markdown conversion
#'   - For tables: HTML table elements
#'
#'   All returns are wrapped with `htmltools::browsable()` to enable viewer display.
#'
#' @seealso
#' - [teal_report()] for creating report objects
#' - [teal_card()] for creating report cards
#' - [code_chunk()] for creating code blocks
#' - [render()] for rendering complete reports to files
#'
#' @examples
#' # Initialize empty report
#' report <- teal_report()
#'
#' # Add arbitrary markdown elements to the report's teal_card
#' teal_card(report) <- c(
#'   teal_card(report),
#'   "## Document section",
#'   "Lorem ipsum dolor sit amet"
#' )
#'
#' # Use within() to execute code and add code-chunk
#' report <- within(report, a <- 2)
#'
#' # within() automatically captures code and outputs
#' report <- within(report, plot(a))
#'
#' html <- tools::toHTML(report)
#' # display HTML markup in viewer
#' html
#'
#' # Print HTML markup to console instead of viewer
#' print(html, browse = FALSE)
#'
#' @export
#' @aliases teal_card-preview
#' @method toHTML default
toHTML.default <- function(x, ...) {
  htmltools::browsable(.toHTML(x, ...))
}

#' @keywords internal
.toHTML <- function(x, ...) { # nolint: object_name.
  UseMethod(".toHTML", x)
}

#' @method .toHTML default
#' @keywords internal
.toHTML.default <- function(x, ...) {
  htmltools::HTML(commonmark::markdown_html(x, extensions = TRUE))
}

#' @method .toHTML ContentBlock
#' @keywords internal
.toHTML.ContentBlock <- function(x, ...) {
  tools::toHTML(x$get_content(), ...)
}

#' @method .toHTML ContentBlock
#' @keywords internal
.toHTML.RcodeBlock <- function(x, ...) {
  tools::toHTML(code_chunk(x$get_content(), lang = "R"), ...)
}

#' @method .toHTML ReportCard
#' @keywords internal
.toHTML.ReportCard <- function(x, ...) {
  shiny::tagList(lapply(x$get_content(), tools::toHTML, ...))
}

#' @method .toHTML teal_card
#' @keywords internal
.toHTML.teal_card <- function(x, ...) {
  bslib::card(lapply(x, tools::toHTML, ...))
}

#' @method .toHTML teal_report
#' @keywords internal
.toHTML.teal_report <- function(x, ...) {
  tools::toHTML(teal_card(x), ...)
}

#' @method .toHTML rtables
#' @keywords internal
.toHTML.rtables <- function(x, ...) {
  shiny::tags$pre(tools::toHTML(to_flextable(x)))
}

#' @method .toHTML flextable
#' @keywords internal
.toHTML.flextable <- function(x, ...) {
  flextable::htmltools_value(x)
}

#' @method .toHTML condition
#' @keywords internal
.toHTML.condition <- function(x, ...) {
  conditionMessage(x)
}

.plot2html <- function(x, ...) {
  on.exit(unlink(tmpfile))
  tmpfile <- tempfile(fileext = ".png")
  dims <- .determine_default_dimensions(x)
  grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
  print(x)
  grDevices::dev.off()
  shiny::tags$img(src = knitr::image_uri(tmpfile), style = "width: 100%; height: auto;")
}

#' @method .toHTML recordedplot
#' @keywords internal
.toHTML.recordedplot <- .plot2html

#' @method .toHTML trellis
#' @keywords internal
.toHTML.trellis <- .plot2html

#' @method .toHTML gg
#' @keywords internal
.toHTML.gg <- function(x, ...) {
  on.exit(unlink(tmpfile))
  dims <- .determine_default_dimensions(x, convert_to_inches = TRUE, dpi = 100)
  tmpfile <- tempfile(fileext = ".png")
  ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100)
  shiny::tags$img(src = knitr::image_uri(tmpfile))
}

#' @method .toHTML grob
#' @keywords internal
.toHTML.grob <- function(x, ...) {
  on.exit(unlink(tmpfile))
  dims <- .determine_default_dimensions(x)
  tmpfile <- tempfile(fileext = ".png")
  grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
  grid::grid.newpage()
  grid::grid.draw(x)
  grDevices::dev.off()
  shiny::tags$img(src = knitr::image_uri(tmpfile))
}

#' @method .toHTML code_chunk
#' @keywords internal
.toHTML.code_chunk <- function(x, ...) {
  bslib::accordion(
    class = "code_chunk",
    open = FALSE,
    bslib::accordion_panel(
      title = shiny::tags$span(shiny::icon("code"), attr(x, "lang", exact = TRUE)),
      value = "rcode",
      shiny::tags$pre(
        shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang", exact = TRUE))),
        .noWS = "inside"
      )
    )
  )
}

#' @method .toHTML chunk_output
#' @keywords internal
.toHTML.chunk_output <- function(x, ...) {
  new_x <- x[[1]]
  mostattributes(new_x) <- c(attributes(unclass(x)), attributes(new_x))
  tools::toHTML(new_x, ...)
}

#' @method .toHTML summary.lm
#' @keywords internal
.toHTML.summary.lm <- function(x, ...) {
  shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n"))
}

#' @method .toHTML TableTree
#' @keywords internal
.toHTML.TableTree <- .toHTML.rtables

#' @method .toHTML ElementaryTable
#' @keywords internal
.toHTML.ElementaryTable <- .toHTML.rtables

#' @method .toHTML rlisting
#' @keywords internal
.toHTML.rlisting <- .toHTML.rtables

#' @method .toHTML data.frame
#' @keywords internal
.toHTML.data.frame <- .toHTML.rtables

#' @method .toHTML datatables
#' @keywords internal
.toHTML.datatables <- function(x, ...) {
  x
}

#' @method .toHTML gtsummary
#' @keywords internal
.toHTML.gtsummary <- function(x, ...) {
  tools::toHTML(gtsummary::as_flex_table(x))
}

#' @method .toHTML listing_df
#' @keywords internal
.toHTML.listing_df <- function(x, ...) {
  tools::toHTML(flextable::as_flextable(x))
}

setOldClass("teal_card")

#' Reproducible report
#'
#' Reproducible report container class. Inherits code tracking behavior from [`teal.data::teal_data-class`].
#'
#' This class provides an isolated environment in which to store and process data with all code being recorded.
#' The environment, code, data set names, and data joining keys are stored in their respective slots.
#' These slots should never be accessed directly, use the provided get/set functions.
#'
#' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots.
#' If errors are raised, a `qenv.error` object is returned.
#'
#' @name teal_report-class
#' @rdname teal_report-class
#'
#' @slot .xData (`environment`) environment containing data sets and possibly
#'  auxiliary variables.
#'  Access variables with [get()], [`$`]  or [`[[`].
#'  No setter provided. Evaluate code to add variables into `@.xData`.
#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `qenv`.
#'  Access with [teal.code::get_code()].
#'  No setter provided. Evaluate code to append code to the slot.
#' @slot join_keys (`join_keys`) object specifying joining keys for data sets in
#' `@.xData`.
#'  Access or modify with [teal.data::join_keys()].
#' @slot verified (`logical(1)`) flag signifying that code in `@code` has been
#'  proven to yield contents of `@.xData`.
#'  Used internally. See [`teal.data::verify()`] for more details.
#' @slot card (`teal_card`)
#' @inheritSection teal.data::`teal_data-class` Code
#' @importFrom teal.data teal_data
#' @keywords internal
setClass(
  Class = "teal_report",
  contains = "teal_data",
  slots = c(teal_card = "teal_card")
)

#' It initializes the `teal_report` class
#'
#' Accepts .xData as a list and converts it to an environment before initializing
#' parent constructor (`teal_data`).
#' @noRd
setMethod(
  "initialize",
  "teal_report",
  function(.Object, teal_card = NULL, ...) { # nolint: object_name.
    args <- list(...)
    if (is.null(teal_card)) teal_card <- teal_card()
    checkmate::assert_class(teal_card, "teal_card")
    checkmate::assert_list(args, names = "named")
    methods::callNextMethod(
      .Object,
      teal_card = teal_card,
      ...
    )
  }
)

#' Comprehensive data integration function for `teal` applications
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Initializes a reportable data for `teal` application.
#'
#' @inheritParams teal.data::teal_data
#' @param teal_card (`teal_card`) object containing the report content.
#' @return A `teal_report` object.
#'
#' @seealso [`teal.data::teal_data`]
#'
#' @export
#'
#' @examples
#' # Initialize teal_report with existing h2 header
#' report <- teal_report(teal_card = teal_card("## Analysis Report"))
#'
#' # Use within() to execute code and add code-chunk
#' report <- within(report, {
#'   data <- iris
#'   summary_stats <- summary(data)
#' })
#'
#' # Access objects created within the report
#' report$data
#' report$summary_stats
#'
#' # within() automatically captures code and outputs
#' report <- within(report, {
#'   head(iris)
#' })
#'
#' # Add arbitrary markdown content to the card
#' teal_card(report) <- c(
#'   teal_card(report),
#'   teal_card("### Conclusion", "The analysis is complete.")
#' )
#'
#' # View the generated card with code chunks
#' teal_card(report)
#'
#' # View report in HTML format
#' tools::toHTML(report)
#'
#' if (interactive()) {
#'   # Render the report to various formats
#'   render(report, output_format = rmarkdown::html_document())
#'   render(report, output_format = rmarkdown::pdf_document())
#' }
#'
teal_report <- function(...,
                        teal_card = NULL,
                        code = character(0),
                        join_keys = teal.data::join_keys()) {
  if (is.null(teal_card)) teal_card <- teal_card()
  methods::new(
    "teal_report",
    .xData = list2env(list(...)),
    teal_card = teal_card,
    join_keys = join_keys,
    code = code
  )
}

#' Internal function to convert `qenv` or `teal_data` to `teal_report`
#' @noRd
coerce.teal_report <- function(from, to) { # nolint: object_name.
  if (inherits(from, "teal_report")) {
    return(from)
  }
  new_x <- teal_report()
  for (slot_name in methods::slotNames(from)) {
    methods::slot(new_x, slot_name) <- methods::slot(from, slot_name)
  }
  teal_card(new_x) <- .code_to_card(from@code)
  new_x
}

methods::setAs("qenv", "teal_report", coerce.teal_report)
methods::setAs("teal_data", "teal_report", coerce.teal_report)

#' @rdname teal_report
#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`.
#' @export
as.teal_report <- function(x) { # nolint: object_name.
  checkmate::assert_class(x, "qenv")
  methods::as(x, "teal_report")
}

#' @export
#' @rdname srv_editor_block
ui_editor_block <- function(id, value, ...) {
  UseMethod("ui_editor_block", value)
}

#' UI and Server functions for editing report document blocks
#'
#' These functions provide a user interface and server logic for editing and extending
#' the editor functionality to support new data types.
#'
#' @details
#' The methods for this S3 generic can be extended by the app developer to new classes
#' or even overwritten.
#' For this a function with the name `srv_editor_block.<class>` and/or `ui_editor_block.<class>`
#' should be defined in the Global Environment, where `<class>` is the class of
#' the object to be used in the method.
#'
#' For example, to override the default behavior for `character` class, you can use:
#'
#' ```r
#' ui_editor_block.character <- function(id, value) {
#'   # custom implementation
#'   shiny::tagList(
#'     shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable CUSTOM markdown block"),
#'     shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%")
#'   )
#' }
#' srv_editor_block.character <- function(id, value) {
#'  # custom implementation
#'  # ...
#' }
#' ```
#'
#' Alternatively, you can register the S3 method using
#' `registerS3method("ui_editor_block", "<class>", fun)` and
#' `registerS3method("srv_editor_block", "<class>", fun)`.
#'
#' ### Optional arguments of `ui_editor_block`
#'
#' - `cached_html`: (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI that is
#' rendered at the time the card is being added. Default is `NULL`.
#'
#'    `teal` will call on `ui_editor_block` with the contents of each element
#'     of the card (`value` argument) and an optional parameter `cached_html`.
#'     This parameter is not part of the S3 generic as it is optional when overriding the method.
#'
#'     The usage of this argument improve the UI performance by avoiding re-rendering on the fly.
#'     When overriding this method, the usage of this argument is optional, hence it is not part of the S3 generic.
#'
#' @param id (`character(1)`) A unique identifier for the module.
#' @param value The content of the block to be edited. It can be a character string or other types.
#' @param ... Additional arguments passed to dispatch functions.
#' @export
srv_editor_block <- function(id, value, ...) {
  UseMethod("srv_editor_block", value)
}

#' @export
ui_editor_block.default <- function(id, value, ...) {
  .ui_editor_block(id, value, ...)
}

#' @export
srv_editor_block.default <- function(id, value, ...) {
  .srv_editor_block(id, value, ...)
}

#' @keywords internal
.ui_editor_block <- function(id, value, cached_html, ...) {
  UseMethod(".ui_editor_block", value)
}

#' @keywords internal
.srv_editor_block <- function(id, value, ...) {
  UseMethod(".srv_editor_block", value)
}

#' @method .ui_editor_block default
.ui_editor_block.default <- function(id, value, cached_html, ...) {
  shiny::tags$div(
    shiny::tags$h6(
      shiny::tags$span(
        class = "fa-stack small text-muted",
        # style = "width: 2em;", # necessary to avoid extra space after icon
        shiny::icon("pencil", class = "fa-stack-1x"),
        shiny::icon("ban", class = "fa-stack-2x fa-inverse text-black-50")
      ),
      "Non-editable block"
    ),
    if (is.null(cached_html)) {
      tools::toHTML(value)
    } else {
      cached_html
    }
  )
}

#' @method .srv_editor_block default
.srv_editor_block.default <- function(id, value, ...) {
  shiny::moduleServer(id, function(input, output, session) result <- NULL) # No input being changed, skipping update
}

#' @method .ui_editor_block character
.ui_editor_block.character <- function(id, value, ...) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"),
    shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%")
  )
}

#' @method .srv_editor_block character
.srv_editor_block.character <- function(id, value, ...) {
  shiny::moduleServer(id, function(input, output, session) result <- shiny::reactive(input$content))
}

#' Reset report button module
#'
#' @description
#'
#' 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 of the button. 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)
  .action_button_busy(
    shiny::NS(id, "reset_reporter"),
    label = label,
    icon = "x-lg",
    type = "danger",
    outline = TRUE
  )
}

#' @rdname reset_report_button
#' @export
reset_report_button_srv <- function(id, reporter) {
  checkmate::assert_class(reporter, "Reporter")

  shiny::moduleServer(id, function(input, output, session) {
    shiny::setBookmarkExclude(c("reset_reporter"))

    shiny::observeEvent(reporter$get_cards(), {
      shinyjs::toggleClass(
        id = "reset_reporter", condition = length(reporter$get_cards()) == 0, class = "disabled"
      )
    })

    shiny::observeEvent(input$reset_reporter, {
      shiny::tags$div(
        class = "teal-reporter reporter-modal",
        .custom_css_dependency(),
        shiny::showModal(
          shiny::modalDialog(
            easyClose = TRUE,
            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-outline-secondary",
                `data-bs-dismiss` = "modal",
                NULL,
                "Dismiss"
              ),
              shiny::actionButton(session$ns("reset_reporter_ok"), "Reset", class = "btn btn-primary")
            )
          )
        )
      )
    })

    shiny::observeEvent(reporter$get_cards(), {
      if (length(reporter$get_cards())) {
        shinyjs::enable("reset_reporter")
      } else {
        shinyjs::disable("reset_reporter")
      }
    })

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

# reporter_previewer_content --------------------------------------------------------------------------------------

#' @keywords internal
reporter_previewer_content_ui <- function(id) {
  ns <- shiny::NS(id)
  shiny::tags$div(
    .custom_css_dependency(),
    bslib::accordion(
      id = ns("reporter_cards"),
      class = "teal-reporter report-previewer-accordion"
    ),
    sortable::sortable_js(
      css_id = ns("reporter_cards"),
      options = sortable::sortable_options(
        onSort = sortable::sortable_js_capture_input(ns("reporter_cards_order")),
        handle = ".accordion-icon"
      )
    )
  )
}

#' @keywords internal
reporter_previewer_content_srv <- function(id, reporter) {
  shiny::moduleServer(id, function(input, output, session) {
    shiny::setBookmarkExclude("card_remove_id")

    session$onRestored(function(state) {
      if (is.null(state$dir)) {
        return(NULL)
      }
      reporterdir <- file.path(state$dir, "reporter")
      reporter$from_jsondir(reporterdir)
    })

    shiny::exportTestValues(cards = reporter$get_cards())
    current_ids_rv <- shiny::reactiveVal()
    queues_rv <- list(insert = shiny::reactiveVal(), remove = shiny::reactiveVal())

    shiny::observeEvent(reporter$get_cards(), {
      all_cards <- reporter$get_cards()
      reporter_ids <- names(all_cards)
      current_ids <- current_ids_rv()

      to_add <- !reporter_ids %in% current_ids
      to_remove <- !current_ids %in% reporter_ids
      if (any(to_add)) queues_rv$insert(reporter_ids[to_add])
      if (any(to_remove)) queues_rv$remove(current_ids[to_remove])

      shinyjs::toggle("empty_reporters", condition = length(all_cards) == 0L)
    })

    shiny::observeEvent(queues_rv$insert(), {
      lapply(queues_rv$insert(), function(card_id) {
        current_ids_rv(c(current_ids_rv(), card_id))
      })
    })

    shiny::observeEvent(queues_rv$remove(), {
      lapply(queues_rv$remove(), bslib::accordion_panel_remove, id = "reporter_cards")
    })

    shiny::observeEvent(input$card_remove_id, {
      reporter$remove_cards(ids = input$card_remove_id)
    })

    shiny::observeEvent(input$reporter_cards_order, {
      reporter$reorder_cards(input$reporter_cards_order)
    })
  })
}

previewer_card_ui <- function(id, card_id, show_loading = TRUE) {
  ns <- shiny::NS(id)
  accordion_item <- bslib::accordion_panel(
    value = card_id,
    title = shiny::tags$label(shiny::uiOutput(ns("title"))),
    icon = bslib::tooltip(
      bsicons::bs_icon("arrows-move"),
      "Move card"
    ),
    if (show_loading) {
      shiny::tags$h6(id = ns(paste0("loading_placeholder_", card_id)), class = "text-muted", "Loading the report...")
    },
    shiny::uiOutput(ns("card_content"))
  )
  accordion_item <- shiny::tagAppendAttributes(accordion_item, "data-rank-id" = card_id)

  accordion_item <- shiny::tagAppendAttributes(
    tag = accordion_item,
    .cssSelector = ".accordion-header",
    class = "d-flex",
  )

  accordion_item <- htmltools::tagAppendChildren(
    tag = accordion_item,
    .cssSelector = ".accordion-header",
    ui_previewer_card_actions(ns("actions"))
  )
}

previewer_card_srv <- function(id, card_r, card_id, reporter) {
  shiny::moduleServer(id, function(input, output, session) {
    output$title <- shiny::renderUI({
      title <- metadata(shiny::req(card_r()), "title")
      if (is.null(title) || isFALSE(nzchar(title))) {
        title <- shiny::tags$span("(Empty title)", class = "text-muted")
      }
      title
    })
    output$card_content <- shiny::renderUI({
      result <- reporter$get_cached_html(card_id)
      shiny::removeUI(sprintf("#%s", session$ns(paste0("loading_placeholder_", card_id))))
      result
    })

    srv_previewer_card_actions("actions", card_r, card_id, reporter)
  })
}

#' Render `teal_card`
#' @inheritParams rmarkdown::render
#' @param input (`teal_report` or `teal_code`) object to render.
#' @param global_knitr (`list`) options to apply to every code chunk in a teal_card document.
#'  [Read more here](https://rmarkdown.rstudio.com/lesson-3.html#global-options).
#' @param keep_rmd (`logical(1)`) if `.Rmd` should be kept after rendering to desired `output_format`.
#' @param ... arguments passed to `rmarkdown::render`.
#' @examples
#' report <- teal_report()
#' teal_card(report) <- c(
#'   teal_card(report),
#'   "## Document section",
#'   "Lorem ipsum dolor sit amet"
#' )
#' report <- within(report, a <- 2)
#' report <- within(report, plot(a))
#' metadata(teal_card(report)) <- list(
#'   title = "My Document",
#'   author = "NEST"
#' )
#' if (interactive()) {
#'   render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10))
#' }
#' @export
render <- function(
  input,
  output_dir = getwd(),
  global_knitr = getOption("teal.reporter.global_knitr"),
  keep_rmd = TRUE,
  ...
) {
  checkmate::assert_multi_class(input, c("teal_report", "teal_card", "Reporter"))
  checkmate::assert_string(output_dir)
  checkmate::assert_list(global_knitr, names = "named")
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  checkmate::assert_flag(keep_rmd)
  checkmate::assert_subset(names(list(...)), names(formals(rmarkdown::render)))

  # Set output dir to a new working directory. Absolute paths in rmarkdown files will break .Rmd portability
  dir.create(output_dir, recursive = TRUE, showWarnings = FALSE)
  old_wd <- setwd(dir = output_dir)
  on.exit(setwd(old_wd))

  # This Rmd file is for render purpose as it contains evaluated code chunks and their outputs.
  rmd_filepath <- "report.Rmd"
  temp_rmd_content <- to_rmd(
    block = input,
    global_knitr = c(global_knitr, list(eval = FALSE)), # we don't want to rerun evaluated code chunks to render
    include_chunk_output = TRUE
  )
  cat(temp_rmd_content, file = rmd_filepath)
  args <- utils::modifyList(list(...), list(input = rmd_filepath))
  tryCatch(
    do.call(rmarkdown::render, args),
    finally = {
      report_items <- list.files(pattern = "report_item_")
      unlink(c(rmd_filepath, report_items))
    }
  )

  if (keep_rmd) {
    # This Rmd file doesn't contain chunk_outputs as they can be reproduced when executing code-chunks
    out_rmd_content <- to_rmd(
      block = input,
      global_knitr = global_knitr,
      include_chunk_output = FALSE
    )
    cat(out_rmd_content, file = rmd_filepath)
  }
  output_dir
}

ui_card_editor <- function(id, value, cached_html) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::tags$div(
      id = ns("blocks"),
      lapply(names(value), function(block_name) {
        ui_editor_block(
          shiny::NS(ns("blocks"), block_name),
          value = value[[block_name]],
          cached_html = cached_html[[block_name]]
        )
      })
    ),
    shiny::actionButton(ns("add_block"), label = "Add text block", icon = shiny::icon("plus"))
  )
}

srv_card_editor <- function(id, card_r) {
  shiny::moduleServer(id, function(input, output, session) {
    blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot
    blocks_queue_rv <- shiny::reactiveVal()

    shiny::observeEvent(card_r(), { # Reset on card change
      for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL
      blocks_queue_rv(NULL) # Force retriggering
      blocks_queue_rv(names(card_r()))
    })

    shiny::observeEvent(blocks_queue_rv(), {
      lapply(blocks_queue_rv(), function(block_name) {
        new_block_id <- shiny::NS("blocks", block_name)
        block_content <- card_r()[[block_name]] %||% "" # Initialize as empty string
        blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content)

        if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered
          new_block_ui <- ui_editor_block(
            session$ns(new_block_id),
            value = block_content,
            cached_html = NULL
          )
          shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui)
        }
      })
    })

    shiny::observeEvent(input$add_block, {
      new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1)
      blocks_queue_rv(new_name)
    })

    blocks_inputs_rvs
  })
}

#' @name eval_code-teal_report
#' @rdname eval_code-teal_report
#' @aliases eval_code,teal_report-method
#'
#' @inherit teal.code::eval_code
#' @param object (`teal_report`)
#' @param code_block_opts (`list`) Additional options for the R code chunk in R Markdown.
#' @return `teal_reporter` environment with the code evaluated and the outputs added
#' to the card or `qenv.error` if evaluation fails.
#' @importFrom teal.code eval_code
#'
#' @examples
#' td <- teal.data::teal_data()
#' td <- teal.code::eval_code(td, "iris <- iris")
#' tr <- as.teal_report(td)
#' tr <- teal.code::eval_code(tr, "a <- 1")
#' tr <- teal.code::eval_code(tr, "b <- 2L # with comment")
#' tr <- teal.code::eval_code(tr, quote(library(checkmate)))
#' tr <- teal.code::eval_code(tr, expression(assert_number(a)))
#' teal_card(tr)
setMethod(
  "eval_code",
  signature = c(object = "teal_report"),
  function(object, code, code_block_opts = list(), ...) {
    new_object <- methods::callNextMethod(object = object, code = code, ...)
    if (inherits(new_object, "error")) {
      return(new_object)
    }
    new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts)

    teal_card(new_object) <- c(teal_card(new_object), new_blocks)
    new_object
  }
)

1		#' Load `Reporter` button module
2		#'
3		#' @description
4		#'
5		#' Provides a button to upload `ReporterCard`(s) to the `Reporter`.
6		#'
7		#' For more information, refer to the vignette: `vignette("simpleReporter", "teal.reporter")`.
8		#'
9		#' @name load_report_button
10		#'
11		#' @param id `character(1)` this `shiny` module's id.
12		#' @param label (`character(1)`) label of the button. By default it is empty.
13		#' @param reporter [`Reporter`] instance.
14		NULL
15
16		#' @rdname load_report_button
17		#' @return `shiny::tagList`
18		#' @export
19		report_load_ui <- function(id, label = NULL) {
20	!	checkmate::assert_string(label, null.ok = TRUE)
21	!	.action_button_busy(
22	!	shiny::NS(id, "reporter_load"),
23	!	label = label,
24	!	icon = "upload",
25	!	outline = TRUE
26		)
27		}
28
29		#' @rdname load_report_button
30		#' @return `shiny::moduleServer`
31		#' @export
32		report_load_srv <- function(id, reporter) {
33	15x	checkmate::assert_class(reporter, "Reporter")
34
35	15x	shiny::moduleServer(
36	15x	id,
37	15x	function(input, output, session) {
38	15x	shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load"))
39	15x	ns <- session$ns
40
41		# Set max request size from package option
42	15x	max_size <- getOption("teal.reporter.max_request_size", 10 * 1024^2)
43	15x	options(shiny.maxRequestSize = max_size)
44
45	15x	archiver_modal <- function() {
46	3x	nr_cards <- length(reporter$get_cards())
47	3x	shiny::div(
48	3x	class = "teal-reporter reporter-modal",
49	3x	.custom_css_dependency(),
50	3x	shiny::modalDialog(
51	3x	easyClose = TRUE,
52	3x	shiny::tags$h3("Load the Report"),
53	3x	shiny::tags$hr(),
54	3x	shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)",
55	3x	multiple = FALSE,
56	3x	accept = c(".zip")
57		),
58	3x	footer = shiny::div(
59	3x	shiny::tags$button(
60	3x	type = "button",
61	3x	class = "btn btn-outline-secondary",
62	3x	`data-bs-dismiss` = "modal",
63	3x	NULL,
64	3x	"Dismiss"
65		),
66	3x	shinyjs::disabled(
67	3x	shiny::tags$button(
68	3x	id = ns("reporter_load_main"),
69	3x	type = "button",
70	3x	class = "btn btn-primary action-button",
71	3x	NULL,
72	3x	"Load"
73		)
74		)
75		)
76		)
77		)
78		}
79
80	15x	shiny::observeEvent(input$archiver_zip, {
81	3x	shinyjs::enable(id = "reporter_load_main")
82		})
83
84	15x	shiny::observeEvent(input$reporter_load, {
85	3x	shiny::showModal(archiver_modal())
86		})
87
88	15x	shiny::observeEvent(input$reporter_load_main, {
89	3x	load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]])
90	3x	shiny::removeModal()
91		})
92		}
93		)
94		}
95
96		#' @keywords internal
97		load_json_report <- function(reporter, zip_path, filename) {
98	3x	tmp_dir <- tempdir()
99	3x	output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
100	3x	dir.create(path = output_dir)
101	3x	if (!is.null(zip_path) && grepl("report(er)?_", filename)) {
102	3x	tryCatch(
103	3x	expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE),
104	3x	warning = function(cond) {
105	!	print(cond)
106	!	shiny::showNotification(
107	!	ui = "Unzipping folder warning!",
108	!	action = "Please contact app developer",
109	!	type = "warning"
110		)
111		},
112	3x	error = function(cond) {
113	!	print(cond)
114	!	shiny::showNotification(
115	!	ui = "Unzipping folder error!",
116	!	action = "Please contact app developer",
117	!	type = "error"
118		)
119		}
120		)
121	3x	tryCatch(
122	3x	reporter$from_jsondir(output_dir),
123	3x	warning = function(cond) {
124	!	print(cond)
125	!	shiny::showNotification(
126	!	ui = "Loading reporter warning!",
127	!	action = "Please contact app developer",
128	!	type = "warning"
129		)
130		},
131	3x	error = function(cond) {
132	1x	print(cond)
133	1x	shiny::showNotification(
134	1x	ui = "Loading reporter error!",
135	1x	action = "Please contact app developer",
136	1x	type = "error"
137		)
138		}
139		)
140		} else {
141	!	shiny::showNotification(
142	!	paste(
143	!	"Failed to load the Reporter file.",
144	!	"Please make sure that the filename starts with `report_`."
145		),
146	!	type = "error"
147		)
148		}
149		}
150		1 + 1

1		# reporter_previewer_content --------------------------------------------------------------------------------------
2
3		#' @keywords internal
4		reporter_previewer_content_ui <- function(id) {
5	!	ns <- shiny::NS(id)
6	!	shiny::tags$div(
7	!	.custom_css_dependency(),
8	!	bslib::accordion(
9	!	id = ns("reporter_cards"),
10	!	class = "teal-reporter report-previewer-accordion"
11		),
12	!	sortable::sortable_js(
13	!	css_id = ns("reporter_cards"),
14	!	options = sortable::sortable_options(
15	!	onSort = sortable::sortable_js_capture_input(ns("reporter_cards_order")),
16	!	handle = ".accordion-icon"
17		)
18		)
19		)
20		}
21
22		#' @keywords internal
23		reporter_previewer_content_srv <- function(id, reporter) {
24	11x	shiny::moduleServer(id, function(input, output, session) {
25	11x	shiny::setBookmarkExclude("card_remove_id")
26
27	11x	session$onRestored(function(state) {
28	!	if (is.null(state$dir)) {
29	!	return(NULL)
30		}
31	!	reporterdir <- file.path(state$dir, "reporter")
32	!	reporter$from_jsondir(reporterdir)
33		})
34
35	11x	shiny::exportTestValues(cards = reporter$get_cards())
36	11x	current_ids_rv <- shiny::reactiveVal()
37	11x	queues_rv <- list(insert = shiny::reactiveVal(), remove = shiny::reactiveVal())
38
39	11x	shiny::observeEvent(reporter$get_cards(), {
40	6x	all_cards <- reporter$get_cards()
41	6x	reporter_ids <- names(all_cards)
42	6x	current_ids <- current_ids_rv()
43
44	6x	to_add <- !reporter_ids %in% current_ids
45	6x	to_remove <- !current_ids %in% reporter_ids
46	3x	if (any(to_add)) queues_rv$insert(reporter_ids[to_add])
47	!	if (any(to_remove)) queues_rv$remove(current_ids[to_remove])
48
49	6x	shinyjs::toggle("empty_reporters", condition = length(all_cards) == 0L)
50		})
51
52	11x	shiny::observeEvent(queues_rv$insert(), {
53	3x	lapply(queues_rv$insert(), function(card_id) {
54	3x	current_ids_rv(c(current_ids_rv(), card_id))
55		})
56		})
57
58	11x	shiny::observeEvent(queues_rv$remove(), {
59	!	lapply(queues_rv$remove(), bslib::accordion_panel_remove, id = "reporter_cards")
60		})
61
62	11x	shiny::observeEvent(input$card_remove_id, {
63	!	reporter$remove_cards(ids = input$card_remove_id)
64		})
65
66	11x	shiny::observeEvent(input$reporter_cards_order, {
67	!	reporter$reorder_cards(input$reporter_cards_order)
68		})
69		})
70		}

1		#' Convert content into a `flextable`
2		#'
3		#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
4		#'
5		#' Function merges cells with `colspan` > 1,
6		#' aligns columns to the center and row names to the left,
7		#' indents the row names by 10 times indentation.
8		#'
9		#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
10		#'
11		#' @return `flextable`.
12		#'
13		#' @keywords internal
14		to_flextable <- function(content) {
15	86x	if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
16	42x	ft <- rtables.officer::tt_to_flextable(content)
17	44x	} else if (inherits(content, "listing_df")) {
18	1x	mf <- rlistings::matrix_form(content)
19	1x	nr_header <- attr(mf, "nrow_header")
20	1x	df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
21	1x	header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
22
23	1x	ft <- rtables::df_to_tt(df)
24	1x	if (length(mf$main_title) != 0) {
25	!	rtables::main_title(ft) <- mf$main_title
26		}
27	1x	rtables::subtitles(ft) <- mf$subtitles
28	1x	rtables::main_footer(ft) <- mf$main_footer
29	1x	rtables::prov_footer(ft) <- mf$prov_footer
30	1x	rtables::header_section_div(ft) <- mf$header_section_div
31	1x	ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1))
32	43x	} else if (inherits(content, "data.frame")) {
33	42x	ft <- if (nrow(content) == 0) {
34	!	flextable::flextable(content)
35		} else {
36	42x	rtables.officer::tt_to_flextable(
37	42x	rtables::df_to_tt(content)
38		)
39		}
40		} else {
41	1x	stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
42		}
43
44	85x	ft
45		}
46
47		#' Divide text block into smaller blocks
48		#'
49		#' Split a text block into smaller blocks with a specified number of lines.
50		#'
51		#' A single character string containing a text block of multiple lines (separated by `\n`)
52		#' is split into multiple strings with n or less lines each.
53		#'
54		#' @param x (`character`) string containing the input block of text
55		#' @param n (`integer`) number of lines per block
56		#'
57		#' @return
58		#' List of character strings with up to `n` lines in each element.
59		#'
60		#' @keywords internal
61		split_text_block <- function(x, n) {
62	2x	checkmate::assert_string(x)
63	2x	checkmate::assert_integerish(n, lower = 1L, len = 1L)
64
65	2x	lines <- strsplit(x, "\n")[[1]]
66
67	2x	if (length(lines) <= n) {
68	1x	return(list(x))
69		}
70
71	1x	nblocks <- ceiling(length(lines) / n)
72	1x	ind <- rep(1:nblocks, each = n)[seq_along(lines)]
73	1x	unname(lapply(split(lines, ind), paste, collapse = "\n"))
74		}
75
76		#' Retrieve text details for global_knitr options
77		#' This function returns a character string describing the default settings for the global_knitr options.
78		#' @noRd
79		#' @keywords internal
80		global_knitr_details <- function() {
81	1x	paste0(
82	1x	c(
83	1x	" To access the default values for the `global_knitr` parameter,",
84	1x	" use `getOption('teal.reporter.global_knitr')`. These defaults include:",
85	1x	" - `echo = TRUE`",
86	1x	" - `tidy.opts = list(width.cutoff = 60)`",
87	1x	" - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise"
88		),
89	1x	collapse = "\n"
90		)
91		}
92
93		#' @export
94		#' @keywords internal
95		format.code_chunk <- function(x, ...) {
96	90x	language <- attr(x, "lang", exact = TRUE)
97	90x	params <- attr(x, "params", exact = TRUE)
98	90x	if (language %in% names(knitr::knit_engines$get())) {
99	89x	sprintf(
100	89x	"```{%s}\n%s\n```",
101	89x	toString(c(language, paste(names(params), params, sep = "="))),
102	89x	NextMethod()
103		)
104		} else {
105	1x	sprintf("```%s\n%s\n```", language, NextMethod())
106		}
107		}
108
109		#' Teal action button that is disabled while busy
110		#'
111		#' @inheritParams bslib::input_task_button
112		#' @param id (`character(1)`) the id of the button.
113		#' @param label (`character(1)`) the label of the button.
114		#' @param icon (`character(1)` or `NULL`) the name of the Bootstrap icon to be
115		#' displayed on the button.
116		#' @param additional_class (`character(1)` or `NULL`) additional CSS class to be
117		#' added to the button.
118		#'
119		#' @return A `shiny` action button that is disabled while busy.
120		#' @keywords internal
121		.action_button_busy <- function(id,
122		label,
123		icon = NULL,
124		type = "primary",
125		outline = FALSE,
126		additional_class = NULL) {
127	!	checkmate::assert_string(type)
128	!	checkmate::assert_string(additional_class, null.ok = TRUE)
129	!	shiny::tagList(
130	!	shinyjs::useShinyjs(),
131	!	.custom_css_dependency("outline_button.css"),
132	!	.custom_js_dependency("busy-disable.js", name = "teal-reporter-busy-disable"),
133	!	shiny::tags$button(
134	!	id = id,
135	!	class = c(
136	!	"teal-reporter action-button teal-reporter-busy-disable",
137	!	sprintf("btn btn-%1$s %1$s", trimws(type)),
138	!	if (isTRUE(outline)) "outline-button",
139	!	additional_class
140		),
141	!	role = "button",
142	!	style = "text-decoration: none;",
143	!	if (!is.null(icon)) {
144	!	margin_style <- ifelse(is.null(label), "margin: 0 10px 0 10px;", "")
145	!	shiny::tags$span(
146	!	style = margin_style,
147	!	bsicons::bs_icon(icon, class = sprintf("text-%s", type))
148		)
149		},
150	!	label
151		)
152		)
153		}
154
155		#' @keywords internal
156		.custom_js_dependency <- function(script, name = sprintf("teal-reporter-%s", script)) {
157	2x	htmltools::htmlDependency(
158	2x	name = name,
159	2x	version = utils::packageVersion("teal.reporter"),
160	2x	package = "teal.reporter",
161	2x	src = "js",
162	2x	script = script
163		)
164		}
165
166		#' @keywords internal
167		.custom_css_dependency <- function(stylesheet = "custom.css", name = sprintf("teal-reporter-%s", stylesheet)) {
168	22x	checkmate::assert_string(stylesheet)
169	22x	htmltools::htmlDependency(
170	22x	name = name,
171	22x	version = utils::packageVersion("teal.reporter"),
172	22x	package = "teal.reporter",
173	22x	src = "css",
174	22x	stylesheet = stylesheet
175		)
176		}
177
178		#' @keywords internal
179		.accordion_toggle_js_dependency <- function() { # nolint object_length_linter.
180	2x	.custom_js_dependency("accordion-toggle.js", name = "teal-reporter-accordion-toggle")
181		}
182
183		#' @noRd
184		dummy <- function() {
185	1x	R6::R6Class # Used to trick R CMD check for avoiding NOTE about R6
186	1x	jsonlite::fromJSON # Used to trick R CMD check for not detecting jsonlite usage
187		}

1		#' Render `teal_card`
2		#' @inheritParams rmarkdown::render
3		#' @param input (`teal_report` or `teal_code`) object to render.
4		#' @param global_knitr (`list`) options to apply to every code chunk in a teal_card document.
5		#' [Read more here](https://rmarkdown.rstudio.com/lesson-3.html#global-options).
6		#' @param keep_rmd (`logical(1)`) if `.Rmd` should be kept after rendering to desired `output_format`.
7		#' @param ... arguments passed to `rmarkdown::render`.
8		#' @examples
9		#' report <- teal_report()
10		#' teal_card(report) <- c(
11		#' teal_card(report),
12		#' "## Document section",
13		#' "Lorem ipsum dolor sit amet"
14		#' )
15		#' report <- within(report, a <- 2)
16		#' report <- within(report, plot(a))
17		#' metadata(teal_card(report)) <- list(
18		#' title = "My Document",
19		#' author = "NEST"
20		#' )
21		#' if (interactive()) {
22		#' render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10))
23		#' }
24		#' @export
25		render <- function(
26		input,
27		output_dir = getwd(),
28		global_knitr = getOption("teal.reporter.global_knitr"),
29		keep_rmd = TRUE,
30		...
31		) {
32	20x	checkmate::assert_multi_class(input, c("teal_report", "teal_card", "Reporter"))
33	20x	checkmate::assert_string(output_dir)
34	20x	checkmate::assert_list(global_knitr, names = "named")
35	20x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
36	20x	checkmate::assert_flag(keep_rmd)
37	20x	checkmate::assert_subset(names(list(...)), names(formals(rmarkdown::render)))
38
39		# Set output dir to a new working directory. Absolute paths in rmarkdown files will break .Rmd portability
40	20x	dir.create(output_dir, recursive = TRUE, showWarnings = FALSE)
41	20x	old_wd <- setwd(dir = output_dir)
42	20x	on.exit(setwd(old_wd))
43
44		# This Rmd file is for render purpose as it contains evaluated code chunks and their outputs.
45	20x	rmd_filepath <- "report.Rmd"
46	20x	temp_rmd_content <- to_rmd(
47	20x	block = input,
48	20x	global_knitr = c(global_knitr, list(eval = FALSE)), # we don't want to rerun evaluated code chunks to render
49	20x	include_chunk_output = TRUE
50		)
51	20x	cat(temp_rmd_content, file = rmd_filepath)
52	20x	args <- utils::modifyList(list(...), list(input = rmd_filepath))
53	20x	tryCatch(
54	20x	do.call(rmarkdown::render, args),
55	20x	finally = {
56	20x	report_items <- list.files(pattern = "report_item_")
57	20x	unlink(c(rmd_filepath, report_items))
58		}
59		)
60
61	20x	if (keep_rmd) {
62		# This Rmd file doesn't contain chunk_outputs as they can be reproduced when executing code-chunks
63	20x	out_rmd_content <- to_rmd(
64	20x	block = input,
65	20x	global_knitr = global_knitr,
66	20x	include_chunk_output = FALSE
67		)
68	20x	cat(out_rmd_content, file = rmd_filepath)
69		}
70	20x	output_dir
71		}

1		.content_to_rmd <- function(block, ...) {
2	4x	path <- basename(tempfile(pattern = "report_item_", fileext = ".rds"))
3	4x	suppressWarnings(saveRDS(block, file = path))
4	4x	sprintf("```{r echo = FALSE, eval = TRUE}\nreadRDS('%s')\n```", path)
5		}
6
7		.plot_to_rmd <- function(block, ...) {
8	14x	path <- basename(tempfile(pattern = "report_item_", fileext = ".rds"))
9	14x	suppressWarnings(saveRDS(block, file = path))
10	14x	dims <- .determine_default_dimensions(block, convert_to_inches = TRUE)
11
12	14x	chunk <- if (inherits(block, "grob")) {
13	!	"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\n._figure <- readRDS('%s')\ngrid::grid.newpage()\ngrid::grid.draw(._figure)\n```" # nolint line_length_linter.
14		} else {
15	14x	"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```"
16		}
17
18	14x	sprintf(
19	14x	chunk,
20	14x	dims$width,
21	14x	dims$height,
22	14x	path
23		)
24		}
25
26		#' Convert `ReporterCard`/`teal_card` content to `rmarkdown`
27		#'
28		#' This is an S3 generic that is used to generate content in `rmarkdown` format
29		#' from various types of blocks in a `ReporterCard` or `teal_card` object.
30		#'
31		#' # Customize `to_rmd`
32		#' The methods for this S3 generic can be extended by the app developer or even overwritten.
33		#' For this a function with the name `to_rmd.<class>` should be defined in the
34		#' Global Environment, where `<class>` is the class of the object to be converted.
35		#'
36		#' For example, to override the default behavior for `code_chunk` class, you can use:
37		#'
38		#' ```r
39		#' to_rmd.code_chunk <- function(block, ..., output_format) {
40		#' # custom implementation
41		#' sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block)
42		#' }
43		#' ```
44		#'
45		#' Alternatively, you can register the S3 method using `registerS3method("to_rmd", "<class>", fun)`
46		#'
47		#' @param block (`any`) content which can be represented in Rmarkdown syntax.
48		#' @return `character(1)` containing a content or Rmarkdown document.
49		#' @keywords internal
50		to_rmd <- function(block, ...) {
51	195x	UseMethod("to_rmd")
52		}
53
54		#' @method to_rmd default
55		#' @keywords internal
56		to_rmd.default <- function(block, ...) {
57	195x	.to_rmd(block, ...)
58		}
59
60		.to_rmd <- function(block, ...) {
61	195x	UseMethod(".to_rmd")
62		}
63
64		#' @method .to_rmd default
65		#' @keywords internal
66		.to_rmd.default <- function(block, ...) {
67	!	block
68		}
69
70		#' @method .to_rmd teal_report
71		#' @keywords internal
72		.to_rmd.teal_report <- function(block, ...) {
73	28x	to_rmd(teal_card(block), ...)
74		}
75
76		#' @method .to_rmd teal_card
77		#' @keywords internal
78		.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
79	40x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
80	40x	is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation")
81	40x	powerpoint_exception_parsed <- if (is_powerpoint) {
82	!	format_code_block_function <- quote(
83	!	code_block <- function(code_text) {
84	!	df <- data.frame(code_text)
85	!	ft <- flextable::flextable(df)
86	!	ft <- flextable::delete_part(ft, part = "header")
87	!	ft <- flextable::autofit(ft, add_h = 0)
88	!	ft <- flextable::fontsize(ft, size = 7, part = "body")
89	!	ft <- flextable::bg(x = ft, bg = "lightgrey")
90	!	ft <- flextable::border_outer(ft)
91	!	if (flextable::flextable_dim(ft)$widths > 8) {
92	!	ft <- flextable::width(ft, width = 8)
93		}
94	!	ft
95		}
96		)
97	!	deparse1(format_code_block_function, collapse = "\n")
98		} else {
99	40x	NULL
100		}
101	40x	global_knitr_parsed <- sprintf(
102	40x	"knitr::opts_chunk$set(%s)",
103	40x	paste(utils::capture.output(dput(global_knitr)), collapse = "")
104		)
105	40x	global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE)
106
107	40x	m_yaml <- metadata(block)
108	40x	if ("SRC" %in% names(m_yaml)) {
109	!	m_yaml$SRC <- NULL # TODO: remove when *Block functions are removed from `previewer_deprecated.R`
110		}
111	40x	paste(
112	40x	c(
113	40x	if (length(m_yaml)) as_yaml_auto(m_yaml),
114	40x	if (length(global_knitr) \|\| is_powerpoint) to_rmd(global_knitr_code_chunk),
115	40x	unlist(lapply(
116	40x	block,
117	40x	function(x) to_rmd(x, output_format = m_yaml$output, ...)
118		))
119		),
120	40x	collapse = "\n\n"
121		)
122		}
123
124		#' @method .to_rmd code_chunk
125		#' @keywords internal
126		.to_rmd.code_chunk <- function(block, ..., output_format = NULL) {
127	43x	params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l)
128	43x	block_str <- format(block)
129	43x	lang <- attr(block, "lang", exact = TRUE)
130	43x	if (identical(output_format, "powerpoint_presentation")) {
131	!	block_content_list <- lapply(
132	!	split_text_block(block, 30),
133	!	function(x, lang) {
134	!	code_block <- sprintf("code_block(\n%s)", shQuote(x, type = "cmd"))
135	!	format(code_chunk(code_block, echo = FALSE, lang = lang))
136		},
137	!	lang = lang
138		)
139	!	paste(sprintf("\\newpage\n\n---\n\n%s\n", block_content_list), collapse = "\n\n")
140		} else {
141	43x	format(block)
142		}
143		}
144
145		#' @method .to_rmd character
146		#' @keywords internal
147		.to_rmd.character <- function(block, ...) {
148	54x	block
149		}
150
151		#' @method .to_rmd chunk_output
152		#' @keywords internal
153		.to_rmd.chunk_output <- function(block, ..., include_chunk_output) {
154	8x	if (!missing(include_chunk_output) && isTRUE(include_chunk_output)) {
155	4x	new_block <- block[[1]]
156	4x	mostattributes(new_block) <- c(attributes(unclass(block)), attributes(new_block))
157	4x	to_rmd(new_block, ..., include_chunk_output = include_chunk_output)
158		}
159		}
160
161		#' @method .to_rmd condition
162		#' @keywords internal
163		.to_rmd.condition <- function(block, ...) {
164	!	conditionMessage(block)
165		}
166
167		#' @method .to_rmd gg
168		#' @keywords internal
169		.to_rmd.gg <- .plot_to_rmd
170
171		#' @method .to_rmd trellis
172		#' @keywords internal
173		.to_rmd.trellis <- .plot_to_rmd
174
175		#' @method .to_rmd recordedplot
176		#' @keywords internal
177		.to_rmd.recordedplot <- .plot_to_rmd
178
179		#' @method .to_rmd grob
180		#' @keywords internal
181		.to_rmd.grob <- .plot_to_rmd
182
183		#' @method .to_rmd Heatmap
184		#' @keywords internal
185		.to_rmd.Heatmap <- .plot_to_rmd
186
187		#' @method .to_rmd datatables
188		#' @keywords internal
189		.to_rmd.datatables <- .content_to_rmd
190
191		#' @method .to_rmd summary.lm
192		#' @keywords internal
193		.to_rmd.summary.lm <- .content_to_rmd
194
195		#' @method .to_rmd rtables
196		#' @keywords internal
197		.to_rmd.rtables <- function(block, ...) {
198	4x	flextable_block <- to_flextable(block)
199	4x	attr(flextable_block, "keep") <- attr(block, "keep")
200	4x	to_rmd(flextable_block, ...)
201		}
202
203		#' @method .to_rmd flextable
204		#' @keywords internal
205		.to_rmd.flextable <- .content_to_rmd
206
207		#' @method .to_rmd TableTree
208		#' @keywords internal
209		.to_rmd.TableTree <- .to_rmd.rtables
210
211		#' @method .to_rmd ElementaryTable
212		#' @keywords internal
213		.to_rmd.ElementaryTable <- .to_rmd.rtables
214
215		#' @method .to_rmd rlisting
216		#' @keywords internal
217		.to_rmd.rlisting <- .to_rmd.rtables
218
219		#' @method .to_rmd data.frame
220		#' @keywords internal
221		.to_rmd.data.frame <- .to_rmd.rtables
222
223		#' @method .to_rmd gtsummary
224		#' @keywords internal
225		.to_rmd.gtsummary <- function(block, ...) {
226	!	to_rmd(gtsummary::as_flex_table(block), ...)
227		}
228
229		#' @method .to_rmd listing_df
230		#' @keywords internal
231		.to_rmd.listing_df <- function(block, ...) {
232	!	to_rmd(flextable::as_flextable(block), ...)
233		}
234
235		#' @method .to_rmd ContentBlock
236		#' @keywords internal
237		.to_rmd.ContentBlock <- function(block, ...) {
238	!	to_rmd(block$get_content(), ...)
239		}
240
241		#' @method .to_rmd RcodeBlock
242		#' @keywords internal
243		.to_rmd.RcodeBlock <- function(block, ...) {
244	!	to_rmd(code_chunk(block$get_content(), lang = "R"), ...)
245		}

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

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

1		# deprecated ------------------------------------------------------------------------------------------------------
2
3		#' Report previewer module
4		#'
5		#' @description `r lifecycle::badge("deprecated")`
6		#'
7		#' Module offers functionalities to visualize, manipulate,
8		#' and interact with report cards that have been added to a report.
9		#' It includes a previewer interface to see the cards and options to modify the report before downloading.
10		#'
11		#' Cards are saved by the `shiny` bookmarking mechanism.
12		#'
13		#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
14		#'
15		#' This function is deprecated and will be removed in the next release.
16		#' Please use `preview_report_button_ui()` and `preview_report_button_srv()`
17		#' to create a preview button that opens a modal with the report preview.
18		#'
19		#' @details `r global_knitr_details()`
20		#'
21		#' @name reporter_previewer_deprecated
22		#'
23		#' @param id (`character(1)`) `shiny` module instance id.
24		#' @param reporter (`Reporter`) instance.
25		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
26		#' for customizing the rendering process.
27		#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible
28		#' values and `"download"` is required.
29		#' Default `c("download", "load", "reset")`
30		#' @inheritParams reporter_download_inputs
31		#'
32		#' @return `NULL`.
33		NULL
34
35		#' @rdname reporter_previewer_deprecated
36		#' @export
37		reporter_previewer_ui <- function(id) {
38	!	ns <- shiny::NS(id)
39	!	lifecycle::deprecate_soft(
40	!	when = "0.6.0",
41	!	what = "reporter_previewer_ui()",
42	!	details = paste(
43	!	"Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n",
44	!	"Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,",
45	!	"and `preview_report_button_ui()` instead."
46		)
47		)
48	!	bslib::page_fluid(
49	!	shiny::tagList(
50	!	shinyjs::useShinyjs(),
51	!	shiny::singleton(
52	!	shiny::tags$head(
53	!	shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")),
54	!	shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter"))
55		)
56		),
57
58		# Extend shinyjs::js to include function defined in extendShinyJs.js
59	!	shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
60	!	shiny::tags$div(
61	!	class = "well",
62	!	style = "display: inline-flex; flex-direction: row; gap: 10px;",
63	!	shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")),
64	!	shiny::tags$span(
65	!	id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report")
66		),
67	!	shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report"))
68		),
69	!	shiny::tags$div(reporter_previewer_content_ui(ns("previewer")))
70		)
71		)
72		}
73
74		#' @rdname reporter_previewer_deprecated
75		#' @export
76		reporter_previewer_srv <- function(id,
77		reporter,
78		global_knitr = getOption("teal.reporter.global_knitr"),
79		rmd_output = getOption("teal.reporter.rmd_output"),
80		rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"),
81		previewer_buttons = c("download", "load", "reset")) {
82	11x	lifecycle::deprecate_soft(
83	11x	when = "0.6.0",
84	11x	what = "reporter_previewer_srv()",
85	11x	details = paste(
86	11x	"Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n",
87	11x	"Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,",
88	11x	"and `preview_report_button_srv()` instead."
89		)
90		)
91	11x	checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE)
92	11x	checkmate::assert_true("download" %in% previewer_buttons)
93	10x	checkmate::assert_class(reporter, "Reporter")
94	10x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
95	10x	checkmate::assert_subset(
96	10x	rmd_output,
97	10x	c("html_document", "pdf_document", "powerpoint_presentation", "word_document"),
98	10x	empty.ok = FALSE
99		)
100	10x	checkmate::assert_list(rmd_yaml_args, names = "named")
101	10x	checkmate::assert_names(
102	10x	names(rmd_yaml_args),
103	10x	subset.of = c("author", "title", "date", "output", "toc"),
104	10x	must.include = "output"
105		)
106	8x	checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
107
108	7x	shiny::moduleServer(id, function(input, output, session) {
109	7x	if (!"load" %in% previewer_buttons) {
110	1x	shinyjs::hide(id = "load_span")
111		}
112	7x	if (!"download" %in% previewer_buttons) {
113	!	shinyjs::hide(id = "download_span")
114		}
115	7x	if (!"reset" %in% previewer_buttons) {
116	1x	shinyjs::hide(id = "reset_span")
117		}
118	7x	report_load_srv("load", reporter = reporter)
119	7x	download_report_button_srv(
120	7x	"download",
121	7x	reporter = reporter,
122	7x	global_knitr = global_knitr,
123	7x	rmd_output = rmd_output,
124	7x	rmd_yaml_args = rmd_yaml_args
125		)
126	7x	reset_report_button_srv("reset", reporter = reporter)
127	7x	reporter_previewer_content_srv("previewer", reporter = reporter)
128		})
129		}
130
131		#' @noRd
132		ContentBlock <- R6::R6Class( # nolint: object_name_linter.
133		classname = "ContentBlock",
134		public = list(
135		set_content = function(content) {
136	!	private$content <- content
137	!	invisible(self)
138		},
139	!	get_content = function() private$content,
140	!	from_list = function(x) invisible(self),
141	!	to_list = function() list()
142		),
143		private = list(
144		content = NULL,
145		deep_clone = function(name, value) {
146	!	if (name == "content" && checkmate::test_file_exists(value)) {
147	!	extension <- ""
148	!	split <- strsplit(basename(value), split = "\\.")
149		# The below ensures no extension is found for files such as this: .gitignore but is found for files like
150		# .gitignore.txt
151	!	if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
152	!	extension <- split[[1]][length(split[[1]])]
153	!	extension <- paste0(".", extension)
154		}
155	!	copied_file <- tempfile(fileext = extension)
156	!	file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
157	!	copied_file
158		} else {
159	!	value
160		}
161		}
162		),
163		lock_objects = TRUE,
164		lock_class = TRUE
165		)
166
167		#' @noRd
168		RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
169		classname = "RcodeBlock",
170		inherit = ContentBlock,
171		public = list(
172		initialize = function(content = character(0), ...) {
173	!	checkmate::assert_class(content, "character")
174	!	super$set_content(content)
175	!	self$set_params(list(...))
176	!	invisible(self)
177		},
178		set_content = function(content) {
179	!	checkmate::assert_string(content)
180	!	super$set_content(content)
181		},
182		set_params = function(params) {
183	!	checkmate::assert_list(params, names = "named")
184	!	checkmate::assert_subset(names(params), self$get_available_params())
185	!	private$params <- params
186	!	invisible(self)
187		},
188	!	get_params = function() private$params,
189	!	get_available_params = function() names(knitr::opts_chunk$get()),
190		from_list = function(x) {
191	!	checkmate::assert_list(x)
192	!	checkmate::assert_names(names(x), must.include = c("text", "params"))
193	!	self$set_content(x$text)
194	!	self$set_params(x$params)
195	!	invisible(self)
196		},
197	!	to_list = function() list(text = self$get_content(), params = self$get_params())
198		),
199		private = list(
200		content = character(0),
201		params = list()
202		),
203		lock_objects = TRUE,
204		lock_class = TRUE
205		)
206
207		#' @noRd
208		TextBlock <- R6::R6Class( # nolint: object_name_linter.
209		classname = "TextBlock",
210		inherit = ContentBlock,
211		public = list(
212		initialize = function(content = character(0), style = private$styles[1]) {
213	!	super$set_content(content)
214	!	self$set_style(style)
215	!	invisible(self)
216		},
217		set_content = function(content) {
218	!	checkmate::assert_string(content)
219	!	super$set_content(content)
220		},
221		get_content = function() {
222	!	if (private$style == "verbatim") {
223	!	return(sprintf("```\n%s\n```\n", private$content))
224		}
225	!	sprintf(
226	!	"%s%s",
227	!	switch(private$style,
228	!	header2 = "## ",
229	!	header3 = "### ",
230		""
231		),
232	!	private$content
233		)
234		},
235		set_style = function(style) {
236	!	private$style <- match.arg(style, private$styles)
237	!	invisible(self)
238		},
239	!	get_style = function() private$style,
240	!	get_available_styles = function() private$styles,
241		from_list = function(x) {
242	!	checkmate::assert_list(x)
243	!	checkmate::assert_names(names(x), must.include = c("text", "style"))
244	!	self$set_content(x$text)
245	!	self$set_style(x$style)
246	!	invisible(self)
247		},
248	!	to_list = function() list(text = self$get_content(), style = self$get_style())
249		),
250		private = list(
251		content = character(0),
252		style = character(0),
253		styles = c("default", "header2", "header3", "verbatim")
254		),
255		lock_objects = TRUE,
256		lock_class = TRUE
257		)

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

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

1		#' @title `teal_card`: An `S3` class for managing `teal` reports
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' The `teal_card` `S3` class provides functionality to store, manage, edit, and adjust report contents.
6		#' It enables users to create, manipulate, and serialize report-related data efficiently.
7		#'
8		#' The `teal_card()` function serves two purposes:
9		#' 1. When called with a `teal_report` object, it acts as a getter and returns the card slot.
10		#' 2. When called with other arguments, it creates a new `teal_card` object from those arguments.
11		#'
12		#' @return An `S3` `list` of class `teal_card`.
13		#' @param ... Elements from which `teal_card` will be combined.
14		#'
15		#' @details The `teal_card` class supports `c()` and `x[i]` methods for combining and subsetting elements.
16		#' However, these methods only function correctly when the first element is a `teal_card`.
17		#'
18		#' @seealso [code_chunk()], [render()], [toHTML()]
19		#'
20		#' @examples
21		#' # create an empty card
22		#' report <- teal_card()
23		#'
24		#' # Create a card with content
25		#' report <- teal_card(
26		#' "## Headline",
27		#' "This is `iris` table",
28		#' code_chunk("print(iris)", lang = "R"),
29		#' iris
30		#' )
31		#'
32		#' # Add elements to the report
33		#' report <- c(
34		#' report,
35		#' list("## mtcars Table"),
36		#' code_chunk("print(mtcars)", lang = "R"),
37		#' mtcars
38		#' )
39		#'
40		#' # Subset the report to keep only the first two elements
41		#' report[1:2]
42		#'
43		#' # Replace element
44		#' report[[1]] <- "## Iris Table"
45		#'
46		#' # Append element
47		#' report <- append(report, teal_card("# Awesome Report"), after = 0)
48		#' tools::toHTML(report)
49		#'
50		#' if (interactive()) {
51		#' render(report, output_format = rmarkdown::pdf_document())
52		#' }
53		#'
54		#' @aliases teal_card
55		#' @name teal_card
56		#'
57		#' @export
58		teal_card <- function(...) {
59	846x	UseMethod("teal_card")
60		}
61
62		#' @export
63		#' @keywords internal
64		teal_card.default <- function(...) {
65	658x	x <- lapply(list(...), .convert_teal_card_input)
66
67	658x	if (length(x) > 0) {
68	384x	names(x) <- vapply(
69	384x	sample.int(.Machine$integer.max, size = length(x)),
70	384x	function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8),
71	384x	character(1)
72		)
73		}
74	658x	structure(x, class = "teal_card")
75		}
76
77		#' @export
78		#' @keywords internal
79		teal_card.teal_card <- function(...) {
80	95x	dots <- list(...)
81	95x	c(dots[[1]], dots[-1])
82		}
83
84		#' @export
85		#' @keywords internal
86		teal_card.teal_report <- function(...) {
87	90x	dots <- list(...)
88	90x	dots[[1]] <- dots[[1]]@teal_card
89	90x	do.call(teal_card, args = dots)
90		}
91
92		#' @export
93		#' @keywords internal
94		teal_card.qenv <- function(...) {
95	3x	dots <- list(...)
96	3x	dots[[1]] <- .code_to_card(dots[[1]]@code)
97	3x	do.call(teal_card, args = dots)
98		}
99
100		#' @rdname teal_card
101		#' @param value (`teal_card`) object to set in the `teal_report`.
102		#' @export
103		`teal_card<-` <- function(x, value) {
104	47x	x <- methods::as(x, "teal_report")
105	47x	checkmate::assert_class(x, "teal_report")
106	47x	x@teal_card <- as.teal_card(value)
107	47x	x
108		}
109
110		#' @export
111		`[[<-.teal_card` <- function(x, index, value) {
112	8x	new_card <- as.teal_card(value)
113	8x	value <- new_card[[1]]
114	8x	new_x <- NextMethod()
115	8x	if (checkmate::test_integerish(index)) {
116	2x	names(new_x)[[index]] <- names(new_card)[[1]]
117		}
118	8x	new_x
119		}
120
121		#' Create or coerce to a teal_card
122		#'
123		#' This function ensures that input is converted to a teal_card object.
124		#' It accepts various input types and converts them appropriately.
125		#'
126		#' @param x Object to convert to teal_card
127		#' @return A teal_card object
128		#' @rdname teal_card
129		#' @export
130		as.teal_card <- function(x) { # nolint: object_name.
131	864x	if (inherits(x, "teal_card")) {
132	541x	if (length(x) && !checkmate::test_names(names(x), type = "unique")) { # Fix names if not unique or missing
133	59x	names(x) <- substr(
134	59x	vapply(seq_len(length(x)), function(ix) rlang::hash(list(ix, Sys.time(), x[[ix]])), character(1L)),
135	59x	1,
136	59x	8
137		)
138		}
139	541x	return(x)
140		}
141	323x	if (identical(class(x), "list")) {
142	102x	return(do.call(teal_card, unname(x)))
143		}
144	221x	teal_card(x)
145		}
146
147		#' @rdname teal_card
148		#' @export
149		c.teal_card <- function(...) {
150	330x	dots <- list(...)
151	330x	structure(
152	330x	Reduce(
153	330x	f = function(u, v) {
154	743x	v <- as.teal_card(v)
155	743x	if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u
156	3x	if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v`
157	2x	v
158		} else {
159	1x	warning(
160	1x	"Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n",
161	1x	"Restoring original content and adding only new items to the end of the card."
162		)
163	1x	utils::modifyList(u, v)
164		}
165		} else {
166	740x	attrs <- utils::modifyList(attributes(u) %\|\|% list(), attributes(v))
167	740x	attrs$names <- union(names(u), names(v))
168	740x	attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %\|\|% list(), metadata(v))
169	740x	result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass
170	740x	attributes(result) <- attrs
171	740x	result
172		}
173		},
174	330x	x = dots,
175	330x	init = list()
176		),
177	330x	class = "teal_card"
178		)
179		}
180
181		#' @param i index specifying elements to extract or replace
182		#' @rdname teal_card
183		#' @export
184		`[.teal_card` <- function(x, i) {
185	5x	out <- NextMethod()
186	5x	class(out) <- "teal_card"
187	5x	attr(out, "metadata") <- metadata(x)
188	5x	out
189		}
190
191		#' Access metadata from a `teal_card` or `ReportCard`
192		#'
193		#' This function retrieves metadata from a `teal_card` or `ReportCard` object.
194		#' When `which` is `NULL`, it returns all metadata fields as a list.
195		#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata.
196		#' @param which (`character` or `NULL`) The name of the metadata field to extract.
197		#' @return A list of metadata fields or a specific field if `which` is provided.
198		#' @export
199		metadata <- function(object, which = NULL) {
200	1197x	checkmate::assert_string(which, null.ok = TRUE)
201	1197x	UseMethod("metadata", object)
202		}
203
204		#' @rdname metadata
205		#' @export
206		metadata.teal_card <- function(object, which = NULL) {
207	1193x	metadata <- attr(object, which = "metadata", exact = TRUE)
208	1193x	result <- metadata %\|\|% list()
209	1193x	if (is.null(which)) {
210	1102x	return(result)
211		}
212	91x	result[[which]]
213		}
214
215		#' @rdname metadata
216		#' @export
217		metadata.ReportCard <- function(object, which = NULL) {
218	4x	result <- list(title = object$get_name())
219	4x	if (is.null(which)) {
220	1x	return(result)
221		}
222	3x	result[[which]]
223		}
224
225		#' Set metadata for a `teal_card` or `ReportCard`
226		#'
227		#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object.
228		#' It can be used to add new metadata or update existing fields.
229		#' @param object (`teal_card` or `ReportCard`) The object to modify.
230		#' @param which (`character`) The name of the metadata field to set.
231		#' @param value The value to assign to the specified metadata field.
232		#' @return The modified object with updated metadata.
233		#' @export
234		`metadata<-` <- function(object, which = NULL, value) {
235	283x	checkmate::assert_string(which, null.ok = TRUE)
236	283x	UseMethod("metadata<-", object)
237		}
238
239		#' @rdname metadata-set
240		#' @export
241		`metadata<-.teal_card` <- function(object, which = NULL, value) {
242	266x	if (missing(which)) {
243	194x	checkmate::assert_list(value, names = "named")
244	194x	attr(object, which = "metadata") <- value
245	194x	return(object)
246		}
247	72x	attr(object, which = "metadata") <- utils::modifyList(
248	72x	metadata(object), structure(list(value), names = which)
249		)
250	72x	object
251		}
252
253		#' @rdname metadata-set
254		#' @details
255		#' The `ReportCard` class only supports the `title` field in metadata.
256		#' @export
257		`metadata<-.ReportCard` <- function(object, which, value) {
258	17x	if (missing(which)) {
259	3x	if (!is.null(value[["title"]])) {
260	2x	object$set_name(value[["title"]])
261		}
262	3x	if (length(value) >= 2 \|\| length(value) == 1 && is.null(value[["title"]])) {
263	2x	warning("ReportCard class only supports `title` in metadata.")
264		}
265	3x	return(object)
266		}
267
268	14x	if (isFALSE(identical(which, "title"))) {
269	1x	warning("ReportCard class only supports `title` in metadata.")
270		} else {
271	13x	object$set_name(value)
272		}
273	14x	object
274		}
275
276		#' Generate a code chunk
277		#'
278		#' @description
279		#' This function creates a `code_chunk` object that represents code to be displayed
280		#' in a report. It stores the code of any language (see `lang` argument) and any
281		#' specified chunk options (e.g., `echo`, `eval`).
282		#'
283		#' @details
284		#' Important Notes:
285		#' - The code is not evaluated; it is only stored as text with formatting attributes.
286		#' - When converted to output, `code_chunk` produces markdown code block syntax
287		#' (` ```{lang} ... ``` `) or HTML `<pre><code>...</code></pre>` blocks.
288		#' - The document is not rendered using `rmarkdown::render`. The `code_chunk` is part
289		#' of the `teal_card` API for building reproducible documents that are produced as-is.
290		#'
291		#' Typical Workflow:
292		#' 1. Create a `code_chunk` object with your code and options
293		#' 2. Add it to a `teal_card` using `teal_card()` or `c()`
294		#' 3. The card produces the formatted code block in the final document output
295		#'
296		#' @param code (`character`) The code to be displayed in the code chunk.
297		#' @param ... Additional named parameters to be included as chunk options. These control
298		#' how the chunk behaves when rendered (e.g., `echo = TRUE`, `eval = FALSE`,
299		#' `message = FALSE`). See [`knitr` options](https://yihui.org/knitr/options/) for
300		#' available options.
301		#' @param lang (`character(1)`) The language of the code chunk. Defaults to `"R"`.
302		#' See [`knitr::knit_engines`] for supported languages (e.g., "python", "bash").
303		#'
304		#' @return An object of class `code_chunk`
305		#' @seealso
306		#' - [teal_card()] for creating report cards that can contain `code_chunk` objects
307		#'
308		#' @examples
309		#' # Basic code chunk with options
310		#' code_chunk("x <- 1:10", echo = TRUE, message = FALSE)
311		#'
312		#' # Python code chunk
313		#' code_chunk("import pandas as pd", lang = "python", eval = FALSE)
314		#'
315		#' # Code chunk with multiple knitr options
316		#' code_chunk(
317		#' "plot(mtcars$mpg, mtcars$hp)",
318		#' echo = TRUE,
319		#' eval = TRUE,
320		#' fig.width = 7,
321		#' fig.height = 5,
322		#' warning = FALSE
323		#' )
324		#'
325		#' @export
326		code_chunk <- function(code, ..., lang = "R") {
327	127x	checkmate::assert_character(code)
328	127x	checkmate::assert_string(lang)
329	127x	params <- list(...)
330	127x	checkmate::assert_list(params, names = "named", .var.name = "...")
331	127x	structure(
332	127x	paste(code, collapse = "\n"),
333	127x	params = params,
334	127x	lang = lang,
335	127x	class = "code_chunk"
336		)
337		}
338
339
340		#' Builds `teal_card` from code and outputs in `qenv` object
341		#'
342		#' Builds a `teal_card` from the code and outputs of a `teal_data`
343		#' object, preserving the order of code execution and output display.
344		#'
345		#' @inheritParams eval_code-teal_report
346		#' @param x (`list`) object from `qenv@code`.
347		#' @return A `teal_card` built from the code and outputs in a `qenv` object.
348		#' @keywords internal
349		.code_to_card <- function(x, code_block_opts = list()) {
350	32x	elems <- Reduce(
351	32x	function(items, code_elem) {
352	64x	this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts))
353	64x	this_outs <- Filter( # intentionally remove warnings,messages from the generated report
354	64x	function(x) !inherits(x[[1]], "condition"),
355	64x	lapply(
356	64x	attr(code_elem, "outputs"),
357	64x	function(x) structure(list(x), class = c("chunk_output"))
358		)
359		)
360	64x	c(items, list(this_chunk), this_outs)
361		},
362	32x	init = list(),
363	32x	x = x
364		)
365	32x	do.call(teal_card, args = elems)
366		}
367
368		#' Internal helper for `teal_card`` input conversion
369		#'
370		#' Converts input values to a format compatible with `teal_card`.
371		#' This function is used internally to handle common inputs, such as `ggplot` objects,
372		#' ensuring they are appropriately converted to an "evaluable output" blocks that can
373		#' be saved to `RDS` file efficiently.
374		#'
375		#' This function performs the following conversions:
376		#' - `ggplot` objects are converted to `recordedplot` objects.
377		#'
378		#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`,
379		#' no conversion is applied.
380		#'
381		#' @param x (`object`) An object to be converted.
382		#'
383		#' @return The processed object, possibly converted or left unchanged.
384		#'
385		#' @keywords internal
386		.convert_teal_card_input <- function(x) {
387	660x	if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) {
388	16x	return(x)
389		}
390	644x	if (inherits(x, "chunk_output")) {
391	28x	res <- structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output"))
392	28x	attributes(res) <- attributes(x) # keep same attributes
393	28x	res
394	616x	} else if (inherits(x, "ggplot")) {
395	52x	.ggplot_to_recordedplot(x)
396		} else {
397	564x	x
398		}
399		}
400
401		#' @noRd
402		.ggplot_to_recordedplot <- function(x) {
403	52x	checkmate::assert_class(x, "ggplot")
404	52x	grDevices::pdf(file = NULL)
405	52x	grDevices::dev.control(displaylist = "enable")
406	52x	dev <- grDevices::dev.cur()
407	52x	on.exit(grDevices::dev.off(dev))
408	52x	print(x)
409	52x	grDevices::recordPlot()
410		}
411
412		#' Determine default dimensions for report figures
413		#'
414		#' @param x An object, typically a `recordedplot` or `ggplot`, that has an
415		#' optional attributes `dev.width` and `dev.height` that override the default
416		#' dims set as options `teal.reporter.dev.fig.width` and
417		#' `teal.reporter.dev.fig.height`.
418		#' @return List with `width` and `height` elements.
419		#' @keywords internal
420		.determine_default_dimensions <- function(x, convert_to_inches = FALSE, dpi = 96) {
421	73x	checkmate::assert_flag(convert_to_inches)
422	73x	width <- attr(x, "dev.width") %\|\|% getOption("teal.reporter.dev.fig.width", 800)
423	73x	height <- attr(x, "dev.height") %\|\|% getOption("teal.reporter.dev.fig.height", 600)
424	73x	if (width < 150 \|\| height < 150) {
425	!	warning("Figure dimensions too small, setting to minimum of 150x150 pixels.")
426	!	width <- max(width, 150)
427	!	height <- max(height, 150)
428		}
429
430	73x	if (convert_to_inches) {
431	16x	width <- width / dpi
432	16x	height <- height / dpi
433		}
434	73x	list(width = width, height = height)
435		}

1		#' Concatenate `teal_report` objects
2		#'
3		#' @param ... (`teal_report`) objects to concatenate
4		#'
5		#' @return A [`teal_report`] object with combined [`teal_card`] elements.
6		#'
7		#' @export
8		#' @method c teal_report
9		c.teal_report <- function(...) {
10	53x	result <- NextMethod()
11	53x	l <- Filter(function(x) inherits(x, "teal_report"), list(...))
12	53x	if (length(l) > 1) {
13	4x	teal_card(result) <- do.call(c, lapply(l, teal_card))
14		}
15	53x	result
16		}

1		#' @title `Reporter`: An `R6` class for managing reports
2		#' @docType class
3		#' @description
4		#'
5		#' This `R6` class is designed to store and manage reports,
6		#' facilitating the creation, manipulation, and serialization of report-related data.
7		#' It supports both `ReportCard` and `teal_card` objects, allowing flexibility
8		#' in the types of reports that can be stored and managed.
9		#'
10		#' @export
11		#'
12		Reporter <- R6::R6Class( # nolint: object_name_linter.
13		classname = "Reporter",
14		public = list(
15		#' @description Initialize a `Reporter` object.
16		#'
17		#' @return Object of class `Reporter`, invisibly.
18		#' @examples
19		#' reporter <- Reporter$new()
20		#'
21		initialize = function() {
22	96x	private$cards <- shiny::reactiveValues()
23	96x	private$cached_html <- shiny::reactiveValues()
24	96x	private$open_previewer_r <- shiny::reactiveVal(NULL)
25	96x	invisible(self)
26		},
27		#' @description Append one or more `ReportCard` or `teal_card` objects to the `Reporter`.
28		#'
29		#' @param cards (`ReportCard` or `teal_card`) or a list of such objects
30		#' @return `self`, invisibly.
31		#' @examplesIf require("ggplot2")
32		#' library(ggplot2)
33		#'
34		#' card1 <- teal_card("## Header 2 text", "A paragraph of default text")
35		#' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram())
36		#' metadata(card1, "title") <- "Card1"
37		#'
38		#' card2 <- teal_card("Document introduction")
39		#' metadata(card2, "title") <- "Card2"
40		#'
41		#' reporter <- Reporter$new()
42		#' reporter$append_cards(list(card1, card2))
43		append_cards = function(cards) {
44	83x	if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) {
45	13x	cards <- list(cards)
46		}
47
48	83x	checkmate::assert_list(cards, types = c("ReportCard", "teal_card"))
49	83x	new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content())
50
51	83x	if (!is.null(self$get_template())) {
52	2x	new_cards <- lapply(new_cards, self$get_template())
53		}
54
55		# Set up unique id for each card
56	83x	names(new_cards) <- vapply(new_cards, function(card) {
57	126x	sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8))
58	83x	}, character(1L))
59
60	83x	for (card_id in names(new_cards)) {
61	126x	card <- new_cards[[card_id]]
62	126x	private$cards[[card_id]] <- card
63	126x	private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
64		}
65	83x	invisible(self)
66		},
67		#' @description Reorders `teal_card` objects in `Reporter`.
68		#' @param new_order `character` vector with names of `teal_card` objects to
69		#' be set in this order.
70		#' @description Reorders `teal_card` objects in `Reporter`.
71		#' @return `self`, invisibly.
72		#' @examplesIf require("ggplot2") && require("rtables")
73		#' library(rtables)
74		#' # With the card1 from above
75		#' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
76		#' table_res2 <- build_table(lyt, airquality)
77		#' card2 <- teal_card(
78		#' "## Header 2 text",
79		#' "A paragraph of default text",
80		#' table_res2
81		#' )
82		#' metadata(card2, "title") <- "Card2"
83		#'
84		#' reporter <- Reporter$new()
85		#' reporter$append_cards(list(card1, card2))
86		#'
87		#' names(reporter$get_cards())
88		#' reporter$reorder_cards(c("Card2", "Card1"))
89		#' names(reporter$get_cards())
90		reorder_cards = function(new_order) {
91	3x	private$override_order <- new_order
92	3x	invisible(self)
93		},
94		#' @description Sets `ReportCard` or `teal_card` content.
95		#' @param card_id (`character(1)`) the unique id of the card to be replaced.
96		#' @param card The new object (`ReportCard` or `teal_card`) to replace the existing one.
97		#' @return `self`, invisibly.
98		#' @examplesIf require("ggplot2")
99		#' # With card1 and card2 from above
100		#'
101		#' metadata(reporter$get_cards()[[1]], "title")
102		#' reporter$replace_card(card2, names(reporter$get_cards())[[1]])
103		#' metadata(reporter$get_cards()[[1]], "title")
104		replace_card = function(card, card_id) {
105	1x	if (inherits(card, "ReportCard")) {
106	!	card <- card$get_content()
107		}
108	1x	private$cards[[card_id]] <- card
109	1x	private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
110	1x	invisible(self)
111		},
112		#' @description Retrieves all `teal_card` objects contained in `Reporter`.
113		#' @return A (`list`) of [`teal_card`] objects.
114		#' @examplesIf require("ggplot2")
115		#' # With card1 and card2 from above
116		#'
117		#' reporter <- Reporter$new()
118		#' reporter$append_cards(list(card1, card2))
119		#' reporter$get_cards()
120		get_cards = function() {
121	215x	result <- if (shiny::isRunning()) {
122	!	shiny::reactiveValuesToList(private$cards)
123		} else {
124	215x	shiny::isolate(shiny::reactiveValuesToList(private$cards))
125		}
126	215x	result <- Filter(Negate(is.null), result) # Exclude all cards that were removed
127		# Ensure that cards added after reorder are returned (as well as reordered ones that were removed are excluded)
128	215x	result[union(intersect(private$override_order, names(result)), names(result))]
129		},
130		#' @description Compiles and returns all content blocks from the `teal_card`
131		#' objects in the `Reporter`.
132		#' @param sep An optional separator to insert between each content block.
133		#' Default is a `\n\\newpage\n` markdown.
134		#' @return `list()` of `teal_card`
135		#' @examplesIf require("ggplot2")
136		#' # With card1 and card2 from above
137		#'
138		#' reporter <- Reporter$new()
139		#' reporter$append_cards(list(card1, card2))
140		#' reporter$get_blocks()
141		get_blocks = function(sep = "\\newpage") {
142	48x	cards <- self$get_cards()
143	48x	blocks <- teal_card()
144	48x	for (idx in seq_along(cards)) {
145	59x	card <- unname(cards[[idx]]) # unname to avoid names conflict in c()
146	59x	title <- trimws(metadata(card, "title"))
147	59x	metadata(card)$title <- NULL
148
149	59x	card_title <- if (length(title) > 0 && nzchar(title)) {
150	8x	sprintf("# %s", title)
151		} else {
152	51x	sprintf("# _Unnamed Card (%d)_", idx)
153		}
154	59x	blocks <- c(blocks, as.teal_card(card_title), card)
155	11x	if (idx != length(cards) && length(sep)) blocks <- c(blocks, trimws(sep))
156		}
157	48x	blocks
158		},
159		#' @description Resets the `Reporter`, removing all `teal_card` objects and metadata.
160		#'
161		#' @return `self`, invisibly.
162		#'
163		reset = function() {
164	27x	if (shiny::isRunning()) {
165	!	for (card_id in names(private$cards)) private$cards[[card_id]] <- NULL
166		} else {
167	27x	private$cards <- shiny::reactiveValues()
168		}
169	27x	private$override_order <- character(0L)
170	27x	private$metadata <- list()
171	27x	invisible(self)
172		},
173		#' @description Removes specific `teal_card` objects from the `Reporter` by their indices.
174		#'
175		#' @param ids (`integer`, `character`) the indexes of cards (either name)
176		#' @return `self`, invisibly.
177		remove_cards = function(ids = NULL) {
178	2x	checkmate::assert(
179	2x	checkmate::check_null(ids),
180	2x	checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards)),
181	2x	checkmate::check_character(ids, min.len = 1, max.len = length(private$cards))
182		)
183	2x	for (card_id in ids) {
184	2x	private$cards[[card_id]] <- NULL
185		}
186	2x	invisible(self)
187		},
188		#' @description Get the metadata associated with this `Reporter`.
189		#'
190		#' @return `named list` of metadata to be appended.
191		#' @examples
192		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
193		#' reporter$get_metadata()
194		#'
195	39x	get_metadata = function() private$metadata,
196		#' @description Appends metadata to this `Reporter`.
197		#'
198		#' @param meta (`named list`) of metadata to be appended.
199		#' @return `self`, invisibly.
200		#' @examples
201		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
202		#' reporter$get_metadata()
203		#'
204		append_metadata = function(meta) {
205	31x	checkmate::assert_list(meta, names = "unique")
206	25x	checkmate::assert_true(length(meta) == 0 \|\| all(!names(meta) %in% names(private$metadata)))
207	23x	private$metadata <- append(private$metadata, meta)
208	23x	invisible(self)
209		},
210		#' @description
211		#' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
212		#' @param reporter (`Reporter`) instance to copy from.
213		#' @return invisibly self
214		#' @examples
215		#' reporter <- Reporter$new()
216		#' reporter$from_reporter(reporter)
217		from_reporter = function(reporter) {
218	10x	lifecycle::deprecate_warn("0.6.0", "Reporter$from_reporter()")
219	10x	checkmate::assert_class(reporter, "Reporter")
220	10x	self$reset()
221	10x	self$append_cards(reporter$get_cards())
222	10x	self$append_metadata(reporter$get_metadata())
223	10x	invisible(self)
224		},
225		#' @description Convert a `Reporter` to a list and transfer any associated files to specified directory.
226		#' @param output_dir (`character(1)`) a path to the directory where files will be copied.
227		#' @return `named list` representing the `Reporter` instance, including version information,
228		#' metadata, and report cards.
229		#' @examples
230		#' reporter <- Reporter$new()
231		#' tmp_dir <- file.path(tempdir(), "testdir")
232		#' dir.create(tmp_dir)
233		#' reporter$to_list(tmp_dir)
234		to_list = function(output_dir) {
235	17x	checkmate::assert_directory_exists(output_dir)
236	15x	rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list())
237	15x	rlist[["metadata"]] <- self$get_metadata()
238	15x	cards <- self$get_cards()
239	15x	for (i in seq_along(cards)) {
240		# we want to have list names being a class names to indicate the class for $from_list
241	20x	card <- cards[[i]]
242	20x	card_class <- class(card)[1]
243	20x	u_card <- list()
244	20x	tmp <- tempfile(fileext = ".rds")
245	20x	suppressWarnings(saveRDS(card, file = tmp))
246	20x	tmp_base <- basename(tmp)
247	20x	file.copy(tmp, file.path(output_dir, tmp_base))
248	20x	u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base)
249	20x	rlist$cards <- c(rlist$cards, u_card)
250		}
251	15x	rlist
252		},
253		#' @description Extracts and saves all figure elements from the `teal_card` objects in the
254		#' `Reporter` to a specified directory.
255		#' @param output_dir (`character(1)`) a path to the directory where figures will be saved.
256		#' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures.
257		write_figures = function(output_dir, sub_directory = "figures") {
258	5x	figures_dir <- file.path(output_dir, sub_directory)
259	5x	dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
260	5x	cards <- self$get_cards()
261	5x	for (card_id in names(cards)) {
262	6x	card <- cards[[card_id]]
263	6x	cached_html <- self$get_cached_html(card_id)
264	6x	for (element_ix in seq_along(card)) {
265	19x	card_element <- card[[element_ix]]
266		if (
267	19x	inherits(card_element, "chunk_output") &&
268	19x	checkmate::test_multi_class(
269	19x	card_element[[1]],
270	19x	classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap")
271		)
272		) {
273	!	base64_image <- cached_html[[names(card)[[element_ix]]]]
274		if ( # Ensure we only save valid base64 images
275	!	!is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") &&
276	!	!is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src)
277		) {
278	!	b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src)
279	!	writeBin(
280	!	jsonlite::base64_dec(b64),
281	!	file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix))
282		)
283		}
284		}
285		}
286		}
287		},
288		#' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
289		#' @param rlist (`named list`) representing a `Reporter` instance.
290		#' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
291		#' @return `self`, invisibly.
292		#' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
293		#' @examples
294		#' reporter <- Reporter$new()
295		#' tmp_dir <- file.path(tempdir(), "testdir")
296		#' unlink(tmp_dir, recursive = TRUE)
297		#' dir.create(tmp_dir)
298		#' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
299		from_list = function(rlist, output_dir) {
300	8x	id <- self$get_id()
301	8x	checkmate::assert_list(rlist)
302	8x	checkmate::assert_directory_exists(output_dir)
303	8x	stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter")
304	8x	stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id)
305	7x	if (rlist$version %in% c("1")) {
306	7x	new_cards <- list()
307	7x	cards_names <- names(rlist$cards)
308	7x	cards_names <- gsub("[.][0-9]*$", "", cards_names)
309	7x	for (iter_c in seq_along(rlist$cards)) {
310	12x	card_class <- cards_names[iter_c]
311	12x	card <- rlist$cards[[iter_c]]
312	12x	if (card_class == "teal_card") {
313	12x	new_card <- readRDS(file.path(output_dir, card$path))
314	12x	class(new_card) <- "teal_card"
315	12x	new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards
316	12x	names(new_card) <- card$name
317		} else {
318	!	new_card <- eval(str2lang(card_class))$new()
319	!	new_card$from_list(card, output_dir)
320		}
321	12x	new_cards <- c(new_cards, new_card)
322		}
323		} else {
324	!	stop(
325	!	sprintf(
326	!	"The provided %s reporter version is not supported.",
327	!	rlist$version
328		)
329		)
330		}
331	7x	self$reset()
332	7x	self$set_id(rlist$id)
333	7x	self$append_cards(new_cards)
334	7x	self$append_metadata(rlist$metadata)
335	7x	invisible(self)
336		},
337		#' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory.
338		#' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics.
339		#' @return `output_dir` argument.
340		#' @examples
341		#' reporter <- Reporter$new()
342		#' tmp_dir <- file.path(tempdir(), "jsondir")
343		#' dir.create(tmp_dir)
344		#' reporter$to_jsondir(tmp_dir)
345		to_jsondir = function(output_dir) {
346	13x	checkmate::assert_directory_exists(output_dir)
347	11x	json <- self$to_list(output_dir)
348	11x	cat(
349	11x	jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
350	11x	file = file.path(output_dir, "Report.json")
351		)
352	11x	output_dir
353		},
354		#' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory.
355		#' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics.
356		#' @return `self`, invisibly.
357		#' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
358		#' @examples
359		#' reporter <- Reporter$new()
360		#' tmp_dir <- file.path(tempdir(), "jsondir")
361		#' dir.create(tmp_dir)
362		#' unlink(list.files(tmp_dir, recursive = TRUE))
363		#' reporter$to_jsondir(tmp_dir)
364		#' reporter$from_jsondir(tmp_dir)
365		from_jsondir = function(output_dir) {
366	5x	checkmate::assert_directory_exists(output_dir)
367	5x	dir_files <- list.files(output_dir)
368	5x	stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0)
369	5x	stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files))
370	5x	json <- jsonlite::read_json(file.path(output_dir, "Report.json"))
371	5x	self$reset()
372	5x	self$from_list(json, output_dir)
373	4x	invisible(self)
374		},
375		#' @description Set the `Reporter` id
376		#' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list.
377		#' The id is added to the downloaded file name.
378		#' @param id (`character(1)`) a Report id.
379		#' @return `self`, invisibly.
380		set_id = function(id) {
381	14x	private$id <- id
382	14x	invisible(self)
383		},
384		#' @description Get or set the reactive trigger to open the previewer modal.
385		#' @param val value to the passed to the reactive trigger.
386		#' @return `reactiveVal` value
387		open_previewer = function(val) {
388	9x	if (missing(val)) {
389	7x	private$open_previewer_r()
390		} else {
391	2x	private$open_previewer_r(val)
392		}
393		},
394		#' @description Get cached HTML for a specific `teal_card` by its id.
395		#' @param card_id (`character(1)`) the unique id of the card.
396		get_cached_html = function(card_id) {
397	9x	if (shiny::isRunning()) {
398	!	private$cached_html[[card_id]]
399		} else {
400	9x	shiny::isolate(private$cached_html[[card_id]])
401		}
402		},
403		#' @description Get the `Reporter` id
404		#' @return `character(1)` the `Reporter` id.
405	43x	get_id = function() private$id,
406		#' @description Set template function for `teal_card`
407		#' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards`
408		#' @param template (`function`) a template function.
409		#' @return `self`, invisibly.
410		#' @examples
411		#'
412		#' reporter <- teal.reporter::Reporter$new()
413		#' template_fun <- function(document) {
414		#' disclaimer <- teal.reporter::teal_card("Here comes disclaimer text")
415		#' c(disclaimer, document)
416		#' }
417		#' reporter$set_template(template_fun)
418		#' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text")
419		#' metadata(doc1, "title") <- "Welcome card"
420		#' reporter$append_cards(doc1)
421		#' reporter$get_cards()
422		set_template = function(template) {
423	2x	private$template <- template
424	2x	invisible(self)
425		},
426		#' @description Get the `Reporter` template
427		#' @return a template `function`.
428	95x	get_template = function() private$template
429		),
430		private = list(
431		id = "",
432		cards = NULL, # reactiveValues
433		cached_html = NULL, # reactiveValues
434		open_previewer_r = NULL, # reactiveVal to trigger reactive contexts
435		override_order = character(0L), # to sort cards (reactiveValues are not sortable)
436		metadata = list(),
437		template = NULL,
438		# @description The copy constructor.
439		#
440		# @param name the name of the field
441		# @param value the value of the field
442		# @return the new value of the field
443		#
444		deep_clone = function(name, value) {
445	31x	shiny::isolate({
446	31x	if (name == "cards") {
447	1x	new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) {
448	1x	if (R6::is.R6(card)) card$clone(deep = TRUE) else card
449		})
450	1x	do.call(shiny::reactiveValues, new_cards)
451		} else {
452	30x	value
453		}
454		})
455		}
456		),
457		lock_objects = TRUE,
458		lock_class = TRUE
459		)

1		ui_previewer_card_actions <- function(id) {
2	1x	ns <- shiny::NS(id)
3	1x	shiny::tagList(
4	1x	shiny::actionLink(
5	1x	inputId = ns("toggle_code_action"),
6	1x	class = "btn btn-outline-secondary btn-sm float-end p-3 card-code-toggle",
7	1x	style = "background-color: white !important; z-index: 10 !important; position: relative !important;",
8	1x	label = NULL,
9	1x	title = "Toggle code chunks",
10	1x	icon = shiny::icon("code")
11		),
12	1x	shiny::actionLink(
13	1x	inputId = ns("edit_action"),
14	1x	class = "btn btn-primary btn-sm float-end p-3",
15	1x	label = NULL,
16	1x	title = "Edit card",
17	1x	icon = shiny::icon("edit")
18		),
19	1x	shiny::actionLink(
20	1x	inputId = ns("remove_action"),
21	1x	class = "btn btn-danger btn-sm float-end p-3",
22	1x	label = NULL,
23	1x	icon = shiny::icon("trash-alt"),
24		)
25		)
26		}
27
28		srv_previewer_card_actions <- function(id, card_r, card_id, reporter) {
29	6x	shiny::moduleServer(id, function(input, output, session) {
30	6x	new_card_rv <- shiny::reactiveVal()
31
32	6x	shiny::observeEvent(
33	6x	ignoreInit = TRUE,
34	6x	input$edit_action,
35		{
36	1x	template_card <- card_r()
37	1x	new_card_rv(template_card)
38	1x	title <- metadata(template_card, "title")
39	1x	if (is.null(title) \|\| isFALSE(nzchar(title))) {
40	1x	title <- shiny::tags$span(class = "text-muted", "(Empty title)")
41		}
42
43	1x	shiny::showModal(
44	1x	shiny::modalDialog(
45	1x	title = shiny::tags$span(
46	1x	class = "edit_title_container",
47	1x	"Editing Card:",
48	1x	shiny::tags$span(id = session$ns("static_title"), title),
49	1x	shiny::actionButton(
50	1x	session$ns("edit_title"),
51	1x	label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"),
52	1x	class = "fs-6",
53	1x	title = "Edit title"
54		),
55	1x	shinyjs::hidden(
56	1x	shiny::textInput(
57	1x	session$ns("new_title"),
58	1x	label = NULL, value = metadata(template_card, "title")
59		)
60		)
61		),
62	1x	size = "l",
63	1x	easyClose = TRUE,
64	1x	shiny::tagList(
65	1x	ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)),
66	1x	shiny::uiOutput(session$ns("add_text_element_button_ui"))
67		),
68	1x	footer = shiny::tagList(
69	1x	shiny::actionButton(session$ns("edit_save"), label = "Save"),
70	1x	shiny::modalButton("Close")
71		)
72		)
73		)
74		}
75		)
76
77	6x	block_input_names_rvs <- srv_card_editor("editor", new_card_rv)
78
79	6x	shiny::observeEvent(input$edit_title, {
80	!	shinyjs::hide("edit_title")
81	!	shinyjs::hide("static_title")
82	!	shinyjs::show("new_title")
83	!	shinyjs::js$jumpToFocus(session$ns("new_title"))
84		})
85
86		# Handle
87	6x	shiny::observeEvent(input$edit_save, {
88	1x	new_card <- shiny::req(new_card_rv())
89	1x	input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs))
90	1x	for (name in names(input_r)) {
91	2x	new_card[[name]] <- shiny::isolate(input_r[[name]]())
92		}
93	1x	if (isFALSE(is.null(input$new_title))) {
94	!	metadata(new_card, "title") <- input$new_title
95		}
96	1x	if (isFALSE(identical(new_card, card_r()))) {
97	1x	tryCatch(
98		{
99	1x	reporter$replace_card(card = new_card, card_id = card_id)
100	1x	new_card_rv(NULL)
101	1x	reporter$open_previewer(Sys.time())
102	1x	shiny::showNotification("Card was successfully updated.", type = "message")
103		},
104	1x	error = function(err) {
105	!	shiny::showNotification(
106	!	sprintf(
107	!	"A card with the name '%s' already exists. Please use a different name.",
108	!	metadata(new_card, "title")
109		),
110	!	type = "error",
111	!	duration = 5
112		)
113	!	shinyjs::enable("edit_save")
114		}
115		)
116		} else {
117	!	new_card_rv(NULL)
118	!	reporter$open_previewer(Sys.time())
119		}
120		})
121
122	6x	shiny::observeEvent(input$toggle_code_action, {
123	!	shinyjs::runjs(sprintf("toggleRCodeAccordions('%s');", card_id))
124		})
125
126		# Handle remove button
127	6x	shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id))
128		})
129		}

1		#' @export
2		`[.teal_report` <- function(x, names) {
3	1x	x <- NextMethod("`[`", x) # unverified doesn't need warning for code inconsistency
4	1x	x@teal_card <- x@teal_card # todo: https://github.com/insightsengineering/teal.reporter/issues/394
5	1x	x
6		}

1		#' Simple reporter module
2		#'
3		#' @description
4		#'
5		#' Module provides compact UI and server functions for managing a report in a `shiny` app.
6		#' This module combines functionalities for [adding cards to a report][add_card_button],
7		#' [downloading the report][download_report_button], and [resetting report content][reset_report_button].
8		#'
9		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
10		#'
11		#' @details `r global_knitr_details()`
12		#'
13		#' @name simple_reporter
14		#'
15		#' @param id (`character(1)`) `shiny` module instance id.
16		#' @param reporter (`Reporter`) instance.
17		#' @param card_fun (`reactive` or `function`) which returns a [`teal_card`] or [`ReportCard`] instance.
18		#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
19		#' @inheritParams reporter_download_inputs
20		#'
21		#' @return `NULL`.
22		#'
23		#' @examples
24		#' if (interactive()) {
25		#' library(shiny)
26		#'
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	!	ns <- shiny::NS(id)
40	!	shiny::tagList(
41	!	.custom_css_dependency(),
42	!	shiny::tags$div(
43	!	shiny::tags$label(class = "text-primary", shiny::tags$strong("Reporter")),
44	!	shiny::tags$div(
45	!	class = "simple_reporter_container",
46	!	add_card_button_ui(ns("add_report_card_simple")),
47	!	download_report_button_ui(ns("download_button_simple")),
48	!	report_load_ui(ns("archive_load_simple")),
49	!	reset_report_button_ui(ns("reset_button_simple"))
50		),
51	!	shiny::tags$br()
52		)
53		)
54		}
55
56		#' @rdname simple_reporter
57		#' @export
58		simple_reporter_srv <- function(
59		id,
60		reporter,
61		card_fun,
62		global_knitr = getOption("teal.reporter.global_knitr"),
63		rmd_output = getOption("teal.reporter.rmd_output"),
64		rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args")
65		) {
66	5x	shiny::moduleServer(
67	5x	id,
68	5x	function(input, output, session) {
69	5x	add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
70	5x	download_report_button_srv(
71	5x	"download_button_simple",
72	5x	reporter = reporter,
73	5x	global_knitr = global_knitr,
74	5x	rmd_output = rmd_output,
75	5x	rmd_yaml_args = rmd_yaml_args
76		)
77	5x	report_load_srv("archive_load_simple", reporter = reporter)
78	5x	reset_report_button_srv("reset_button_simple", reporter = reporter)
79		}
80		)
81		}

1		.onLoad <- function(libname, pkgname) {
2	2x	op <- options()
3
4	2x	teal_reporter_default_options <- list(
5	2x	teal.reporter.global_knitr = list(
6	2x	echo = TRUE,
7	2x	tidy.opts = list(width.cutoff = 60),
8	2x	tidy = requireNamespace("formatR", quietly = TRUE)
9		),
10	2x	teal.reporter.devices.dev.width = 800,
11	2x	teal.reporter.devices.dev.height = 600,
12	2x	teal.reporter.rmd_output = c(
13	2x	"html" = "html_document", "pdf" = "pdf_document",
14	2x	"powerpoint" = "powerpoint_presentation",
15	2x	"word" = "word_document"
16		),
17	2x	teal.reporter.rmd_yaml_args = list(
18	2x	author = "NEST", title = "Report",
19	2x	date = as.character(Sys.Date()), output = "html_document",
20	2x	toc = FALSE
21		),
22	2x	teal.reporter.max_request_size = 10 * 1024^2
23		)
24
25	2x	toset <- !(names(teal_reporter_default_options) %in% names(op))
26	1x	if (any(toset)) options(teal_reporter_default_options[toset])
27
28		# Manual import instead of using backports and adding 1 more dependency
29	2x	if (getRversion() < "4.4") {
30	!	assign("%\|\|%", rlang::`%\|\|%`, envir = getNamespace(pkgname))
31		}
32
33	2x	invisible()
34		}
35
36		.onAttach <- function(libname, pkgname) {
37	3x	if (!requireNamespace("formatR", quietly = TRUE)) {
38	1x	packageStartupMessage(
39	1x	"For better code formatting, consider installing the formatR package."
40		)
41		}
42		}

1		#' Show report previewer button module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' Provides a button that triggers showing the report preview in a modal.
5		#'
6		#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
7		#'
8		#' @name reporter_previewer
9		#'
10		#' @param id (`character(1)`) `shiny` module instance id.
11		#' @param label (`character(1)`) label of the button. By default it is "Preview Report".
12		#' @param reporter (`Reporter`) instance.
13		#'
14		#' @return `NULL`.
15		NULL
16
17		#' @rdname reporter_previewer
18		#' @export
19		preview_report_button_ui <- function(id, label = "Preview Report") {
20	!	checkmate::assert_string(label, null.ok = TRUE)
21	!	ns <- shiny::NS(id)
22	!	shiny::tagList(
23	!	.action_button_busy(
24	!	ns("preview_button"),
25	!	label = shiny::tags$span(
26	!	label,
27	!	shiny::uiOutput(ns("preview_button_counter"))
28		),
29	!	icon = "file-earmark-text",
30	!	outline = TRUE
31		)
32		)
33		}
34
35		#' @rdname reporter_previewer
36		#' @export
37		preview_report_button_srv <- function(id, reporter) {
38	4x	checkmate::assert_class(reporter, "Reporter")
39
40	4x	shiny::moduleServer(id, function(input, output, session) {
41	4x	shiny::setBookmarkExclude(c("preview_button"))
42
43	4x	shiny::observeEvent(reporter$get_cards(), {
44	4x	shinyjs::toggleClass(
45	4x	id = "preview_button", condition = length(reporter$get_cards()) == 0, class = "disabled"
46		)
47		})
48
49	4x	output$preview_button_counter <- shiny::renderUI({
50	4x	shiny::tags$span(
51	4x	class = "badge rounded-pill bg-primary",
52	4x	length(reporter$get_cards())
53		)
54		})
55
56	4x	preview_modal <- function() {
57	2x	shiny::tags$div(
58	2x	class = "teal-reporter reporter-previewer-modal",
59	2x	.custom_css_dependency(),
60	2x	.accordion_toggle_js_dependency(),
61	2x	shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
62	2x	shiny::modalDialog(
63	2x	easyClose = TRUE,
64	2x	size = "xl",
65	2x	title = "Report Preview",
66	2x	reporter_previewer_content_ui(session$ns("preview_content")),
67	2x	footer = shiny::tagList(
68	2x	shiny::tags$button(
69	2x	type = "button",
70	2x	class = "btn btn-outline-secondary",
71	2x	"data-bs-dismiss" = "modal",
72	2x	"Dismiss"
73		)
74		)
75		)
76		)
77		}
78
79	4x	reporter_previewer_content_srv(id = "preview_content", reporter = reporter)
80
81	4x	srv_list <- shiny::reactiveValues()
82	4x	shiny::observeEvent(
83	4x	list(input$preview_button, reporter$open_previewer()),
84	4x	ignoreInit = TRUE,
85		{
86	2x	shiny::req(input$preview_button != 0 \|\| !is.null(reporter$open_previewer())) # prevent unnecessary triggering.
87	2x	shiny::showModal(preview_modal())
88
89	2x	panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards"))
90	2x	lapply(
91	2x	names(reporter$get_cards()),
92	2x	function(card_id) {
93		# Only show loading placeholder for cards that are being initialized for the first time
94	!	first_run <- is.null(srv_list[[card_id]])
95
96	!	bslib::accordion_panel_insert(
97	!	id = panel_ns(NULL),
98	!	previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id, show_loading = first_run)
99		)
100
101	!	if (first_run) { # Only initialize srv once per card_id
102	!	previewer_card_srv(
103	!	id = panel_ns(card_id),
104	!	card_r = shiny::reactive(reporter$get_cards()[[card_id]]),
105	!	card_id = card_id,
106	!	reporter = reporter
107		)
108	!	srv_list[[card_id]] <- card_id
109		}
110		}
111		)
112		}
113		)
114		})
115		}

1		#' @importFrom tools toHTML
2		NULL
3
4		#' Convert report objects to HTML
5		#'
6		#' @description
7		#' `r lifecycle::badge("experimental")`
8		#'
9		#' The `toHTML` S3 generic method converts various report objects into HTML representations.
10		#' This is the primary method for rendering report content for display in web browsers,
11		#' IDE Viewer, or for inclusion in Shiny applications.
12		#'
13		#' @param x The object to convert to HTML. Supported types include:
14		#' - `teal_card`: A list-like structure containing report elements
15		#' - `teal_report`: A report object containing a `teal_card`
16		#' - `ReportCard`: Deprecated R6 class for report cards
17		#' - `code_chunk`: Code blocks created with [code_chunk()]
18		#' - `chunk_output`: Output from evaluated code chunks
19		#' - Plot objects: `ggplot`, `recordedplot`, `trellis`, `grob`
20		#' - Table objects: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`,
21		#' `listing_df`, `gtsummary`, `flextable`, `datatables`
22		#' - Text: `character` strings (rendered as markdown)
23		#' - Other objects: Conditions, model summaries, etc.
24		#' @param ... Additional arguments passed to methods.
25		#'
26		#' @details
27		#' ## Relationship with `teal_card`
28		#'
29		#' The `teal_card` class is a central component in the `teal.reporter` ecosystem. It is an S3 list
30		#' where each element represents a piece of report content (text, plots, tables, code chunks, etc.).
31		#' The `toHTML` method for `teal_card` objects:
32		#'
33		#' 1. Iterates through each element in the `teal_card` list
34		#' 2. Calls `toHTML()` recursively on each element based on its class
35		#' 3. Wraps all converted elements in a [bslib::card()] container
36		#'
37		#' This hierarchical conversion allows complex report structures to be rendered as styled HTML
38		#' with proper formatting for each content type.
39		#'
40		#' ## Content Type Conversions
41		#'
42		#' Text and Markdown: Character strings are converted to HTML using `CommonMark` markdown syntax.
43		#' Supports headers, lists, code blocks, emphasis, and other markdown features.
44		#'
45		#' Code Chunks: Created with [code_chunk()], these are rendered as collapsible Bootstrap
46		#' accordions with syntax highlighting. The accordion includes the programming language indicator
47		#' and an icon.
48		#'
49		#' Plots: Plot objects (`ggplot`, `recordedplot`, `trellis`, `grob`) are converted to PNG
50		#' images with base64-encoded data URIs, making them self-contained in the HTML output.
51		#'
52		#' Tables: Table objects are converted to styled HTML tables, typically via `flextable`
53		#' for consistent formatting.
54		#'
55		#' ## Viewer Integration
56		#'
57		#' All HTML output is wrapped with [htmltools::browsable()], which enables:
58		#' - Automatic render in IDE Viewer when displayed interactively
59		#' - Proper HTML dependency injection (Bootstrap CSS/JavaScript, Font Awesome icons, etc.)
60		#' - Standalone HTML files with all required resources
61		#'
62		#' You can override the `browsable` behavior with:
63		#' ```r
64		#' print(toHTML(x), browse = FALSE) # Print markup to console instead
65		#' ```
66		#'
67		#' @return An HTML representation of the input object. The exact return type depends on the
68		#' input class:
69		#' - For `teal_card`: A `bslib::card()` containing all elements
70		#' - For `code_chunk`: A `bslib::accordion()` with the code
71		#' - For plots: A `shiny::tags$img()` tag
72		#' - For text: HTML markup from markdown conversion
73		#' - For tables: HTML table elements
74		#'
75		#' All returns are wrapped with `htmltools::browsable()` to enable viewer display.
76		#'
77		#' @seealso
78		#' - [teal_report()] for creating report objects
79		#' - [teal_card()] for creating report cards
80		#' - [code_chunk()] for creating code blocks
81		#' - [render()] for rendering complete reports to files
82		#'
83		#' @examples
84		#' # Initialize empty report
85		#' report <- teal_report()
86		#'
87		#' # Add arbitrary markdown elements to the report's teal_card
88		#' teal_card(report) <- c(
89		#' teal_card(report),
90		#' "## Document section",
91		#' "Lorem ipsum dolor sit amet"
92		#' )
93		#'
94		#' # Use within() to execute code and add code-chunk
95		#' report <- within(report, a <- 2)
96		#'
97		#' # within() automatically captures code and outputs
98		#' report <- within(report, plot(a))
99		#'
100		#' html <- tools::toHTML(report)
101		#' # display HTML markup in viewer
102		#' html
103		#'
104		#' # Print HTML markup to console instead of viewer
105		#' print(html, browse = FALSE)
106		#'
107		#' @export
108		#' @aliases teal_card-preview
109		#' @method toHTML default
110		toHTML.default <- function(x, ...) {
111	487x	htmltools::browsable(.toHTML(x, ...))
112		}
113
114		#' @keywords internal
115		.toHTML <- function(x, ...) { # nolint: object_name.
116	487x	UseMethod(".toHTML", x)
117		}
118
119		#' @method .toHTML default
120		#' @keywords internal
121		.toHTML.default <- function(x, ...) {
122	261x	htmltools::HTML(commonmark::markdown_html(x, extensions = TRUE))
123		}
124
125		#' @method .toHTML ContentBlock
126		#' @keywords internal
127		.toHTML.ContentBlock <- function(x, ...) {
128	!	tools::toHTML(x$get_content(), ...)
129		}
130
131		#' @method .toHTML ContentBlock
132		#' @keywords internal
133		.toHTML.RcodeBlock <- function(x, ...) {
134	!	tools::toHTML(code_chunk(x$get_content(), lang = "R"), ...)
135		}
136
137		#' @method .toHTML ReportCard
138		#' @keywords internal
139		.toHTML.ReportCard <- function(x, ...) {
140	1x	shiny::tagList(lapply(x$get_content(), tools::toHTML, ...))
141		}
142
143		#' @method .toHTML teal_card
144		#' @keywords internal
145		.toHTML.teal_card <- function(x, ...) {
146	2x	bslib::card(lapply(x, tools::toHTML, ...))
147		}
148
149		#' @method .toHTML teal_report
150		#' @keywords internal
151		.toHTML.teal_report <- function(x, ...) {
152	1x	tools::toHTML(teal_card(x), ...)
153		}
154
155		#' @method .toHTML rtables
156		#' @keywords internal
157		.toHTML.rtables <- function(x, ...) {
158	78x	shiny::tags$pre(tools::toHTML(to_flextable(x)))
159		}
160
161		#' @method .toHTML flextable
162		#' @keywords internal
163		.toHTML.flextable <- function(x, ...) {
164	78x	flextable::htmltools_value(x)
165		}
166
167		#' @method .toHTML condition
168		#' @keywords internal
169		.toHTML.condition <- function(x, ...) {
170	!	conditionMessage(x)
171		}
172
173		.plot2html <- function(x, ...) {
174	56x	on.exit(unlink(tmpfile))
175	56x	tmpfile <- tempfile(fileext = ".png")
176	56x	dims <- .determine_default_dimensions(x)
177	56x	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
178	56x	print(x)
179	56x	grDevices::dev.off()
180	56x	shiny::tags$img(src = knitr::image_uri(tmpfile), style = "width: 100%; height: auto;")
181		}
182
183		#' @method .toHTML recordedplot
184		#' @keywords internal
185		.toHTML.recordedplot <- .plot2html
186
187		#' @method .toHTML trellis
188		#' @keywords internal
189		.toHTML.trellis <- .plot2html
190
191		#' @method .toHTML gg
192		#' @keywords internal
193		.toHTML.gg <- function(x, ...) {
194	2x	on.exit(unlink(tmpfile))
195	2x	dims <- .determine_default_dimensions(x, convert_to_inches = TRUE, dpi = 100)
196	2x	tmpfile <- tempfile(fileext = ".png")
197	2x	ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100)
198	2x	shiny::tags$img(src = knitr::image_uri(tmpfile))
199		}
200
201		#' @method .toHTML grob
202		#' @keywords internal
203		.toHTML.grob <- function(x, ...) {
204	1x	on.exit(unlink(tmpfile))
205	1x	dims <- .determine_default_dimensions(x)
206	1x	tmpfile <- tempfile(fileext = ".png")
207	1x	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
208	1x	grid::grid.newpage()
209	1x	grid::grid.draw(x)
210	1x	grDevices::dev.off()
211	1x	shiny::tags$img(src = knitr::image_uri(tmpfile))
212		}
213
214		#' @method .toHTML code_chunk
215		#' @keywords internal
216		.toHTML.code_chunk <- function(x, ...) {
217	5x	bslib::accordion(
218	5x	class = "code_chunk",
219	5x	open = FALSE,
220	5x	bslib::accordion_panel(
221	5x	title = shiny::tags$span(shiny::icon("code"), attr(x, "lang", exact = TRUE)),
222	5x	value = "rcode",
223	5x	shiny::tags$pre(
224	5x	shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang", exact = TRUE))),
225	5x	.noWS = "inside"
226		)
227		)
228		)
229		}
230
231		#' @method .toHTML chunk_output
232		#' @keywords internal
233		.toHTML.chunk_output <- function(x, ...) {
234	2x	new_x <- x[[1]]
235	2x	mostattributes(new_x) <- c(attributes(unclass(x)), attributes(new_x))
236	2x	tools::toHTML(new_x, ...)
237		}
238
239		#' @method .toHTML summary.lm
240		#' @keywords internal
241		.toHTML.summary.lm <- function(x, ...) {
242	!	shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n"))
243		}
244
245		#' @method .toHTML TableTree
246		#' @keywords internal
247		.toHTML.TableTree <- .toHTML.rtables
248
249		#' @method .toHTML ElementaryTable
250		#' @keywords internal
251		.toHTML.ElementaryTable <- .toHTML.rtables
252
253		#' @method .toHTML rlisting
254		#' @keywords internal
255		.toHTML.rlisting <- .toHTML.rtables
256
257		#' @method .toHTML data.frame
258		#' @keywords internal
259		.toHTML.data.frame <- .toHTML.rtables
260
261		#' @method .toHTML datatables
262		#' @keywords internal
263		.toHTML.datatables <- function(x, ...) {
264	!	x
265		}
266
267		#' @method .toHTML gtsummary
268		#' @keywords internal
269		.toHTML.gtsummary <- function(x, ...) {
270	!	tools::toHTML(gtsummary::as_flex_table(x))
271		}
272
273		#' @method .toHTML listing_df
274		#' @keywords internal
275		.toHTML.listing_df <- function(x, ...) {
276	!	tools::toHTML(flextable::as_flextable(x))
277		}

1		setOldClass("teal_card")
2
3		#' Reproducible report
4		#'
5		#' Reproducible report container class. Inherits code tracking behavior from [`teal.data::teal_data-class`].
6		#'
7		#' This class provides an isolated environment in which to store and process data with all code being recorded.
8		#' The environment, code, data set names, and data joining keys are stored in their respective slots.
9		#' These slots should never be accessed directly, use the provided get/set functions.
10		#'
11		#' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots.
12		#' If errors are raised, a `qenv.error` object is returned.
13		#'
14		#' @name teal_report-class
15		#' @rdname teal_report-class
16		#'
17		#' @slot .xData (`environment`) environment containing data sets and possibly
18		#' auxiliary variables.
19		#' Access variables with [get()], [`$`] or [`[[`].
20		#' No setter provided. Evaluate code to add variables into `@.xData`.
21		#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `qenv`.
22		#' Access with [teal.code::get_code()].
23		#' No setter provided. Evaluate code to append code to the slot.
24		#' @slot join_keys (`join_keys`) object specifying joining keys for data sets in
25		#' `@.xData`.
26		#' Access or modify with [teal.data::join_keys()].
27		#' @slot verified (`logical(1)`) flag signifying that code in `@code` has been
28		#' proven to yield contents of `@.xData`.
29		#' Used internally. See [`teal.data::verify()`] for more details.
30		#' @slot card (`teal_card`)
31		#' @inheritSection teal.data::`teal_data-class` Code
32		#' @importFrom teal.data teal_data
33		#' @keywords internal
34		setClass(
35		Class = "teal_report",
36		contains = "teal_data",
37		slots = c(teal_card = "teal_card")
38		)
39
40		#' It initializes the `teal_report` class
41		#'
42		#' Accepts .xData as a list and converts it to an environment before initializing
43		#' parent constructor (`teal_data`).
44		#' @noRd
45		setMethod(
46		"initialize",
47		"teal_report",
48		function(.Object, teal_card = NULL, ...) { # nolint: object_name.
49	50x	args <- list(...)
50	!	if (is.null(teal_card)) teal_card <- teal_card()
51	50x	checkmate::assert_class(teal_card, "teal_card")
52	49x	checkmate::assert_list(args, names = "named")
53	49x	methods::callNextMethod(
54	49x	.Object,
55	49x	teal_card = teal_card,
56		...
57		)
58		}
59		)
60
61		#' Comprehensive data integration function for `teal` applications
62		#'
63		#' @description
64		#' `r lifecycle::badge("stable")`
65		#'
66		#' Initializes a reportable data for `teal` application.
67		#'
68		#' @inheritParams teal.data::teal_data
69		#' @param teal_card (`teal_card`) object containing the report content.
70		#' @return A `teal_report` object.
71		#'
72		#' @seealso [`teal.data::teal_data`]
73		#'
74		#' @export
75		#'
76		#' @examples
77		#' # Initialize teal_report with existing h2 header
78		#' report <- teal_report(teal_card = teal_card("## Analysis Report"))
79		#'
80		#' # Use within() to execute code and add code-chunk
81		#' report <- within(report, {
82		#' data <- iris
83		#' summary_stats <- summary(data)
84		#' })
85		#'
86		#' # Access objects created within the report
87		#' report$data
88		#' report$summary_stats
89		#'
90		#' # within() automatically captures code and outputs
91		#' report <- within(report, {
92		#' head(iris)
93		#' })
94		#'
95		#' # Add arbitrary markdown content to the card
96		#' teal_card(report) <- c(
97		#' teal_card(report),
98		#' teal_card("### Conclusion", "The analysis is complete.")
99		#' )
100		#'
101		#' # View the generated card with code chunks
102		#' teal_card(report)
103		#'
104		#' # View report in HTML format
105		#' tools::toHTML(report)
106		#'
107		#' if (interactive()) {
108		#' # Render the report to various formats
109		#' render(report, output_format = rmarkdown::html_document())
110		#' render(report, output_format = rmarkdown::pdf_document())
111		#' }
112		#'
113		teal_report <- function(...,
114		teal_card = NULL,
115		code = character(0),
116		join_keys = teal.data::join_keys()) {
117	42x	if (is.null(teal_card)) teal_card <- teal_card()
118	50x	methods::new(
119	50x	"teal_report",
120	50x	.xData = list2env(list(...)),
121	50x	teal_card = teal_card,
122	50x	join_keys = join_keys,
123	50x	code = code
124		)
125		}
126
127		#' Internal function to convert `qenv` or `teal_data` to `teal_report`
128		#' @noRd
129		coerce.teal_report <- function(from, to) { # nolint: object_name.
130	7x	if (inherits(from, "teal_report")) {
131	!	return(from)
132		}
133	7x	new_x <- teal_report()
134	7x	for (slot_name in methods::slotNames(from)) {
135	24x	methods::slot(new_x, slot_name) <- methods::slot(from, slot_name)
136		}
137	7x	teal_card(new_x) <- .code_to_card(from@code)
138	7x	new_x
139		}
140
141		methods::setAs("qenv", "teal_report", coerce.teal_report)
142		methods::setAs("teal_data", "teal_report", coerce.teal_report)
143
144		#' @rdname teal_report
145		#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`.
146		#' @export
147		as.teal_report <- function(x) { # nolint: object_name.
148	8x	checkmate::assert_class(x, "qenv")
149	8x	methods::as(x, "teal_report")
150		}

1		#' @export
2		#' @rdname srv_editor_block
3		ui_editor_block <- function(id, value, ...) {
4	1x	UseMethod("ui_editor_block", value)
5		}
6
7		#' UI and Server functions for editing report document blocks
8		#'
9		#' These functions provide a user interface and server logic for editing and extending
10		#' the editor functionality to support new data types.
11		#'
12		#' @details
13		#' The methods for this S3 generic can be extended by the app developer to new classes
14		#' or even overwritten.
15		#' For this a function with the name `srv_editor_block.<class>` and/or `ui_editor_block.<class>`
16		#' should be defined in the Global Environment, where `<class>` is the class of
17		#' the object to be used in the method.
18		#'
19		#' For example, to override the default behavior for `character` class, you can use:
20		#'
21		#' ```r
22		#' ui_editor_block.character <- function(id, value) {
23		#' # custom implementation
24		#' shiny::tagList(
25		#' shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable CUSTOM markdown block"),
26		#' shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%")
27		#' )
28		#' }
29		#' srv_editor_block.character <- function(id, value) {
30		#' # custom implementation
31		#' # ...
32		#' }
33		#' ```
34		#'
35		#' Alternatively, you can register the S3 method using
36		#' `registerS3method("ui_editor_block", "<class>", fun)` and
37		#' `registerS3method("srv_editor_block", "<class>", fun)`.
38		#'
39		#' ### Optional arguments of `ui_editor_block`
40		#'
41		#' - `cached_html`: (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI that is
42		#' rendered at the time the card is being added. Default is `NULL`.
43		#'
44		#' `teal` will call on `ui_editor_block` with the contents of each element
45		#' of the card (`value` argument) and an optional parameter `cached_html`.
46		#' This parameter is not part of the S3 generic as it is optional when overriding the method.
47		#'
48		#' The usage of this argument improve the UI performance by avoiding re-rendering on the fly.
49		#' When overriding this method, the usage of this argument is optional, hence it is not part of the S3 generic.
50		#'
51		#' @param id (`character(1)`) A unique identifier for the module.
52		#' @param value The content of the block to be edited. It can be a character string or other types.
53		#' @param ... Additional arguments passed to dispatch functions.
54		#' @export
55		srv_editor_block <- function(id, value, ...) {
56	8x	UseMethod("srv_editor_block", value)
57		}
58
59		#' @export
60		ui_editor_block.default <- function(id, value, ...) {
61	1x	.ui_editor_block(id, value, ...)
62		}
63
64		#' @export
65		srv_editor_block.default <- function(id, value, ...) {
66	8x	.srv_editor_block(id, value, ...)
67		}
68
69		#' @keywords internal
70		.ui_editor_block <- function(id, value, cached_html, ...) {
71	1x	UseMethod(".ui_editor_block", value)
72		}
73
74		#' @keywords internal
75		.srv_editor_block <- function(id, value, ...) {
76	8x	UseMethod(".srv_editor_block", value)
77		}
78
79		#' @method .ui_editor_block default
80		.ui_editor_block.default <- function(id, value, cached_html, ...) {
81	!	shiny::tags$div(
82	!	shiny::tags$h6(
83	!	shiny::tags$span(
84	!	class = "fa-stack small text-muted",
85		# style = "width: 2em;", # necessary to avoid extra space after icon
86	!	shiny::icon("pencil", class = "fa-stack-1x"),
87	!	shiny::icon("ban", class = "fa-stack-2x fa-inverse text-black-50")
88		),
89	!	"Non-editable block"
90		),
91	!	if (is.null(cached_html)) {
92	!	tools::toHTML(value)
93		} else {
94	!	cached_html
95		}
96		)
97		}
98
99		#' @method .srv_editor_block default
100		.srv_editor_block.default <- function(id, value, ...) {
101	1x	shiny::moduleServer(id, function(input, output, session) result <- NULL) # No input being changed, skipping update
102		}
103
104		#' @method .ui_editor_block character
105		.ui_editor_block.character <- function(id, value, ...) {
106	1x	ns <- shiny::NS(id)
107	1x	shiny::tagList(
108	1x	shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"),
109	1x	shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%")
110		)
111		}
112
113		#' @method .srv_editor_block character
114		.srv_editor_block.character <- function(id, value, ...) {
115	7x	shiny::moduleServer(id, function(input, output, session) result <- shiny::reactive(input$content))
116		}

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

1		previewer_card_ui <- function(id, card_id, show_loading = TRUE) {
2	!	ns <- shiny::NS(id)
3	!	accordion_item <- bslib::accordion_panel(
4	!	value = card_id,
5	!	title = shiny::tags$label(shiny::uiOutput(ns("title"))),
6	!	icon = bslib::tooltip(
7	!	bsicons::bs_icon("arrows-move"),
8	!	"Move card"
9		),
10	!	if (show_loading) {
11	!	shiny::tags$h6(id = ns(paste0("loading_placeholder_", card_id)), class = "text-muted", "Loading the report...")
12		},
13	!	shiny::uiOutput(ns("card_content"))
14		)
15	!	accordion_item <- shiny::tagAppendAttributes(accordion_item, "data-rank-id" = card_id)
16
17	!	accordion_item <- shiny::tagAppendAttributes(
18	!	tag = accordion_item,
19	!	.cssSelector = ".accordion-header",
20	!	class = "d-flex",
21		)
22
23	!	accordion_item <- htmltools::tagAppendChildren(
24	!	tag = accordion_item,
25	!	.cssSelector = ".accordion-header",
26	!	ui_previewer_card_actions(ns("actions"))
27		)
28		}
29
30		previewer_card_srv <- function(id, card_r, card_id, reporter) {
31	3x	shiny::moduleServer(id, function(input, output, session) {
32	3x	output$title <- shiny::renderUI({
33	3x	title <- metadata(shiny::req(card_r()), "title")
34	3x	if (is.null(title) \|\| isFALSE(nzchar(title))) {
35	1x	title <- shiny::tags$span("(Empty title)", class = "text-muted")
36		}
37	3x	title
38		})
39	3x	output$card_content <- shiny::renderUI({
40	3x	result <- reporter$get_cached_html(card_id)
41	3x	shiny::removeUI(sprintf("#%s", session$ns(paste0("loading_placeholder_", card_id))))
42	3x	result
43		})
44
45	3x	srv_previewer_card_actions("actions", card_r, card_id, reporter)
46		})
47		}

1		ui_card_editor <- function(id, value, cached_html) {
2	!	ns <- shiny::NS(id)
3	!	shiny::tagList(
4	!	shiny::tags$div(
5	!	id = ns("blocks"),
6	!	lapply(names(value), function(block_name) {
7	!	ui_editor_block(
8	!	shiny::NS(ns("blocks"), block_name),
9	!	value = value[[block_name]],
10	!	cached_html = cached_html[[block_name]]
11		)
12		})
13		),
14	!	shiny::actionButton(ns("add_block"), label = "Add text block", icon = shiny::icon("plus"))
15		)
16		}
17
18		srv_card_editor <- function(id, card_r) {
19	7x	shiny::moduleServer(id, function(input, output, session) {
20	7x	blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot
21	7x	blocks_queue_rv <- shiny::reactiveVal()
22
23	7x	shiny::observeEvent(card_r(), { # Reset on card change
24	!	for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL
25	3x	blocks_queue_rv(NULL) # Force retriggering
26	3x	blocks_queue_rv(names(card_r()))
27		})
28
29	7x	shiny::observeEvent(blocks_queue_rv(), {
30	4x	lapply(blocks_queue_rv(), function(block_name) {
31	6x	new_block_id <- shiny::NS("blocks", block_name)
32	6x	block_content <- card_r()[[block_name]] %\|\|% "" # Initialize as empty string
33	6x	blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content)
34
35	6x	if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered
36	1x	new_block_ui <- ui_editor_block(
37	1x	session$ns(new_block_id),
38	1x	value = block_content,
39	1x	cached_html = NULL
40		)
41	1x	shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui)
42		}
43		})
44		})
45
46	7x	shiny::observeEvent(input$add_block, {
47	1x	new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1)
48	1x	blocks_queue_rv(new_name)
49		})
50
51	7x	blocks_inputs_rvs
52		})
53		}

1		#' @name eval_code-teal_report
2		#' @rdname eval_code-teal_report
3		#' @aliases eval_code,teal_report-method
4		#'
5		#' @inherit teal.code::eval_code
6		#' @param object (`teal_report`)
7		#' @param code_block_opts (`list`) Additional options for the R code chunk in R Markdown.
8		#' @return `teal_reporter` environment with the code evaluated and the outputs added
9		#' to the card or `qenv.error` if evaluation fails.
10		#' @importFrom teal.code eval_code
11		#'
12		#' @examples
13		#' td <- teal.data::teal_data()
14		#' td <- teal.code::eval_code(td, "iris <- iris")
15		#' tr <- as.teal_report(td)
16		#' tr <- teal.code::eval_code(tr, "a <- 1")
17		#' tr <- teal.code::eval_code(tr, "b <- 2L # with comment")
18		#' tr <- teal.code::eval_code(tr, quote(library(checkmate)))
19		#' tr <- teal.code::eval_code(tr, expression(assert_number(a)))
20		#' teal_card(tr)
21		setMethod(
22		"eval_code",
23		signature = c(object = "teal_report"),
24		function(object, code, code_block_opts = list(), ...) {
25	22x	new_object <- methods::callNextMethod(object = object, code = code, ...)
26	22x	if (inherits(new_object, "error")) {
27	!	return(new_object)
28		}
29	22x	new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts)
30
31	22x	teal_card(new_object) <- c(teal_card(new_object), new_blocks)
32	22x	new_object
33		}
34		)