teal.reporter coverage - 81.05%

Files
Source

#' @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)")
      }
      unclass(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 <- as.teal_card(card)
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    name = character(0L),
    id = character(0L)
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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

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

#' @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) {
  if (inherits(x, "qenv.error")) { # qenv.error does nothing
    return(x)
  }
  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_along(x), function(ix) rlang::hash(list(ix, Sys.time(), x[[ix]])), character(1L)),
        1,
        8
      )
    }
    return(x)
  }
  if (identical(class(x), "list")) {
    result <- do.call(teal_card, unname(x))
    attr(result, "metadata") <- attr(x, "metadata", exact = TRUE) %||% list()
    return(result)
  }
  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(
              warningCondition(
                "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.",
                class = "teal_card_append"
              )
            )
            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), add = TRUE)
  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)
}

#' @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, ...) {
  tmpfile <- tempfile(fileext = ".png")
  on.exit(unlink(tmpfile), add = TRUE)
  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 = sprintf("width: 100%%; height: auto; max-width: %fpx", dims$width)
  )
}

#' @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, ...) {
  dims <- .determine_default_dimensions(x, convert_to_inches = TRUE, dpi = 100)
  tmpfile <- tempfile(fileext = ".png")
  on.exit(unlink(tmpfile), add = TRUE)
  ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100)
  shiny::tags$img(src = knitr::image_uri(tmpfile), style = sprintf("max-width: %fpx", dims$width * 100))
}

#' @method .toHTML grob
#' @keywords internal
.toHTML.grob <- function(x, ...) {
  dims <- .determine_default_dimensions(x)
  tmpfile <- tempfile(fileext = ".png")
  on.exit(unlink(tmpfile), add = TRUE)
  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), style = sprintf("max-width: %fpx", dims$width))
}

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

# 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),
  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)
    },
    get_content = function(output_format = NULL) {
      params <- self$get_params()
      params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
      if (identical(output_format, "powerpoint_presentation")) {
        block_content_list <- split_text_block(super$get_content(), 30)
        paste(
          sprintf(
            "```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
            shQuote(block_content_list, type = "cmd")
          ),
          collapse = "\n\n"
        )
      } else {
        sprintf(
          "```{r, %s}\n%s\n```\n",
          paste(names(params), params, sep = "=", collapse = ", "),
          super$get_content()
        )
      }
    },
    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
)

#' 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 `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
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Mark strings for quotation in `yaml` serialization
#'
#' This function is designed for use with the `yaml` package to explicitly,
#' It adds an attribute to character strings, indicating that they should be serialized with double quotes.
#'
#' @param x (`character`)
#' @keywords internal
#' @examples
#' library(yaml)
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
#' yaml <- list(
#'   author = yaml_quoted("NEST"),
#'   title = yaml_quoted("Report"),
#'   date = yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' as.yaml(yaml)
yaml_quoted <- function(x) {
  attr(x, "quoted") <- TRUE
  x
}

#' Create `markdown` header from `yaml` string
#'
#' This function wraps a `yaml`-formatted string in Markdown header delimiters.
#'
#' @param x (`character`) `yaml` formatted string.
#' @keywords internal
#' @examples
#' library(yaml)
#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
#' yaml <- list(
#'   author = yaml_quoted("NEST"),
#'   title = yaml_quoted("Report"),
#'   date = yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' md_header <- getFromNamespace("md_header", "teal.reporter")
#' md_header(as.yaml(yaml))
md_header <- function(x) {
  paste0("---\n", x, "---\n")
}

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

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

#' Get document output types from the `rmarkdown` package
#'
#' @description
#'
#' 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
}

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

.plot_to_rmd <- function(block, folder_path = ".", ...) {
  tempfile <- tempfile(pattern = "report_item_", fileext = ".rds")
  path <- file.path(folder_path, basename(tempfile))
  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 or registered as an S3 method, 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, ...) {
#'   # custom implementation
#'   sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block)
#' }
#' ```
#'
#' Alternatively, the S3 method can be registered using `registerS3method("to_rmd", "<class>", fun)`
#'
#' ## Defaults
#'
#' `teal.reporter` provides default `to_rmd` methods for several common classes that
#' returns the content in appropriate R Markdown syntax.
#' These include:
#' - `character`
#' - [code_chunk()] objects
#' - `ggplot2` plots
#' - `data.frame`
#' - `flextable`
#' - `rtables` tables
#' - and others.
#'
#' All of these defaults can be overridden by defining new `to_rmd.<class>` methods.
#' These methods are implemented internally using the helper function `.to_rmd.<class>`.
#'
#' @param block (`any`) content which can be represented in Rmarkdown syntax.
#' @param ... additional arguments passed to implemented methods for different classes.
#' @return `character(1)` containing a content or Rmarkdown document.
#' @examples
#' to_rmd(c("## This is a simple text block.", "", "With a paragraph break."))
#' to_rmd(code_chunk("summary(cars)"))
#' to_rmd(data.frame(x = 1:10, y = 21:30), folder_path = tempdir())
#' @examplesIf requireNamespace("ggplot2", quietly = TRUE)
#'
#' # Example with ggplot2 will create a temporary RDS file in the tempdir()
#' to_rmd(
#'   ggplot2::ggplot(mtcars, ggplot2::aes(x = wt, y = mpg)) +
#'     ggplot2::geom_point(),
#'   folder_path = tempdir() # internal argument of ggplot2 method
#' )
#' @export
to_rmd <- function(block, ...) {
  UseMethod("to_rmd")
}

#' @method to_rmd default
#' @export
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, output_format, ...) {
  to_rmd(code_chunk(block$get_content(output_format), lang = "R"), ...)
}

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::tags$div(
            class = "teal-reporter reporter-editor-modal",
            .custom_css_dependency(),
            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 = "xl",
              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))
  })
}

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

# 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)
    })
  })
}

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

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

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

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

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), add = TRUE)

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

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

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

#' 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) <- suppressWarnings(do.call(c, lapply(l, teal_card)), classes = "teal_card_append")
  }
  result
}

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	89x	if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
16	43x	ft <- rtables.officer::tt_to_flextable(content)
17	46x	} 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	45x	} else if (inherits(content, "data.frame")) {
33	44x	ft <- if (nrow(content) == 0) {
34	!	flextable::flextable(content)
35		} else {
36	44x	rtables.officer::tt_to_flextable(
37	44x	rtables::df_to_tt(content)
38		)
39		}
40		} else {
41	1x	stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
42		}
43
44	88x	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	4x	checkmate::assert_string(x)
63	4x	checkmate::assert_integerish(n, lower = 1L, len = 1L)
64
65	4x	lines <- strsplit(x, "\n")[[1]]
66
67	4x	if (length(lines) <= n) {
68	1x	return(list(x))
69		}
70
71	3x	nblocks <- ceiling(length(lines) / n)
72	3x	ind <- rep(1:nblocks, each = n)[seq_along(lines)]
73	3x	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	102x	language <- attr(x, "lang", exact = TRUE)
97	102x	params <- attr(x, "params", exact = TRUE)
98	102x	if (language %in% names(knitr::knit_engines$get())) {
99	101x	sprintf(
100	101x	"```{%s}\n%s\n```",
101	101x	toString(c(language, paste(names(params), params, sep = "="))),
102	101x	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		# 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		#' 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		#' 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), add = TRUE)
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		#' @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	59x	lifecycle::deprecate_warn(
27	59x	when = "0.6.0",
28	59x	what = "ReportCard$new()",
29	59x	with = "teal_card()",
30	59x	details = "Use teal_report class instead. See vignette('teal-report-class', 'teal.reporter') for more information." # nolint: line_length_linter.
31		)
32	59x	private$content <- teal_card()
33	59x	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	22x	checkmate::assert_numeric(dim, len = 2, any.missing = FALSE, null.ok = TRUE)
66	22x	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	22x	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	53x	styled <- switch(match.arg(style),
85	53x	"default" = text,
86	53x	"verbatim" = sprintf("\n```\n%s\n```\n", text),
87	53x	"header2" = paste0("## ", text),
88	53x	"header3" = paste0("### ", text),
89	53x	text
90		)
91	53x	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	87x	private$content <- c(private$content, content)
113	87x	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	39x	get_content = function() private$content,
125		#' @description Clears all content and metadata from `ReportCard`.
126		#'
127		#' @return `self`, invisibly.
128		#'
129		reset = function() {
130	1x	private$content <- teal_card()
131	1x	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	18x	metadata(private$content, "title") <- name
181	18x	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	1x	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	2x	if (lifecycle::is_present(output_dir)) {
204	!	lifecycle::deprecate_soft("0.6.0", "ReportCard$to_list(output_dir)")
205		}
206	2x	unclass(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	1x	if (lifecycle::is_present(output_dir)) {
225	!	lifecycle::deprecate_soft("0.6.0", "ReportCard$to_list(output_dir)")
226		}
227	1x	self$reset()
228	1x	private$content <- as.teal_card(card)
229	1x	invisible(self)
230		}
231		),
232		private = list(
233		content = list(),
234		name = character(0L),
235		id = character(0L)
236		),
237		lock_objects = TRUE,
238		lock_class = TRUE
239		)
240
241		#' @export
242		length.ReportCard <- function(x) {
243	1x	length(x$get_content())
244		}

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

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	499x	htmltools::browsable(.toHTML(x, ...))
112		}
113
114		#' @keywords internal
115		.toHTML <- function(x, ...) { # nolint: object_name.
116	499x	UseMethod(".toHTML", x)
117		}
118
119		#' @method .toHTML default
120		#' @keywords internal
121		.toHTML.default <- function(x, ...) {
122	267x	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	80x	shiny::tags$pre(tools::toHTML(to_flextable(x)))
159		}
160
161		#' @method .toHTML flextable
162		#' @keywords internal
163		.toHTML.flextable <- function(x, ...) {
164	80x	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	58x	tmpfile <- tempfile(fileext = ".png")
175	58x	on.exit(unlink(tmpfile), add = TRUE)
176	58x	dims <- .determine_default_dimensions(x)
177	58x	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
178	58x	print(x)
179	58x	grDevices::dev.off()
180	58x	shiny::tags$img(
181	58x	src = knitr::image_uri(tmpfile),
182	58x	style = sprintf("width: 100%%; height: auto; max-width: %fpx", dims$width)
183		)
184		}
185
186		#' @method .toHTML recordedplot
187		#' @keywords internal
188		.toHTML.recordedplot <- .plot2html
189
190		#' @method .toHTML trellis
191		#' @keywords internal
192		.toHTML.trellis <- .plot2html
193
194		#' @method .toHTML gg
195		#' @keywords internal
196		.toHTML.gg <- function(x, ...) {
197	2x	dims <- .determine_default_dimensions(x, convert_to_inches = TRUE, dpi = 100)
198	2x	tmpfile <- tempfile(fileext = ".png")
199	2x	on.exit(unlink(tmpfile), add = TRUE)
200	2x	ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100)
201	2x	shiny::tags$img(src = knitr::image_uri(tmpfile), style = sprintf("max-width: %fpx", dims$width * 100))
202		}
203
204		#' @method .toHTML grob
205		#' @keywords internal
206		.toHTML.grob <- function(x, ...) {
207	1x	dims <- .determine_default_dimensions(x)
208	1x	tmpfile <- tempfile(fileext = ".png")
209	1x	on.exit(unlink(tmpfile), add = TRUE)
210	1x	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
211	1x	grid::grid.newpage()
212	1x	grid::grid.draw(x)
213	1x	grDevices::dev.off()
214	1x	shiny::tags$img(src = knitr::image_uri(tmpfile), style = sprintf("max-width: %fpx", dims$width))
215		}
216
217		#' @method .toHTML code_chunk
218		#' @keywords internal
219		.toHTML.code_chunk <- function(x, ...) {
220	5x	bslib::accordion(
221	5x	class = "code_chunk",
222	5x	open = FALSE,
223	5x	bslib::accordion_panel(
224	5x	title = shiny::tags$span(shiny::icon("code"), attr(x, "lang", exact = TRUE)),
225	5x	value = "rcode",
226	5x	shiny::tags$pre(
227	5x	shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang", exact = TRUE))),
228	5x	.noWS = "inside"
229		)
230		)
231		)
232		}
233
234		#' @method .toHTML chunk_output
235		#' @keywords internal
236		.toHTML.chunk_output <- function(x, ...) {
237	2x	new_x <- x[[1]]
238	2x	mostattributes(new_x) <- c(attributes(unclass(x)), attributes(new_x))
239	2x	tools::toHTML(new_x, ...)
240		}
241
242		#' @method .toHTML summary.lm
243		#' @keywords internal
244		.toHTML.summary.lm <- function(x, ...) {
245	!	shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n"))
246		}
247
248		#' @method .toHTML TableTree
249		#' @keywords internal
250		.toHTML.TableTree <- .toHTML.rtables
251
252		#' @method .toHTML ElementaryTable
253		#' @keywords internal
254		.toHTML.ElementaryTable <- .toHTML.rtables
255
256		#' @method .toHTML rlisting
257		#' @keywords internal
258		.toHTML.rlisting <- .toHTML.rtables
259
260		#' @method .toHTML data.frame
261		#' @keywords internal
262		.toHTML.data.frame <- .toHTML.rtables
263
264		#' @method .toHTML datatables
265		#' @keywords internal
266		.toHTML.datatables <- function(x, ...) {
267	!	x
268		}
269
270		#' @method .toHTML gtsummary
271		#' @keywords internal
272		.toHTML.gtsummary <- function(x, ...) {
273	!	tools::toHTML(gtsummary::as_flex_table(x))
274		}
275
276		#' @method .toHTML listing_df
277		#' @keywords internal
278		.toHTML.listing_df <- function(x, ...) {
279	!	tools::toHTML(flextable::as_flextable(x))
280		}

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	6x	private$content <- content
137	6x	invisible(self)
138		},
139	4x	get_content = function() private$content,
140	!	from_list = function(x) invisible(self),
141	!	to_list = function() list()
142		),
143		private = list(content = NULL),
144		lock_objects = TRUE,
145		lock_class = TRUE
146		)
147
148		#' @noRd
149		RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
150		classname = "RcodeBlock",
151		inherit = ContentBlock,
152		public = list(
153		initialize = function(content = character(0), ...) {
154	2x	checkmate::assert_class(content, "character")
155	2x	super$set_content(content)
156	2x	self$set_params(list(...))
157	2x	invisible(self)
158		},
159		set_content = function(content) {
160	!	checkmate::assert_string(content)
161	!	super$set_content(content)
162		},
163		set_params = function(params) {
164	2x	checkmate::assert_list(params, names = "named")
165	2x	checkmate::assert_subset(names(params), self$get_available_params())
166	2x	private$params <- params
167	2x	invisible(self)
168		},
169	4x	get_params = function() private$params,
170	!	get_available_params = function() names(knitr::opts_chunk$get()),
171		from_list = function(x) {
172	!	checkmate::assert_list(x)
173	!	checkmate::assert_names(names(x), must.include = c("text", "params"))
174	!	self$set_content(x$text)
175	!	self$set_params(x$params)
176	!	invisible(self)
177		},
178		get_content = function(output_format = NULL) {
179	4x	params <- self$get_params()
180	4x	params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
181	4x	if (identical(output_format, "powerpoint_presentation")) {
182	2x	block_content_list <- split_text_block(super$get_content(), 30)
183	2x	paste(
184	2x	sprintf(
185	2x	"```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
186	2x	shQuote(block_content_list, type = "cmd")
187		),
188	2x	collapse = "\n\n"
189		)
190		} else {
191	2x	sprintf(
192	2x	"```{r, %s}\n%s\n```\n",
193	2x	paste(names(params), params, sep = "=", collapse = ", "),
194	2x	super$get_content()
195		)
196		}
197		},
198	!	to_list = function() list(text = self$get_content(), params = self$get_params())
199		),
200		private = list(
201		content = character(0),
202		params = list()
203		),
204		lock_objects = TRUE,
205		lock_class = TRUE
206		)
207
208		#' @noRd
209		TextBlock <- R6::R6Class( # nolint: object_name_linter.
210		classname = "TextBlock",
211		inherit = ContentBlock,
212		public = list(
213		initialize = function(content = character(0), style = private$styles[1]) {
214	4x	super$set_content(content)
215	4x	self$set_style(style)
216	4x	invisible(self)
217		},
218		set_content = function(content) {
219	!	checkmate::assert_string(content)
220	!	super$set_content(content)
221		},
222		get_content = function() {
223	4x	if (private$style == "verbatim") {
224	1x	return(sprintf("```\n%s\n```\n", private$content))
225		}
226	3x	sprintf(
227	3x	"%s%s",
228	3x	switch(private$style,
229	3x	header2 = "## ",
230	3x	header3 = "### ",
231		""
232		),
233	3x	private$content
234		)
235		},
236		set_style = function(style) {
237	4x	private$style <- match.arg(style, private$styles)
238	4x	invisible(self)
239		},
240	!	get_style = function() private$style,
241	!	get_available_styles = function() private$styles,
242		from_list = function(x) {
243	!	checkmate::assert_list(x)
244	!	checkmate::assert_names(names(x), must.include = c("text", "style"))
245	!	self$set_content(x$text)
246	!	self$set_style(x$style)
247	!	invisible(self)
248		},
249	!	to_list = function() list(text = self$get_content(), style = self$get_style())
250		),
251		private = list(
252		content = character(0),
253		style = character(0),
254		styles = c("default", "header2", "header3", "verbatim")
255		),
256		lock_objects = TRUE,
257		lock_class = TRUE
258		)

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 `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	97x	private$cards <- shiny::reactiveValues()
23	97x	private$cached_html <- shiny::reactiveValues()
24	97x	private$open_previewer_r <- shiny::reactiveVal(NULL)
25	97x	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	84x	if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) {
45	13x	cards <- list(cards)
46		}
47
48	84x	checkmate::assert_list(cards, types = c("ReportCard", "teal_card"))
49	84x	new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content())
50
51	84x	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	84x	names(new_cards) <- vapply(new_cards, function(card) {
57	128x	sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8))
58	84x	}, character(1L))
59
60	84x	for (card_id in names(new_cards)) {
61	128x	card <- new_cards[[card_id]]
62	128x	private$cards[[card_id]] <- card
63	128x	private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
64		}
65	84x	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	2x	if (inherits(card, "ReportCard")) {
106	1x	card <- card$get_content()
107		}
108	2x	private$cards[[card_id]] <- card
109	2x	private$cached_html[[card_id]] <- lapply(card, tools::toHTML)
110	2x	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	217x	result <- if (shiny::isRunning()) {
122	!	shiny::reactiveValuesToList(private$cards)
123		} else {
124	217x	shiny::isolate(shiny::reactiveValuesToList(private$cards))
125		}
126	217x	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	217x	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	96x	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		),
439		lock_objects = TRUE,
440		lock_class = TRUE
441		)

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	24x	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	19x	checkmate::assert_string(input)
70	18x	checkmate::assert_string(name)
71	18x	checkmate::assert_character(pos_logi)
72	18x	checkmate::assert_character(neg_logi)
73	18x	checkmate::assert_flag(silent)
74
75	18x	all_logi <- c(pos_logi, neg_logi)
76	18x	if (input %in% all_logi) {
77	16x	if (isFALSE(silent)) {
78	1x	message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
79		}
80	16x	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	28x	rmarkdown_namespace <- asNamespace("rmarkdown")
99	28x	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	27x	checkmate::assert_string(output_name)
116	27x	checkmate::assert_subset(output_name, rmd_outputs())
117
118	26x	rmarkdown_namespace <- asNamespace("rmarkdown")
119	26x	if (default_values) {
120	24x	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	28x	checkmate::assert_logical(as_header)
198	28x	checkmate::assert_logical(convert_logi)
199	28x	checkmate::assert_logical(silent)
200	28x	checkmate::assert_logical(multi_output)
201
202	28x	if (multi_output) {
203	1x	checkmate::assert_list(input_list, names = "named")
204		} else {
205	27x	checkmate::assert_list(input_list, names = "unique")
206		}
207
208	25x	is_nested <- function(x) any(unlist(lapply(x, is.list)))
209	25x	if (is_nested(input_list)) {
210	2x	result <- input_list
211		} else {
212	23x	result <- list()
213	23x	input_nams <- names(input_list)
214
215		# top fields
216	23x	top_fields <- c(
217	23x	"author", "date", "title", "subtitle", "abstract",
218	23x	"keywords", "subject", "description", "category", "lang"
219		)
220	23x	for (itop in top_fields) {
221	230x	if (itop %in% input_nams) {
222	28x	result[[itop]] <- switch(itop,
223	28x	date = as.character(input_list[[itop]]),
224	28x	input_list[[itop]]
225		)
226		}
227		}
228
229		# output field
230	23x	doc_types <- unlist(input_list[input_nams == "output"])
231	23x	if (length(doc_types)) {
232	21x	for (dtype in doc_types) {
233	22x	doc_type_args <- rmd_output_arguments(dtype, TRUE)
234	22x	doc_type_args_nams <- names(doc_type_args)
235	22x	any_output_arg <- any(input_nams %in% doc_type_args_nams)
236
237	22x	not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
238	22x	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	22x	if (any_output_arg) {
243	12x	doc_list <- list()
244	12x	doc_list[[dtype]] <- list()
245	12x	for (e in intersect(input_nams, doc_type_args_nams)) {
246	19x	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	19x	doc_list[[dtype]][[e]] <- input_list[[e]]
259		}
260	12x	result[["output"]] <- append(result[["output"]], doc_list)
261		} else {
262	10x	result[["output"]] <- append(result[["output"]], input_list[["output"]])
263		}
264		}
265		}
266		}
267
268	25x	result <- yaml::as.yaml(result)
269	25x	if (as_header) {
270	24x	result <- md_header(result)
271		}
272	25x	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	1x	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		.content_to_rmd <- function(block, folder_path = ".", ...) {
2	6x	tempfile <- tempfile(pattern = "report_item_", fileext = ".rds")
3	6x	path <- file.path(folder_path, basename(tempfile))
4	6x	suppressWarnings(saveRDS(block, file = path))
5	6x	sprintf("```{r echo = FALSE, eval = TRUE}\nreadRDS('%s')\n```", path)
6		}
7
8		.plot_to_rmd <- function(block, folder_path = ".", ...) {
9	17x	tempfile <- tempfile(pattern = "report_item_", fileext = ".rds")
10	17x	path <- file.path(folder_path, basename(tempfile))
11	17x	suppressWarnings(saveRDS(block, file = path))
12	17x	dims <- .determine_default_dimensions(block, convert_to_inches = TRUE)
13
14	17x	chunk <- if (inherits(block, "grob")) {
15	!	"```{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.
16		} else {
17	17x	"```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```"
18		}
19
20	17x	sprintf(
21	17x	chunk,
22	17x	dims$width,
23	17x	dims$height,
24	17x	path
25		)
26		}
27
28		#' Convert `ReporterCard`/`teal_card` content to `rmarkdown`
29		#'
30		#' This is an S3 generic that is used to generate content in `rmarkdown` format
31		#' from various types of blocks in a `ReporterCard` or `teal_card` object.
32		#'
33		#' ## Customize `to_rmd`
34		#'
35		#' The methods for this S3 generic can be extended by the app developer or even overwritten.
36		#' For this a function with the name `to_rmd.<class>` should be defined in the
37		#' Global Environment or registered as an S3 method, where `<class>` is the class of the
38		#' object to be converted.
39		#'
40		#' For example, to override the default behavior for `code_chunk` class, you can use:
41		#'
42		#' ```r
43		#' to_rmd.code_chunk <- function(block, ...) {
44		#' # custom implementation
45		#' sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block)
46		#' }
47		#' ```
48		#'
49		#' Alternatively, the S3 method can be registered using `registerS3method("to_rmd", "<class>", fun)`
50		#'
51		#' ## Defaults
52		#'
53		#' `teal.reporter` provides default `to_rmd` methods for several common classes that
54		#' returns the content in appropriate R Markdown syntax.
55		#' These include:
56		#' - `character`
57		#' - [code_chunk()] objects
58		#' - `ggplot2` plots
59		#' - `data.frame`
60		#' - `flextable`
61		#' - `rtables` tables
62		#' - and others.
63		#'
64		#' All of these defaults can be overridden by defining new `to_rmd.<class>` methods.
65		#' These methods are implemented internally using the helper function `.to_rmd.<class>`.
66		#'
67		#' @param block (`any`) content which can be represented in Rmarkdown syntax.
68		#' @param ... additional arguments passed to implemented methods for different classes.
69		#' @return `character(1)` containing a content or Rmarkdown document.
70		#' @examples
71		#' to_rmd(c("## This is a simple text block.", "", "With a paragraph break."))
72		#' to_rmd(code_chunk("summary(cars)"))
73		#' to_rmd(data.frame(x = 1:10, y = 21:30), folder_path = tempdir())
74		#' @examplesIf requireNamespace("ggplot2", quietly = TRUE)
75		#'
76		#' # Example with ggplot2 will create a temporary RDS file in the tempdir()
77		#' to_rmd(
78		#' ggplot2::ggplot(mtcars, ggplot2::aes(x = wt, y = mpg)) +
79		#' ggplot2::geom_point(),
80		#' folder_path = tempdir() # internal argument of ggplot2 method
81		#' )
82		#' @export
83		to_rmd <- function(block, ...) {
84	222x	UseMethod("to_rmd")
85		}
86
87		#' @method to_rmd default
88		#' @export
89		to_rmd.default <- function(block, ...) {
90	220x	.to_rmd(block, ...)
91		}
92
93		.to_rmd <- function(block, ...) {
94	220x	UseMethod(".to_rmd")
95		}
96
97		#' @method .to_rmd default
98		#' @keywords internal
99		.to_rmd.default <- function(block, ...) {
100	1x	block
101		}
102
103		#' @method .to_rmd teal_report
104		#' @keywords internal
105		.to_rmd.teal_report <- function(block, ...) {
106	28x	to_rmd(teal_card(block), ...)
107		}
108
109		#' @method .to_rmd teal_card
110		#' @keywords internal
111		.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
112	44x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
113	44x	is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation")
114	44x	powerpoint_exception_parsed <- if (is_powerpoint) {
115	2x	format_code_block_function <- quote(
116	2x	code_block <- function(code_text) {
117	!	df <- data.frame(code_text)
118	!	ft <- flextable::flextable(df)
119	!	ft <- flextable::delete_part(ft, part = "header")
120	!	ft <- flextable::autofit(ft, add_h = 0)
121	!	ft <- flextable::fontsize(ft, size = 7, part = "body")
122	!	ft <- flextable::bg(x = ft, bg = "lightgrey")
123	!	ft <- flextable::border_outer(ft)
124	!	if (flextable::flextable_dim(ft)$widths > 8) {
125	!	ft <- flextable::width(ft, width = 8)
126		}
127	!	ft
128		}
129		)
130	2x	deparse1(format_code_block_function, collapse = "\n")
131		} else {
132	42x	NULL
133		}
134	44x	global_knitr_parsed <- sprintf(
135	44x	"knitr::opts_chunk$set(%s)",
136	44x	paste(utils::capture.output(dput(global_knitr)), collapse = "")
137		)
138	44x	global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE)
139
140	44x	m_yaml <- metadata(block)
141	44x	if ("SRC" %in% names(m_yaml)) {
142	!	m_yaml$SRC <- NULL # TODO: remove when *Block functions are removed from `previewer_deprecated.R`
143		}
144	44x	paste(
145	44x	c(
146	44x	if (length(m_yaml)) as_yaml_auto(m_yaml),
147	44x	if (length(global_knitr) \|\| is_powerpoint) to_rmd(global_knitr_code_chunk),
148	44x	unlist(lapply(
149	44x	block,
150	44x	function(x) to_rmd(x, output_format = m_yaml$output, ...)
151		))
152		),
153	44x	collapse = "\n\n"
154		)
155		}
156
157		#' @method .to_rmd code_chunk
158		#' @keywords internal
159		.to_rmd.code_chunk <- function(block, ..., output_format = NULL) {
160	49x	params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l)
161	49x	block_str <- format(block)
162	49x	lang <- attr(block, "lang", exact = TRUE)
163	49x	if (identical(output_format, "powerpoint_presentation")) {
164	!	block_content_list <- lapply(
165	!	split_text_block(block, 30),
166	!	function(x, lang) {
167	!	code_block <- sprintf("code_block(\n%s)", shQuote(x, type = "cmd"))
168	!	format(code_chunk(code_block, echo = FALSE, lang = lang))
169		},
170	!	lang = lang
171		)
172	!	paste(sprintf("\\newpage\n\n---\n\n%s\n", block_content_list), collapse = "\n\n")
173		} else {
174	49x	format(block)
175		}
176		}
177
178		#' @method .to_rmd character
179		#' @keywords internal
180		.to_rmd.character <- function(block, ...) {
181	61x	block
182		}
183
184		#' @method .to_rmd chunk_output
185		#' @keywords internal
186		.to_rmd.chunk_output <- function(block, ..., include_chunk_output) {
187	8x	if (!missing(include_chunk_output) && isTRUE(include_chunk_output)) {
188	4x	new_block <- block[[1]]
189	4x	mostattributes(new_block) <- c(attributes(unclass(block)), attributes(new_block))
190	4x	to_rmd(new_block, ..., include_chunk_output = include_chunk_output)
191		}
192		}
193
194		#' @method .to_rmd condition
195		#' @keywords internal
196		.to_rmd.condition <- function(block, ...) {
197	1x	conditionMessage(block)
198		}
199
200		#' @method .to_rmd gg
201		#' @keywords internal
202		.to_rmd.gg <- .plot_to_rmd
203
204		#' @method .to_rmd trellis
205		#' @keywords internal
206		.to_rmd.trellis <- .plot_to_rmd
207
208		#' @method .to_rmd recordedplot
209		#' @keywords internal
210		.to_rmd.recordedplot <- .plot_to_rmd
211
212		#' @method .to_rmd grob
213		#' @keywords internal
214		.to_rmd.grob <- .plot_to_rmd
215
216		#' @method .to_rmd Heatmap
217		#' @keywords internal
218		.to_rmd.Heatmap <- .plot_to_rmd
219
220		#' @method .to_rmd datatables
221		#' @keywords internal
222		.to_rmd.datatables <- .content_to_rmd
223
224		#' @method .to_rmd summary.lm
225		#' @keywords internal
226		.to_rmd.summary.lm <- .content_to_rmd
227
228		#' @method .to_rmd rtables
229		#' @keywords internal
230		.to_rmd.rtables <- function(block, ...) {
231	5x	flextable_block <- to_flextable(block)
232	5x	attr(flextable_block, "keep") <- attr(block, "keep")
233	5x	to_rmd(flextable_block, ...)
234		}
235
236		#' @method .to_rmd flextable
237		#' @keywords internal
238		.to_rmd.flextable <- .content_to_rmd
239
240		#' @method .to_rmd TableTree
241		#' @keywords internal
242		.to_rmd.TableTree <- .to_rmd.rtables
243
244		#' @method .to_rmd ElementaryTable
245		#' @keywords internal
246		.to_rmd.ElementaryTable <- .to_rmd.rtables
247
248		#' @method .to_rmd rlisting
249		#' @keywords internal
250		.to_rmd.rlisting <- .to_rmd.rtables
251
252		#' @method .to_rmd data.frame
253		#' @keywords internal
254		.to_rmd.data.frame <- .to_rmd.rtables
255
256		#' @method .to_rmd gtsummary
257		#' @keywords internal
258		.to_rmd.gtsummary <- function(block, ...) {
259	!	to_rmd(gtsummary::as_flex_table(block), ...)
260		}
261
262		#' @method .to_rmd listing_df
263		#' @keywords internal
264		.to_rmd.listing_df <- function(block, ...) {
265	!	to_rmd(flextable::as_flextable(block), ...)
266		}
267
268		#' @method .to_rmd ContentBlock
269		#' @keywords internal
270		.to_rmd.ContentBlock <- function(block, ...) {
271	!	to_rmd(block$get_content(), ...)
272		}
273
274		#' @method .to_rmd RcodeBlock
275		#' @keywords internal
276		.to_rmd.RcodeBlock <- function(block, output_format, ...) {
277	!	to_rmd(code_chunk(block$get_content(output_format), lang = "R"), ...)
278		}

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::tags$div(
45	1x	class = "teal-reporter reporter-editor-modal",
46	1x	.custom_css_dependency(),
47	1x	shiny::modalDialog(
48	1x	title = shiny::tags$span(
49	1x	class = "edit_title_container",
50	1x	"Editing Card:",
51	1x	shiny::tags$span(id = session$ns("static_title"), title),
52	1x	shiny::actionButton(
53	1x	session$ns("edit_title"),
54	1x	label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"),
55	1x	class = "fs-6",
56	1x	title = "Edit title"
57		),
58	1x	shinyjs::hidden(
59	1x	shiny::textInput(
60	1x	session$ns("new_title"),
61	1x	label = NULL, value = metadata(template_card, "title")
62		)
63		)
64		),
65	1x	size = "xl",
66	1x	easyClose = TRUE,
67	1x	shiny::tagList(
68	1x	ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)),
69	1x	shiny::uiOutput(session$ns("add_text_element_button_ui"))
70		),
71	1x	footer = shiny::tagList(
72	1x	shiny::actionButton(session$ns("edit_save"), label = "Save"),
73	1x	shiny::modalButton("Close")
74		)
75		)
76		)
77		)
78		}
79		)
80
81	6x	block_input_names_rvs <- srv_card_editor("editor", new_card_rv)
82
83	6x	shiny::observeEvent(input$edit_title, {
84	!	shinyjs::hide("edit_title")
85	!	shinyjs::hide("static_title")
86	!	shinyjs::show("new_title")
87	!	shinyjs::js$jumpToFocus(session$ns("new_title"))
88		})
89
90		# Handle
91	6x	shiny::observeEvent(input$edit_save, {
92	1x	new_card <- shiny::req(new_card_rv())
93	1x	input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs))
94	1x	for (name in names(input_r)) {
95	2x	new_card[[name]] <- shiny::isolate(input_r[[name]]())
96		}
97	1x	if (isFALSE(is.null(input$new_title))) {
98	!	metadata(new_card, "title") <- input$new_title
99		}
100	1x	if (isFALSE(identical(new_card, card_r()))) {
101	1x	tryCatch(
102		{
103	1x	reporter$replace_card(card = new_card, card_id = card_id)
104	1x	new_card_rv(NULL)
105	1x	reporter$open_previewer(Sys.time())
106	1x	shiny::showNotification("Card was successfully updated.", type = "message")
107		},
108	1x	error = function(err) {
109	!	shiny::showNotification(
110	!	sprintf(
111	!	"A card with the name '%s' already exists. Please use a different name.",
112	!	metadata(new_card, "title")
113		),
114	!	type = "error",
115	!	duration = 5
116		)
117	!	shinyjs::enable("edit_save")
118		}
119		)
120		} else {
121	!	new_card_rv(NULL)
122	!	reporter$open_previewer(Sys.time())
123		}
124		})
125
126	6x	shiny::observeEvent(input$toggle_code_action, {
127	!	shinyjs::runjs(sprintf("toggleRCodeAccordions('%s');", card_id))
128		})
129
130		# Handle remove button
131	6x	shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id))
132		})
133		}

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		#' 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		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	49x	args <- list(...)
50	!	if (is.null(teal_card)) teal_card <- teal_card()
51	49x	checkmate::assert_class(teal_card, "teal_card")
52	48x	checkmate::assert_list(args, names = "named")
53	48x	methods::callNextMethod(
54	48x	.Object,
55	48x	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	41x	if (is.null(teal_card)) teal_card <- teal_card()
118	49x	methods::new(
119	49x	"teal_report",
120	49x	.xData = list2env(list(...)),
121	49x	teal_card = teal_card,
122	49x	join_keys = join_keys,
123	49x	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	5x	if (inherits(from, "teal_report")) {
131	!	return(from)
132		}
133	5x	new_x <- teal_report()
134	5x	for (slot_name in methods::slotNames(from)) {
135	18x	methods::slot(new_x, slot_name) <- methods::slot(from, slot_name)
136		}
137	5x	teal_card(new_x) <- .code_to_card(from@code)
138	5x	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	5x	checkmate::assert_class(x, "qenv")
149	5x	methods::as(x, "teal_report")
150		}

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		#' 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		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		#' 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		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	24x	new_object <- methods::callNextMethod(object = object, code = code, ...)
26	24x	if (inherits(new_object, "error")) {
27	2x	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		)

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	52x	result <- NextMethod()
11	52x	l <- Filter(function(x) inherits(x, "teal_report"), list(...))
12	52x	if (length(l) > 1) {
13	4x	teal_card(result) <- suppressWarnings(do.call(c, lapply(l, teal_card)), classes = "teal_card_append")
14		}
15	52x	result
16		}