teal.reporter coverage - 69.93%

Files
Source

#' 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(
    .outline_button(
      ns("preview_button"),
      label = shiny::tags$span(
        label,
        shiny::uiOutput(ns("preview_button_counter"))
      ),
      icon = "file-earmark-text"
    )
  )
}

#' @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 = "position-absolute badge rounded-pill bg-primary",
        length(reporter$get_cards())
      )
    })

    preview_modal <- function(cached_content) {
      shiny::tags$div(
        class = "teal-reporter reporter-previewer-modal",
        .custom_css_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
            }
          }
        )
      }
    )
  })
}

#' @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`.
#'
#' @examples
#' # Create a new empty card
#' report <- teal_card()
#'
#' # Create a card with content
#' report <- teal_card("## Headline", "Some text", summary(iris))
#'
#' # Extract card from a teal_report
#' tr <- teal_report(teal_card = teal_card("## Title"))
#' doc <- teal_card(tr)
#'
#' # Add elements to the report
#' report <- c(report, list("## Table"), list(summary(mtcars)))
#'
#' # Subset the report to keep only the first two elements
#' report <- report[1:2]
#'
#' # Append new elements after the first element
#' report <- append(report, c(list("## Table 2"), list(summary(mtcars))), after = 1)
#'
#' # Verify that the object remains a teal_card
#' class(report)
#'
#' @aliases teal_card
#' @name teal_card
#'
#' @export
teal_card <- function(...) {
  UseMethod("teal_card")
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' Generate an R Markdown code chunk
#'
#' This function creates a `code_chunk` object, which represents an R Markdown
#' code chunk. It stores the R code and any specified chunk options (e.g., `echo`, `eval`).
#' These objects are typically processed later to generate the final R Markdown text.
#'
#' @param code A character string containing the R code.
#' @param ... Additional named parameters to be included as chunk options (e.g., `echo = TRUE`).
#' Check [`knitr` options/](https://yihui.org/knitr/options/) for more details.
#' @param lang (`character(1)`) See [`knitr::knit_engines`].
#'
#' @return An object of class `code_chunk`.
#' @examples
#' my_chunk <- code_chunk("x <- 1:10", echo = TRUE, message = FALSE)
#' class(my_chunk)
#' attributes(my_chunk)$param
#' @export
code_chunk <- function(code, ..., lang = "R") {
  checkmate::assert_character(code)
  params <- list(...)
  checkmate::assert_list(params, names = "named", .var.name = "...")
  structure(
    paste(code, collapse = "\n"),
    params = params,
    lang = lang,
    class = "code_chunk"
  )
}

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

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

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

#' Determine default dimensions for report figures
#'
#' @param x An object, typically a `recordedplot` or `ggplot`, that has an
#' optional attributes `dev.width` and `dev.height` that override the default
#' dims set as options `teal.reporter.dev.fig.width` and
#' `teal.reporter.dev.fig.height`.
#' @return List with `width` and `height` elements.
#' @keywords internal
resolve_figure_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)
}

#' 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)
  .outline_button(
    shiny::NS(id, "reporter_load"),
    label = label,
    icon = "upload"
  )
}

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

      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

ui_previewer_card_actions <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::actionLink(
      inputId = ns("edit_action"),
      class = "btn btn-primary btn-sm float-end p-3",
      label = NULL,
      title = "Edit card",
      icon = shiny::icon("edit")
    ),
    shiny::actionLink(
      inputId = ns("remove_action"),
      class = "btn btn-danger btn-sm float-end p-3",
      label = NULL,
      icon = shiny::icon("trash-alt"),
    )
  )
}

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

    shiny::observeEvent(
      ignoreInit = TRUE,
      input$edit_action,
      {
        template_card <- card_r()
        new_card_rv(template_card)
        title <- metadata(template_card, "title")

        if (is.null(title) || isFALSE(nzchar(title))) {
          title <- shiny::tags$span(class = "text-muted", "(Empty title)")
        }

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

    block_input_names_rvs <- srv_card_editor("editor", new_card_rv)

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

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

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

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

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

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

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

#' @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)) {
        private$cards[[card_id]] <- new_cards[[card_id]]
        private$cached_html[[card_id]] <- lapply(new_cards[[card_id]], 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")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' 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"
    #'
    #' 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")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' 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"
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1))
    #'
    #' 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"
    #'
    #' 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")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- teal_card("## Header 2 text", "A paragraph of default text")
    #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram())
    #'
    #' 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
    #' )
    #'
    #' 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")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- teal_card("## Header 2 text", "A paragraph of default text")
    #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram())
    #'
    #' 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
    #' )
    #'
    #' 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.5.0.9000", "Reporter$from_reporter()")
      checkmate::assert_class(reporter, "Reporter")
      self$reset()
      self$append_cards(reporter$get_cards())
      self$append_metadata(reporter$get_metadata())
      invisible(self)
    },
    #' @description Convert a `Reporter` to a list and transfer any associated files to specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where files will be copied.
    #' @return `named list` representing the `Reporter` instance, including version information,
    #'  metadata, and report cards.
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "testdir")
    #' dir.create(tmp_dir)
    #' reporter$to_list(tmp_dir)
    to_list = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list())
      rlist[["metadata"]] <- self$get_metadata()
      cards <- self$get_cards()
      for (i in seq_along(cards)) {
        # we want to have list names being a class names to indicate the class for $from_list
        card <- cards[[i]]
        card_class <- class(card)[1]
        u_card <- list()
        tmp <- tempfile(fileext = ".rds")
        suppressWarnings(saveRDS(card, file = tmp))
        tmp_base <- basename(tmp)
        file.copy(tmp, file.path(output_dir, tmp_base))
        u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base)
        rlist$cards <- c(rlist$cards, u_card)
      }
      rlist
    },
    #' @description Extracts and saves all figure elements from the `teal_card` objects in the
    #' `Reporter` to a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where figures will be saved.
    #' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures.
    write_figures = function(output_dir, sub_directory = "figures") {
      figures_dir <- file.path(output_dir, sub_directory)
      dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
      cards <- self$get_cards()
      for (card_id in names(cards)) {
        card <- cards[[card_id]]
        cached_html <- self$get_cached_html(card_id)
        for (element_ix in seq_along(card)) {
          card_element <- card[[element_ix]]
          if (
            inherits(card_element, "chunk_output") &&
              checkmate::test_multi_class(
                card_element[[1]],
                classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap")
              )
          ) {
            base64_image <- cached_html[[names(card)[[element_ix]]]]
            if ( # Ensure we only save valid base64 images
              !is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") &&
                !is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src)
            ) {
              b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src)
              writeBin(
                jsonlite::base64_dec(b64),
                file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix))
              )
            }
          }
        }
      }
    },
    #' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
    #' @param rlist (`named list`) representing a `Reporter` instance.
    #' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
    #' @return `self`, invisibly.
    #' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "testdir")
    #' unlink(tmp_dir, recursive = TRUE)
    #' dir.create(tmp_dir)
    #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
    from_list = function(rlist, output_dir) {
      id <- self$get_id()
      checkmate::assert_list(rlist)
      checkmate::assert_directory_exists(output_dir)
      stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter")
      stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id)
      if (rlist$version %in% c("1")) {
        new_cards <- list()
        cards_names <- names(rlist$cards)
        cards_names <- gsub("[.][0-9]*$", "", cards_names)
        for (iter_c in seq_along(rlist$cards)) {
          card_class <- cards_names[iter_c]
          card <- rlist$cards[[iter_c]]
          if (card_class == "teal_card") {
            new_card <- readRDS(file.path(output_dir, card$path))
            class(new_card) <- "teal_card"
            new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards
            names(new_card) <- card$name
          } else {
            new_card <- eval(str2lang(card_class))$new()
            new_card$from_list(card, output_dir)
          }
          new_cards <- c(new_cards, new_card)
        }
      } else {
        stop(
          sprintf(
            "The provided %s reporter version is not supported.",
            rlist$version
          )
        )
      }
      self$reset()
      self$set_id(rlist$id)
      self$append_cards(new_cards)
      self$append_metadata(rlist$metadata)
      invisible(self)
    },
    #' @description Serializes the `Reporter` to a `JSON` file and copies any associated files to a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory where files will be copied, `JSON` and statics.
    #' @return `output_dir` argument.
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "jsondir")
    #' dir.create(tmp_dir)
    #' reporter$to_jsondir(tmp_dir)
    to_jsondir = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      json <- self$to_list(output_dir)
      cat(
        jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
        file = file.path(output_dir, "Report.json")
      )
      output_dir
    },
    #' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory.
    #' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics.
    #' @return `self`, invisibly.
    #' @note if Report has an id when converting to JSON then It will be compared to the currently available one.
    #' @examples
    #' reporter <- Reporter$new()
    #' tmp_dir <- file.path(tempdir(), "jsondir")
    #' dir.create(tmp_dir)
    #' unlink(list.files(tmp_dir, recursive = TRUE))
    #' reporter$to_jsondir(tmp_dir)
    #' reporter$from_jsondir(tmp_dir)
    from_jsondir = function(output_dir) {
      checkmate::assert_directory_exists(output_dir)
      dir_files <- list.files(output_dir)
      stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0)
      stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files))
      json <- jsonlite::read_json(file.path(output_dir, "Report.json"))
      self$reset()
      self$from_list(json, output_dir)
      invisible(self)
    },
    #' @description Set the `Reporter` id
    #' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list.
    #' The id is added to the downloaded file name.
    #' @param id (`character(1)`) a Report id.
    #' @return `self`, invisibly.
    set_id = function(id) {
      private$id <- id
      invisible(self)
    },
    #' @description Get or set the reactive trigger to open the previewer modal.
    #' @param  val value to the passed to the reactive trigger.
    #' @return `reactiveVal` value
    open_previewer = function(val) {
      if (missing(val)) {
        private$open_previewer_r()
      } else {
        private$open_previewer_r(val)
      }
    },
    #' @description Get cached HTML for a specific `teal_card` by its id.
    #' @param card_id (`character(1)`) the unique id of the card.
    get_cached_html = function(card_id) {
      if (shiny::isRunning()) {
        private$cached_html[[card_id]]
      } else {
        shiny::isolate(private$cached_html[[card_id]])
      }
    },
    #' @description Get the `Reporter` id
    #' @return `character(1)` the `Reporter` id.
    get_id = function() private$id,
    #' @description Set template function for `teal_card`
    #' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards`
    #' @param template (`function`) a template function.
    #' @return `self`, invisibly.
    #' @examples
    #'
    #' reporter <- teal.reporter::Reporter$new()
    #' template_fun <- function(document) {
    #'   disclaimer <- teal.reporter::teal_card("Here comes disclaimer text")
    #'   c(disclaimer, document)
    #' }
    #' reporter$set_template(template_fun)
    #' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text")
    #' metadata(doc1, "title") <- "Welcome card"
    #' reporter$append_cards(doc1)
    #' reporter$get_cards()
    set_template = function(template) {
      private$template <- template
      invisible(self)
    },
    #' @description Get the `Reporter` template
    #' @return a template `function`.
    get_template = function() private$template
  ),
  private = list(
    id = "",
    cards = NULL, # reactiveValues
    cached_html = NULL, # reactiveValues
    open_previewer_r = NULL, # reactiveVal to trigger reactive contexts
    override_order = character(0L), # to sort cards (reactiveValues are not sortable)
    metadata = list(),
    template = NULL,
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      shiny::isolate({
        if (name == "cards") {
          new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) {
            if (R6::is.R6(card)) card$clone(deep = TRUE) else card
          })
          do.call(shiny::reactiveValues, new_cards)
        } else {
          value
        }
      })
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' 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)
  .outline_button(shiny::NS(id, "download_button"), label = label, icon = "download")
}

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

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

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

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

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

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

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

    ns <- session$ns

    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 Name",
            value = "",
            placeholder = "Add the card title here",
            width = "100%"
          ),
          shiny::textAreaInput(
            ns("comment"),
            "Comment",
            value = "",
            placeholder = "Add a comment here...",
            width = "100%"
          ),
          shiny::tags$script(
            shiny::HTML(
              sprintf("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 = input$label))
      }

      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(input$label) == 1 && input$label != "") {
            card$set_name(input$label)
          }
        } 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(input$label) == 1 && input$label != "") {
            metadata(card, "title") <- input$label
          }
        }

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

#' @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.5.1",
        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, ...))
    },
    #' @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.5.0.9000", "ReportCard$to_list(output_dir)")
      }
      private$content
    },
    #' @description Reconstructs the `ReportCard` from a list representation.
    #' @param card (`named list`) a `ReportCard` representation.
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #'
    #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
    #'
    from_list = function(card, output_dir = lifecycle::deprecated()) {
      if (lifecycle::is_present(output_dir)) {
        lifecycle::deprecate_soft("0.5.0.9000", "ReportCard$to_list(output_dir)")
      }
      self$reset()
      private$content <- card
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    name = character(0L),
    id = character(0L),
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "content") {
        content <- Reduce(
          f = function(result, this) {
            if (inherits(this, "R6")) {
              this <- this$clone(deep = TRUE)
            }
            c(result, this)
          },
          init = teal_card(),
          x = value
        )

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

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

#' 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)
  .outline_button(
    shiny::NS(id, "reset_reporter"),
    label = label,
    icon = "x-lg",
    class = "danger"
  )
}

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

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

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

.plot_to_rmd <- function(block, ...) {
  path <- basename(tempfile(pattern = "report_item_", fileext = ".rds"))
  suppressWarnings(saveRDS(block, file = path))
  dims <- resolve_figure_dimensions(block, convert_to_inches = TRUE)
  sprintf(
    "```{r echo = FALSE, eval = TRUE, fig.width = %f, fig.height = %f}\nreadRDS('%s')\n```",
    dims$width,
    dims$height,
    path
  )
}

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

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

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

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

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

#' @method .to_rmd teal_card
#' @keywords internal
.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) {
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation")
  powerpoint_exception_parsed <- if (is_powerpoint) {
    format_code_block_function <- quote(
      code_block <- function(code_text) {
        df <- data.frame(code_text)
        ft <- flextable::flextable(df)
        ft <- flextable::delete_part(ft, part = "header")
        ft <- flextable::autofit(ft, add_h = 0)
        ft <- flextable::fontsize(ft, size = 7, part = "body")
        ft <- flextable::bg(x = ft, bg = "lightgrey")
        ft <- flextable::border_outer(ft)
        if (flextable::flextable_dim(ft)$widths > 8) {
          ft <- flextable::width(ft, width = 8)
        }
        ft
      }
    )
    deparse1(format_code_block_function, collapse = "\n")
  } else {
    NULL
  }
  global_knitr_parsed <- sprintf(
    "knitr::opts_chunk$set(%s)",
    paste(utils::capture.output(dput(global_knitr)), collapse = "")
  )
  global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE)

  m <- metadata(block)
  paste(
    c(
      if (length(m)) as_yaml_auto(m),
      if (length(global_knitr) || is_powerpoint) to_rmd(global_knitr_code_chunk),
      unlist(lapply(
        block,
        function(x) to_rmd(x, output_format = m$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), ...)
}

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

#' @importFrom tools toHTML
NULL

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

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

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

#' @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, ...) {
  shiny::tagList(lapply(x, tools::toHTML, ...))
}

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

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

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

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

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

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

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

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

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

#' @method .toHTML code_chunk
#' @keywords internal
.toHTML.code_chunk <- function(x, ...) {
  shiny::tags$pre(
    shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang"))),
    .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))
}

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

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

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

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

#' @keywords internal
reporter_previewer_content_ui <- function(id, cached_content = rlang::list2()) {
  ns <- shiny::NS(id)
  shiny::tags$div(
    .custom_css_dependency(),
    bslib::accordion(
      id = ns("reporter_cards"),
      class = "teal-reporter report-previewer-accordion",
      !!!cached_content
    ),
    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
#' teal_report(x1 = iris, x2 = mtcars)
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")
}

#' @rdname srv_editor_block
#' @export
ui_editor_block <- function(id, value, cached_html) {
  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)`.
#'
#' @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 cached_html (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI.
#' @export
srv_editor_block <- function(id, value) {
  UseMethod("srv_editor_block", value)
}

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

#' @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) NULL) # No input being changed, skipping update
}

#' @method .ui_editor_block character
.ui_editor_block.character <- function(id, value, cached_html) {
  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) shiny::reactive(input$content))
}

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

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

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	3x	checkmate::assert_string(label, null.ok = TRUE)
21	3x	.outline_button(
22	3x	shiny::NS(id, "reporter_load"),
23	3x	label = label,
24	3x	icon = "upload"
25		)
26		}
27
28		#' @rdname load_report_button
29		#' @return `shiny::moduleServer`
30		#' @export
31		report_load_srv <- function(id, reporter) {
32	15x	checkmate::assert_class(reporter, "Reporter")
33
34	15x	shiny::moduleServer(
35	15x	id,
36	15x	function(input, output, session) {
37	15x	shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load"))
38	15x	ns <- session$ns
39
40	15x	archiver_modal <- function() {
41	3x	nr_cards <- length(reporter$get_cards())
42	3x	shiny::div(
43	3x	class = "teal-reporter reporter-modal",
44	3x	.custom_css_dependency(),
45	3x	shiny::modalDialog(
46	3x	easyClose = TRUE,
47	3x	shiny::tags$h3("Load the Report"),
48	3x	shiny::tags$hr(),
49	3x	shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)",
50	3x	multiple = FALSE,
51	3x	accept = c(".zip")
52		),
53	3x	footer = shiny::div(
54	3x	shiny::tags$button(
55	3x	type = "button",
56	3x	class = "btn btn-outline-secondary",
57	3x	`data-bs-dismiss` = "modal",
58	3x	NULL,
59	3x	"Dismiss"
60		),
61	3x	shinyjs::disabled(
62	3x	shiny::tags$button(
63	3x	id = ns("reporter_load_main"),
64	3x	type = "button",
65	3x	class = "btn btn-primary action-button",
66	3x	NULL,
67	3x	"Load"
68		)
69		)
70		)
71		)
72		)
73		}
74
75	15x	shiny::observeEvent(input$archiver_zip, {
76	3x	shinyjs::enable(id = "reporter_load_main")
77		})
78
79	15x	shiny::observeEvent(input$reporter_load, {
80	3x	shiny::showModal(archiver_modal())
81		})
82
83	15x	shiny::observeEvent(input$reporter_load_main, {
84	3x	load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]])
85	3x	shiny::removeModal()
86		})
87		}
88		)
89		}
90
91		#' @keywords internal
92		load_json_report <- function(reporter, zip_path, filename) {
93	3x	tmp_dir <- tempdir()
94	3x	output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
95	3x	dir.create(path = output_dir)
96	3x	if (!is.null(zip_path) && grepl("report(er)?_", filename)) {
97	3x	tryCatch(
98	3x	expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE),
99	3x	warning = function(cond) {
100	!	print(cond)
101	!	shiny::showNotification(
102	!	ui = "Unzipping folder warning!",
103	!	action = "Please contact app developer",
104	!	type = "warning"
105		)
106		},
107	3x	error = function(cond) {
108	!	print(cond)
109	!	shiny::showNotification(
110	!	ui = "Unzipping folder error!",
111	!	action = "Please contact app developer",
112	!	type = "error"
113		)
114		}
115		)
116	3x	tryCatch(
117	3x	reporter$from_jsondir(output_dir),
118	3x	warning = function(cond) {
119	!	print(cond)
120	!	shiny::showNotification(
121	!	ui = "Loading reporter warning!",
122	!	action = "Please contact app developer",
123	!	type = "warning"
124		)
125		},
126	3x	error = function(cond) {
127	1x	print(cond)
128	1x	shiny::showNotification(
129	1x	ui = "Loading reporter error!",
130	1x	action = "Please contact app developer",
131	1x	type = "error"
132		)
133		}
134		)
135		} else {
136	!	shiny::showNotification(
137	!	paste(
138	!	"Failed to load the Reporter file.",
139	!	"Please make sure that the filename starts with `report_`."
140		),
141	!	type = "error"
142		)
143		}
144		}
145		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	20x	checkmate::assert_multi_class(input, c("teal_report", "teal_card", "Reporter"))
32	20x	checkmate::assert_string(output_dir)
33	20x	checkmate::assert_list(global_knitr, names = "named")
34	20x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
35	20x	checkmate::assert_flag(keep_rmd)
36	20x	checkmate::assert_subset(names(list(...)), names(formals(rmarkdown::render)))
37
38		# Set output dir to a new working directory. Absolute paths in rmarkdown files will break .Rmd portability
39	20x	dir.create(output_dir, recursive = TRUE, showWarnings = FALSE)
40	20x	old_wd <- setwd(dir = output_dir)
41	20x	on.exit(setwd(old_wd))
42
43		# This Rmd file is for render purpose as it contains evaluated code chunks and their outputs.
44	20x	rmd_filepath <- "report.Rmd"
45	20x	temp_rmd_content <- to_rmd(
46	20x	block = input,
47	20x	global_knitr = c(global_knitr, list(eval = FALSE)), # we don't want to rerun evaluated code chunks to render
48	20x	include_chunk_output = TRUE
49		)
50	20x	cat(temp_rmd_content, file = rmd_filepath)
51	20x	args <- utils::modifyList(list(...), list(input = rmd_filepath))
52	20x	tryCatch(
53	20x	do.call(rmarkdown::render, args),
54	20x	finally = {
55	20x	report_items <- list.files(pattern = "report_item_")
56	20x	unlink(c(rmd_filepath, report_items))
57		}
58		)
59
60	20x	if (keep_rmd) {
61		# This Rmd file doesn't contain chunk_outputs as they can be reproduced when executing code-chunks
62	20x	out_rmd_content <- to_rmd(
63	20x	block = input,
64	20x	global_knitr = global_knitr,
65	20x	include_chunk_output = FALSE
66		)
67	20x	cat(out_rmd_content, file = rmd_filepath)
68		}
69	20x	output_dir
70		}

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		#'
40		#' @return `NULL`.
41		NULL
42
43		#' @rdname add_card_button
44		#' @export
45		add_card_button_ui <- function(id, label = NULL) {
46	2x	checkmate::assert_string(label, null.ok = TRUE)
47	2x	.outline_button(
48	2x	shiny::NS(id, "add_report_card_button"),
49	2x	icon = "plus-lg",
50	2x	label = label
51		)
52		}
53
54		#' @rdname add_card_button
55		#' @export
56		add_card_button_srv <- function(id, reporter, card_fun) {
57	15x	checkmate::assert_function(card_fun)
58	15x	checkmate::assert_class(reporter, "Reporter")
59	15x	checkmate::assert_subset(names(formals(card_fun)), c("card", "comment", "label"), empty.ok = TRUE)
60
61	15x	shiny::moduleServer(id, function(input, output, session) {
62	15x	shiny::setBookmarkExclude(c(
63	15x	"add_report_card_button", "download_button", "reset_reporter",
64	15x	"add_card_ok", "download_data", "reset_reporter_ok",
65	15x	"label", "comment"
66		))
67
68	15x	ns <- session$ns
69
70	15x	add_modal <- function() {
71	12x	shiny::div(
72	12x	class = "teal-reporter reporter-modal",
73	12x	.custom_css_dependency(),
74	12x	shiny::modalDialog(
75	12x	easyClose = TRUE,
76	12x	shiny::tags$h3("Add a Card to the Report"),
77	12x	shiny::tags$hr(),
78	12x	shiny::textInput(
79	12x	ns("label"),
80	12x	"Card Name",
81	12x	value = "",
82	12x	placeholder = "Add the card title here",
83	12x	width = "100%"
84		),
85	12x	shiny::textAreaInput(
86	12x	ns("comment"),
87	12x	"Comment",
88	12x	value = "",
89	12x	placeholder = "Add a comment here...",
90	12x	width = "100%"
91		),
92	12x	shiny::tags$script(
93	12x	shiny::HTML(
94	12x	sprintf("shinyjs.autoFocusModal('%s');", ns("label")), # See extendShinyJs.js
95	12x	sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("label"), ns("add_card_ok")) # See extendShinyJs.js
96		)
97		),
98	12x	footer = shiny::div(
99	12x	shiny::tags$button(
100	12x	type = "button",
101	12x	class = "btn btn-outline-secondary",
102	12x	`data-bs-dismiss` = "modal",
103	12x	NULL,
104	12x	"Dismiss"
105		),
106	12x	shiny::tags$button(
107	12x	id = ns("add_card_ok"),
108	12x	type = "button",
109	12x	class = "btn btn-primary action-button",
110	12x	NULL,
111	12x	"Add Card"
112		)
113		)
114		)
115		)
116		}
117
118	15x	shiny::observeEvent(input$add_report_card_button, {
119	12x	shiny::showModal(add_modal())
120		})
121
122		# the add card button is disabled when clicked to prevent multi-clicks
123		# please check the ui part for more information
124	15x	shiny::observeEvent(input$add_card_ok, {
125	12x	card_fun_args_nams <- names(formals(card_fun))
126	12x	has_card_arg <- "card" %in% card_fun_args_nams
127	12x	has_comment_arg <- "comment" %in% card_fun_args_nams
128	12x	has_label_arg <- "label" %in% card_fun_args_nams
129
130	12x	arg_list <- list()
131
132	12x	if (has_comment_arg) {
133	4x	arg_list <- c(arg_list, list(comment = input$comment))
134		}
135	12x	if (has_label_arg) {
136	!	arg_list <- c(arg_list, list(label = input$label))
137		}
138
139	12x	shinyjs::disable("add_card_ok")
140
141	12x	if (has_card_arg) {
142		# The default_card is defined here because formals() returns a pairedlist object
143		# of formal parameter names and their default values. The values are missing
144		# if not defined and the missing check does not work if supplied formals(card_fun)[[1]]
145	9x	default_card <- formals(card_fun)$card
146	9x	card <- `if`(
147	9x	missing(default_card),
148	9x	ReportCard$new(),
149	9x	eval(default_card, envir = environment(card_fun))
150		)
151	9x	arg_list <- c(arg_list, list(card = card))
152		}
153
154	12x	card <- try(do.call(card_fun, arg_list))
155
156	12x	if (inherits(card, "try-error")) {
157	3x	msg <- paste0(
158	3x	"The card could not be added to the report. ",
159	3x	"Have the outputs for the report been created yet? If not please try again when they ",
160	3x	"are ready. Otherwise contact your application developer"
161		)
162	3x	warning(msg)
163	3x	shiny::showNotification(
164	3x	msg,
165	3x	type = "error"
166		)
167	3x	shinyjs::enable("add_card_ok")
168		} else {
169	9x	checkmate::assert_multi_class(card, c("ReportCard", "teal_card"))
170	9x	if (inherits(card, "ReportCard")) {
171	1x	if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
172	1x	card$append_text("Comment", "header3")
173	1x	card$append_text(input$comment)
174		}
175
176	1x	if (!has_label_arg && length(input$label) == 1 && input$label != "") {
177	!	card$set_name(input$label)
178		}
179	8x	} else if (inherits(card, "teal_card")) {
180	8x	if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") {
181	1x	card <- c(card, "### Comment", input$comment)
182		}
183	8x	if (!has_label_arg && length(input$label) == 1 && input$label != "") {
184	!	metadata(card, "title") <- input$label
185		}
186		}
187
188	9x	reporter$append_cards(list(card))
189	9x	shiny::showNotification(sprintf("The card added successfully."), type = "message")
190	9x	shiny::removeModal()
191		}
192		})
193		})
194		}

1		#' @importFrom tools toHTML
2		NULL
3
4		#' @method toHTML default
5		#' @keywords internal
6		#' @export
7		toHTML.default <- function(x, ...) {
8	433x	.toHTML(x, ...)
9		}
10
11		#' @keywords internal
12		.toHTML <- function(x, ...) { # nolint: object_name.
13	433x	UseMethod(".toHTML", x)
14		}
15
16		#' @method .toHTML default
17		#' @keywords internal
18		.toHTML.default <- function(x, ...) {
19	220x	shiny::HTML(commonmark::markdown_html(x, extensions = TRUE))
20		}
21
22		#' @method .toHTML ReportCard
23		#' @keywords internal
24		.toHTML.ReportCard <- function(x, ...) {
25	!	shiny::tagList(lapply(x$get_content(), tools::toHTML))
26		}
27
28		#' @method .toHTML teal_card
29		#' @keywords internal
30		.toHTML.teal_card <- function(x, ...) {
31	!	shiny::tagList(lapply(x, tools::toHTML, ...))
32		}
33
34		#' @method .toHTML teal_report
35		#' @keywords internal
36		.toHTML.teal_report <- function(x, ...) {
37	!	tools::toHTML(teal_card(x), ...)
38		}
39
40		#' @method .toHTML rtables
41		#' @keywords internal
42		.toHTML.rtables <- function(x, ...) {
43	78x	shiny::tags$pre(tools::toHTML(to_flextable(x)))
44		}
45
46		#' @method .toHTML flextable
47		#' @keywords internal
48		.toHTML.flextable <- function(x, ...) {
49	78x	flextable::htmltools_value(x)
50		}
51
52		#' @method .toHTML condition
53		#' @keywords internal
54		.toHTML.condition <- function(x, ...) {
55	!	conditionMessage(x)
56		}
57
58		.plot2html <- function(x, ...) {
59	56x	on.exit(unlink(tmpfile))
60	56x	tmpfile <- tempfile(fileext = ".png")
61	56x	dims <- resolve_figure_dimensions(x)
62	56x	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
63	56x	print(x)
64	56x	grDevices::dev.off()
65	56x	shiny::tags$img(src = knitr::image_uri(tmpfile), style = "width: 100%; height: auto;")
66		}
67
68		#' @method .toHTML recordedplot
69		#' @keywords internal
70		.toHTML.recordedplot <- .plot2html
71
72		#' @method .toHTML trellis
73		#' @keywords internal
74		.toHTML.trellis <- .plot2html
75
76		#' @method .toHTML gg
77		#' @keywords internal
78		.toHTML.gg <- function(x, ...) {
79	!	on.exit(unlink(tmpfile))
80	!	dims <- resolve_figure_dimensions(x, convert_to_inches = TRUE, dpi = 100)
81	!	tmpfile <- tempfile(fileext = ".png")
82	!	ggplot2::ggsave(tmpfile, plot = x, width = dims$width, height = dims$height, dpi = 100)
83	!	shiny::tags$img(src = knitr::image_uri(tmpfile))
84		}
85
86		#' @method .toHTML grob
87		#' @keywords internal
88		.toHTML.grob <- function(x, ...) {
89	!	on.exit(unlink(tmpfile))
90	!	dims <- resolve_figure_dimensions(x)
91	!	tmpfile <- tempfile(fileext = ".png")
92	!	grDevices::png(filename = tmpfile, width = dims$width, height = dims$height)
93	!	grid::grid.newpage()
94	!	grid::grid.draw(x)
95	!	grDevices::dev.off()
96	!	shiny::tags$img(src = knitr::image_uri(tmpfile))
97		}
98
99		#' @method .toHTML code_chunk
100		#' @keywords internal
101		.toHTML.code_chunk <- function(x, ...) {
102	1x	shiny::tags$pre(
103	1x	shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang"))),
104	1x	.noWS = "inside"
105		)
106		}
107
108		#' @method .toHTML chunk_output
109		#' @keywords internal
110		.toHTML.chunk_output <- function(x, ...) {
111	!	new_x <- x[[1]]
112	!	mostattributes(new_x) <- c(attributes(unclass(x)), attributes(new_x))
113	!	tools::toHTML(new_x, ...)
114		}
115
116		#' @method .toHTML summary.lm
117		#' @keywords internal
118		.toHTML.summary.lm <- function(x, ...) {
119	!	shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n"))
120		}
121
122		#' @method .toHTML TableTree
123		#' @keywords internal
124		.toHTML.TableTree <- .toHTML.rtables
125
126		#' @method .toHTML ElementaryTable
127		#' @keywords internal
128		.toHTML.ElementaryTable <- .toHTML.rtables
129
130		#' @method .toHTML rlisting
131		#' @keywords internal
132		.toHTML.rlisting <- .toHTML.rtables
133
134		#' @method .toHTML data.frame
135		#' @keywords internal
136		.toHTML.data.frame <- .toHTML.rtables
137
138		#' @method .toHTML datatables
139		#' @keywords internal
140		.toHTML.datatables <- function(x, ...) {
141	!	x
142		}
143
144		#' @method .toHTML gtsummary
145		#' @keywords internal
146		.toHTML.gtsummary <- function(x, ...) {
147	!	tools::toHTML(gtsummary::as_flex_table(x))
148		}
149
150		#' @method .toHTML listing_df
151		#' @keywords internal
152		.toHTML.listing_df <- function(x, ...) {
153	!	tools::toHTML(flextable::as_flextable(x))
154		}

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

1		#' Panel group widget
2		#'
3		#'
4		#' @param title (`character`) title of panel
5		#' @param ... content of panel
6		#' @param collapsed (`logical`, optional)
7		#' whether to initially collapse panel
8		#' @param input_id (`character`, optional)
9		#' name of the panel item element. If supplied, this will register a shiny input variable that
10		#' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
11		#'
12		#' @return `shiny.tag`.
13		#'
14		#' @keywords internal
15		panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
16	1x	stopifnot(checkmate::test_character(title, len = 1) \|\| inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
17	1x	checkmate::assert_flag(collapsed)
18	1x	checkmate::assert_string(input_id, null.ok = TRUE)
19
20	1x	div_id <- paste0(input_id, "_div")
21	1x	panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))
22
23	1x	shiny::tags$div(.renderHook = function(res_tag) {
24	!	res_tag$children <- list(
25	!	shiny::tags$div(
26	!	class = "card",
27	!	style = "margin: 0.5rem 0;",
28	!	shiny::tags$div(
29	!	class = "card-header",
30	!	shiny::tags$div(
31	!	class = ifelse(collapsed, "collapsed", ""),
32	!	`data-bs-toggle` = "collapse", # bs5
33	!	href = paste0("#", panel_id),
34	!	`aria-expanded` = ifelse(collapsed, "false", "true"),
35	!	shiny::icon("angle-down", class = "dropdown-icon"),
36	!	shiny::tags$label(style = "display: inline;", title)
37		)
38		),
39	!	shiny::tags$div(
40	!	id = panel_id,
41	!	class = paste("collapse", ifelse(collapsed, "", "show")),
42	!	shiny::tags$div(class = "card-body", ...)
43		)
44		)
45		)
46
47	!	res_tag
48		})
49		}
50
51		#' Convert content into a `flextable`
52		#'
53		#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
54		#'
55		#' Function merges cells with `colspan` > 1,
56		#' aligns columns to the center and row names to the left,
57		#' indents the row names by 10 times indentation.
58		#'
59		#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
60		#'
61		#' @return `flextable`.
62		#'
63		#' @keywords internal
64		to_flextable <- function(content) {
65	86x	if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
66	42x	ft <- rtables.officer::tt_to_flextable(content)
67	44x	} else if (inherits(content, "listing_df")) {
68	1x	mf <- rlistings::matrix_form(content)
69	1x	nr_header <- attr(mf, "nrow_header")
70	1x	df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
71	1x	header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
72
73	1x	ft <- rtables::df_to_tt(df)
74	1x	if (length(mf$main_title) != 0) {
75	!	rtables::main_title(ft) <- mf$main_title
76		}
77	1x	rtables::subtitles(ft) <- mf$subtitles
78	1x	rtables::main_footer(ft) <- mf$main_footer
79	1x	rtables::prov_footer(ft) <- mf$prov_footer
80	1x	rtables::header_section_div(ft) <- mf$header_section_div
81	1x	ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1))
82	43x	} else if (inherits(content, "data.frame")) {
83	42x	ft <- if (nrow(content) == 0) {
84	!	flextable::flextable(content)
85		} else {
86	42x	rtables.officer::tt_to_flextable(
87	42x	rtables::df_to_tt(content)
88		)
89		}
90		} else {
91	1x	stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
92		}
93
94	85x	ft
95		}
96
97		#' Get the merge index for a single span.
98		#' This function retrieves the merge index for a single span,
99		#' which is used in merging cells.
100		#' @noRd
101		#' @keywords internal
102		get_merge_index_single <- function(span) {
103	!	ret <- list()
104	!	j <- 1
105	!	while (j < length(span)) {
106	!	if (span[j] != 1) {
107	!	ret <- c(ret, list(seq(j, j + span[j] - 1)))
108		}
109	!	j <- j + span[j]
110		}
111	!	ret
112		}
113
114		#' Divide text block into smaller blocks
115		#'
116		#' Split a text block into smaller blocks with a specified number of lines.
117		#'
118		#' A single character string containing a text block of multiple lines (separated by `\n`)
119		#' is split into multiple strings with n or less lines each.
120		#'
121		#' @param x (`character`) string containing the input block of text
122		#' @param n (`integer`) number of lines per block
123		#'
124		#' @return
125		#' List of character strings with up to `n` lines in each element.
126		#'
127		#' @keywords internal
128		split_text_block <- function(x, n) {
129	2x	checkmate::assert_string(x)
130	2x	checkmate::assert_integerish(n, lower = 1L, len = 1L)
131
132	2x	lines <- strsplit(x, "\n")[[1]]
133
134	2x	if (length(lines) <= n) {
135	1x	return(list(x))
136		}
137
138	1x	nblocks <- ceiling(length(lines) / n)
139	1x	ind <- rep(1:nblocks, each = n)[seq_along(lines)]
140	1x	unname(lapply(split(lines, ind), paste, collapse = "\n"))
141		}
142
143		#' Retrieve text details for global_knitr options
144		#' This function returns a character string describing the default settings for the global_knitr options.
145		#' @noRd
146		#' @keywords internal
147		global_knitr_details <- function() {
148	!	paste0(
149	!	c(
150	!	" To access the default values for the `global_knitr` parameter,",
151	!	" use `getOption('teal.reporter.global_knitr')`. These defaults include:",
152	!	" - `echo = TRUE`",
153	!	" - `tidy.opts = list(width.cutoff = 60)`",
154	!	" - `tidy = TRUE` if `formatR` package is installed, `FALSE` otherwise"
155		),
156	!	collapse = "\n"
157		)
158		}
159
160		#' @export
161		#' @keywords internal
162		format.code_chunk <- function(x, ...) {
163	90x	language <- attr(x, "lang", exact = TRUE)
164	90x	params <- attr(x, "params", exact = TRUE)
165	90x	if (language %in% names(knitr::knit_engines$get())) {
166	89x	sprintf(
167	89x	"```{%s}\n%s\n```",
168	89x	toString(c(language, paste(names(params), params, sep = "="))),
169	89x	NextMethod()
170		)
171		} else {
172	1x	sprintf("```%s\n%s\n```", language, NextMethod())
173		}
174		}
175
176		#' @keywords internal
177		.outline_button <- function(id, label, icon = NULL, class = "primary") {
178	10x	shiny::tagList(
179	10x	shinyjs::useShinyjs(),
180	10x	.custom_css_dependency(),
181	10x	htmltools::htmlDependency(
182	10x	name = "teal-reporter-busy-disable",
183	10x	version = utils::packageVersion("teal.reporter"),
184	10x	package = "teal.reporter",
185	10x	src = "js",
186	10x	script = "busy-disable.js"
187		),
188	10x	shiny::tags$button(
189	10x	id = id,
190	10x	class = sprintf("teal-reporter action-button teal-reporter-busy-disable outline-button %s", class),
191	10x	role = "button",
192	10x	style = "text-decoration: none;",
193	10x	if (!is.null(icon)) {
194	10x	margin_style <- ifelse(is.null(label), "margin: 0 10px 0 10px;", "")
195	10x	shiny::tags$span(
196	10x	style = margin_style,
197	10x	bsicons::bs_icon(icon, class = sprintf("text-%s", class))
198		)
199		},
200	10x	label
201		)
202		)
203		}
204
205		#' @keywords internal
206		.custom_css_dependency <- function() {
207	30x	htmltools::htmlDependency(
208	30x	name = "teal-reporter",
209	30x	version = utils::packageVersion("teal.reporter"),
210	30x	package = "teal.reporter",
211	30x	src = "css",
212	30x	stylesheet = "custom.css"
213		)
214		}
215
216		#' @noRd
217		dummy <- function() {
218	!	R6::R6Class # Used to trick R CMD check for avoiding NOTE about R6
219	!	jsonlite::fromJSON # Used to trick R CMD check for not detecting jsonlite usage
220		}

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	!	.outline_button(
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		)
31		)
32		}
33
34		#' @rdname reporter_previewer
35		#' @export
36		preview_report_button_srv <- function(id, reporter) {
37	!	checkmate::assert_class(reporter, "Reporter")
38
39	!	shiny::moduleServer(id, function(input, output, session) {
40	!	shiny::setBookmarkExclude(c("preview_button"))
41
42	!	shiny::observeEvent(reporter$get_cards(), {
43	!	shinyjs::toggleClass(
44	!	id = "preview_button", condition = length(reporter$get_cards()) == 0, class = "disabled"
45		)
46		})
47
48	!	output$preview_button_counter <- shiny::renderUI({
49	!	shiny::tags$span(
50	!	class = "position-absolute badge rounded-pill bg-primary",
51	!	length(reporter$get_cards())
52		)
53		})
54
55	!	preview_modal <- function(cached_content) {
56	!	shiny::tags$div(
57	!	class = "teal-reporter reporter-previewer-modal",
58	!	.custom_css_dependency(),
59	!	shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
60	!	shiny::modalDialog(
61	!	easyClose = TRUE,
62	!	size = "xl",
63	!	title = "Report Preview",
64	!	reporter_previewer_content_ui(session$ns("preview_content")),
65	!	footer = shiny::tagList(
66	!	shiny::tags$button(
67	!	type = "button",
68	!	class = "btn btn-outline-secondary",
69	!	"data-bs-dismiss" = "modal",
70	!	"Dismiss"
71		)
72		)
73		)
74		)
75		}
76
77	!	reporter_previewer_content_srv(id = "preview_content", reporter = reporter)
78
79	!	srv_list <- shiny::reactiveValues()
80	!	shiny::observeEvent(
81	!	list(input$preview_button, reporter$open_previewer()),
82	!	ignoreInit = TRUE,
83		{
84	!	shiny::req(input$preview_button != 0 \|\| !is.null(reporter$open_previewer())) # prevent unnecessary triggering.
85	!	shiny::showModal(preview_modal())
86
87	!	panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards"))
88	!	lapply(
89	!	names(reporter$get_cards()),
90	!	function(card_id) {
91		# Only show loading placeholder for cards that are being initialized for the first time
92	!	first_run <- is.null(srv_list[[card_id]])
93
94	!	bslib::accordion_panel_insert(
95	!	id = panel_ns(NULL),
96	!	previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id, show_loading = first_run)
97		)
98
99	!	if (first_run) { # Only initialize srv once per card_id
100	!	previewer_card_srv(
101	!	id = panel_ns(card_id),
102	!	card_r = shiny::reactive(reporter$get_cards()[[card_id]]),
103	!	card_id = card_id,
104	!	reporter = reporter
105		)
106	!	srv_list[[card_id]] <- card_id
107		}
108		}
109		)
110		}
111		)
112		})
113		}

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		#' @examples
19		#' # Create a new empty card
20		#' report <- teal_card()
21		#'
22		#' # Create a card with content
23		#' report <- teal_card("## Headline", "Some text", summary(iris))
24		#'
25		#' # Extract card from a teal_report
26		#' tr <- teal_report(teal_card = teal_card("## Title"))
27		#' doc <- teal_card(tr)
28		#'
29		#' # Add elements to the report
30		#' report <- c(report, list("## Table"), list(summary(mtcars)))
31		#'
32		#' # Subset the report to keep only the first two elements
33		#' report <- report[1:2]
34		#'
35		#' # Append new elements after the first element
36		#' report <- append(report, c(list("## Table 2"), list(summary(mtcars))), after = 1)
37		#'
38		#' # Verify that the object remains a teal_card
39		#' class(report)
40		#'
41		#' @aliases teal_card
42		#' @name teal_card
43		#'
44		#' @export
45		teal_card <- function(...) {
46	788x	UseMethod("teal_card")
47		}
48
49		#' @export
50		#' @keywords internal
51		teal_card.default <- function(...) {
52	612x	x <- lapply(list(...), .convert_teal_card_input)
53
54	612x	if (length(x) > 0) {
55	362x	names(x) <- vapply(
56	362x	sample.int(.Machine$integer.max, size = length(x)),
57	362x	function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8),
58	362x	character(1)
59		)
60		}
61	612x	structure(x, class = "teal_card")
62		}
63
64		#' @export
65		#' @keywords internal
66		teal_card.teal_card <- function(...) {
67	89x	dots <- list(...)
68	89x	c(dots[[1]], dots[-1])
69		}
70
71		#' @export
72		#' @keywords internal
73		teal_card.teal_report <- function(...) {
74	84x	dots <- list(...)
75	84x	dots[[1]] <- dots[[1]]@teal_card
76	84x	do.call(teal_card, args = dots)
77		}
78
79		#' @export
80		#' @keywords internal
81		teal_card.qenv <- function(...) {
82	3x	dots <- list(...)
83	3x	dots[[1]] <- .code_to_card(dots[[1]]@code)
84	3x	do.call(teal_card, args = dots)
85		}
86
87		#' @rdname teal_card
88		#' @param value (`teal_card`) object to set in the `teal_report`.
89		#' @export
90		`teal_card<-` <- function(x, value) {
91	40x	x <- methods::as(x, "teal_report")
92	40x	checkmate::assert_class(x, "teal_report")
93	40x	x@teal_card <- as.teal_card(value)
94	40x	x
95		}
96
97		#' @export
98		`[[<-.teal_card` <- function(x, index, value) {
99	6x	new_card <- as.teal_card(value)
100	6x	value <- new_card[[1]]
101	6x	new_x <- NextMethod()
102	6x	if (checkmate::test_integerish(index)) {
103	2x	names(new_x)[[index]] <- names(new_card)[[1]]
104		}
105	6x	new_x
106		}
107
108		#' Create or coerce to a teal_card
109		#'
110		#' This function ensures that input is converted to a teal_card object.
111		#' It accepts various input types and converts them appropriately.
112		#'
113		#' @param x Object to convert to teal_card
114		#' @return A teal_card object
115		#' @rdname teal_card
116		#' @export
117		as.teal_card <- function(x) { # nolint: object_name.
118	829x	if (inherits(x, "teal_card")) {
119	521x	if (length(x) && !checkmate::test_names(names(x), type = "unique")) { # Fix names if not unique or missing
120	59x	names(x) <- substr(
121	59x	vapply(seq_len(length(x)), function(ix) rlang::hash(list(ix, Sys.time(), x[[ix]])), character(1L)),
122	59x	1,
123	59x	8
124		)
125		}
126	521x	return(x)
127		}
128	308x	if (identical(class(x), "list")) {
129	95x	return(do.call(teal_card, unname(x)))
130		}
131	213x	teal_card(x)
132		}
133
134		#' @rdname teal_card
135		#' @export
136		c.teal_card <- function(...) {
137	318x	dots <- list(...)
138	318x	structure(
139	318x	Reduce(
140	318x	f = function(u, v) {
141	717x	v <- as.teal_card(v)
142	717x	if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u
143	3x	if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v`
144	2x	v
145		} else {
146	1x	warning(
147	1x	"Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n",
148	1x	"Restoring original content and adding only new items to the end of the card."
149		)
150	1x	utils::modifyList(u, v)
151		}
152		} else {
153	714x	attrs <- utils::modifyList(attributes(u) %\|\|% list(), attributes(v))
154	714x	attrs$names <- union(names(u), names(v))
155	714x	attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %\|\|% list(), metadata(v))
156	714x	result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass
157	714x	attributes(result) <- attrs
158	714x	result
159		}
160		},
161	318x	x = dots,
162	318x	init = list()
163		),
164	318x	class = "teal_card"
165		)
166		}
167
168		#' @param i index specifying elements to extract or replace
169		#' @rdname teal_card
170		#' @export
171		`[.teal_card` <- function(x, i) {
172	5x	out <- NextMethod()
173	5x	class(out) <- "teal_card"
174	5x	attr(out, "metadata") <- metadata(x)
175	5x	out
176		}
177
178		#' Access metadata from a `teal_card` or `ReportCard`
179		#'
180		#' This function retrieves metadata from a `teal_card` or `ReportCard` object.
181		#' When `which` is `NULL`, it returns all metadata fields as a list.
182		#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata.
183		#' @param which (`character` or `NULL`) The name of the metadata field to extract.
184		#' @return A list of metadata fields or a specific field if `which` is provided.
185		#' @export
186		metadata <- function(object, which = NULL) {
187	1158x	checkmate::assert_string(which, null.ok = TRUE)
188	1158x	UseMethod("metadata", object)
189		}
190
191		#' @rdname metadata
192		#' @export
193		metadata.teal_card <- function(object, which = NULL) {
194	1154x	metadata <- attr(object, which = "metadata", exact = TRUE)
195	1154x	result <- metadata %\|\|% list()
196	1154x	if (is.null(which)) {
197	1069x	return(result)
198		}
199	85x	result[[which]]
200		}
201
202		#' @rdname metadata
203		#' @export
204		metadata.ReportCard <- function(object, which = NULL) {
205	4x	result <- list(title = object$get_name())
206	4x	if (is.null(which)) {
207	1x	return(result)
208		}
209	3x	result[[which]]
210		}
211
212		#' Set metadata for a `teal_card` or `ReportCard`
213		#'
214		#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object.
215		#' It can be used to add new metadata or update existing fields.
216		#' @param object (`teal_card` or `ReportCard`) The object to modify.
217		#' @param which (`character`) The name of the metadata field to set.
218		#' @param value The value to assign to the specified metadata field.
219		#' @return The modified object with updated metadata.
220		#' @export
221		`metadata<-` <- function(object, which = NULL, value) {
222	276x	checkmate::assert_string(which, null.ok = TRUE)
223	276x	UseMethod("metadata<-", object)
224		}
225
226		#' @rdname metadata-set
227		#' @export
228		`metadata<-.teal_card` <- function(object, which = NULL, value) {
229	259x	if (missing(which)) {
230	191x	checkmate::assert_list(value, names = "named")
231	191x	attr(object, which = "metadata") <- value
232	191x	return(object)
233		}
234	68x	attr(object, which = "metadata") <- utils::modifyList(
235	68x	metadata(object), structure(list(value), names = which)
236		)
237	68x	object
238		}
239
240		#' @rdname metadata-set
241		#' @details
242		#' The `ReportCard` class only supports the `title` field in metadata.
243		#' @export
244		`metadata<-.ReportCard` <- function(object, which, value) {
245	17x	if (missing(which)) {
246	3x	if (!is.null(value[["title"]])) {
247	2x	object$set_name(value[["title"]])
248		}
249	3x	if (length(value) >= 2 \|\| length(value) == 1 && is.null(value[["title"]])) {
250	2x	warning("ReportCard class only supports `title` in metadata.")
251		}
252	3x	return(object)
253		}
254
255	14x	if (isFALSE(identical(which, "title"))) {
256	1x	warning("ReportCard class only supports `title` in metadata.")
257		} else {
258	13x	object$set_name(value)
259		}
260	14x	object
261		}
262
263		#' Generate an R Markdown code chunk
264		#'
265		#' This function creates a `code_chunk` object, which represents an R Markdown
266		#' code chunk. It stores the R code and any specified chunk options (e.g., `echo`, `eval`).
267		#' These objects are typically processed later to generate the final R Markdown text.
268		#'
269		#' @param code A character string containing the R code.
270		#' @param ... Additional named parameters to be included as chunk options (e.g., `echo = TRUE`).
271		#' Check [`knitr` options/](https://yihui.org/knitr/options/) for more details.
272		#' @param lang (`character(1)`) See [`knitr::knit_engines`].
273		#'
274		#' @return An object of class `code_chunk`.
275		#' @examples
276		#' my_chunk <- code_chunk("x <- 1:10", echo = TRUE, message = FALSE)
277		#' class(my_chunk)
278		#' attributes(my_chunk)$param
279		#' @export
280		code_chunk <- function(code, ..., lang = "R") {
281	122x	checkmate::assert_character(code)
282	122x	params <- list(...)
283	122x	checkmate::assert_list(params, names = "named", .var.name = "...")
284	122x	structure(
285	122x	paste(code, collapse = "\n"),
286	122x	params = params,
287	122x	lang = lang,
288	122x	class = "code_chunk"
289		)
290		}
291
292		#' Builds `teal_card` from code and outputs in `qenv` object
293		#'
294		#' Builds a `teal_card` from the code and outputs of a `teal_data`
295		#' object, preserving the order of code execution and output display.
296		#'
297		#' @inheritParams eval_code-teal_report
298		#' @param x (`list`) object from `qenv@code`.
299		#' @return A `teal_card` built from the code and outputs in a `qenv` object.
300		#' @keywords internal
301		.code_to_card <- function(x, code_block_opts = list()) {
302	26x	elems <- Reduce(
303	26x	function(items, code_elem) {
304	61x	this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts))
305	61x	this_outs <- Filter( # intentionally remove warnings,messages from the generated report
306	61x	function(x) !inherits(x[[1]], "condition"),
307	61x	lapply(
308	61x	attr(code_elem, "outputs"),
309	61x	function(x) structure(list(x), class = c("chunk_output"))
310		)
311		)
312	61x	c(items, list(this_chunk), this_outs)
313		},
314	26x	init = list(),
315	26x	x = x
316		)
317	26x	do.call(teal_card, args = elems)
318		}
319
320		#' Internal helper for `teal_card`` input conversion
321		#'
322		#' Converts input values to a format compatible with `teal_card`.
323		#' This function is used internally to handle common inputs, such as `ggplot` objects,
324		#' ensuring they are appropriately converted to an "evaluable output" blocks that can
325		#' be saved to `RDS` file efficiently.
326		#'
327		#' This function performs the following conversions:
328		#' - `ggplot` objects are converted to `recordedplot` objects.
329		#'
330		#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`,
331		#' no conversion is applied.
332		#'
333		#' @param x (`object`) An object to be converted.
334		#'
335		#' @return The processed object, possibly converted or left unchanged.
336		#'
337		#' @keywords internal
338		.convert_teal_card_input <- function(x) {
339	621x	if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) {
340	16x	return(x)
341		}
342	605x	if (inherits(x, "chunk_output")) {
343	26x	res <- structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output"))
344	26x	attributes(res) <- attributes(x) # keep same attributes
345	26x	res
346	579x	} else if (inherits(x, "ggplot")) {
347	52x	.ggplot_to_recordedplot(x)
348		} else {
349	527x	x
350		}
351		}
352
353		#' @noRd
354		.ggplot_to_recordedplot <- function(x) {
355	52x	checkmate::assert_class(x, "ggplot")
356	52x	grDevices::pdf(file = NULL)
357	52x	grDevices::dev.control(displaylist = "enable")
358	52x	dev <- grDevices::dev.cur()
359	52x	on.exit(grDevices::dev.off(dev))
360	52x	print(x)
361	52x	grDevices::recordPlot()
362		}
363
364		#' Determine default dimensions for report figures
365		#'
366		#' @param x An object, typically a `recordedplot` or `ggplot`, that has an
367		#' optional attributes `dev.width` and `dev.height` that override the default
368		#' dims set as options `teal.reporter.dev.fig.width` and
369		#' `teal.reporter.dev.fig.height`.
370		#' @return List with `width` and `height` elements.
371		#' @keywords internal
372		resolve_figure_dimensions <- function(x, convert_to_inches = FALSE, dpi = 96) {
373	70x	checkmate::assert_flag(convert_to_inches)
374	70x	width <- attr(x, "dev.width") %\|\|% getOption("teal.reporter.dev.fig.width", 800)
375	70x	height <- attr(x, "dev.height") %\|\|% getOption("teal.reporter.dev.fig.height", 600)
376	70x	if (width < 150 \|\| height < 150) {
377	!	warning("Figure dimensions too small, setting to minimum of 150x150 pixels.")
378	!	width <- max(width, 150)
379	!	height <- max(height, 150)
380		}
381
382	70x	if (convert_to_inches) {
383	14x	width <- width / dpi
384	14x	height <- height / dpi
385		}
386	70x	list(width = width, height = height)
387		}

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

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

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

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

1		#' 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	1x	ns <- shiny::NS(id)
40	1x	shiny::tagList(
41	1x	.custom_css_dependency(),
42	1x	shiny::tags$div(
43	1x	shiny::tags$label(class = "text-primary", shiny::tags$strong("Reporter")),
44	1x	shiny::tags$div(
45	1x	class = "simple_reporter_container",
46	1x	add_card_button_ui(ns("add_report_card_simple")),
47	1x	download_report_button_ui(ns("download_button_simple")),
48	1x	report_load_ui(ns("archive_load_simple")),
49	1x	reset_report_button_ui(ns("reset_button_simple"))
50		),
51	1x	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	5x	shiny::moduleServer(
66	5x	id,
67	5x	function(input, output, session) {
68	5x	add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
69	5x	download_report_button_srv(
70	5x	"download_button_simple",
71	5x	reporter = reporter,
72	5x	global_knitr = global_knitr,
73	5x	rmd_output = rmd_output,
74	5x	rmd_yaml_args = rmd_yaml_args
75		)
76	5x	report_load_srv("archive_load_simple", reporter = reporter)
77	5x	reset_report_button_srv("reset_button_simple", reporter = reporter)
78		}
79		)
80		}

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

1		#' 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	2x	checkmate::assert_string(label, null.ok = TRUE)
21	2x	.outline_button(
22	2x	shiny::NS(id, "reset_reporter"),
23	2x	label = label,
24	2x	icon = "x-lg",
25	2x	class = "danger"
26		)
27		}
28
29		#' @rdname reset_report_button
30		#' @export
31		reset_report_button_srv <- function(id, reporter) {
32	12x	checkmate::assert_class(reporter, "Reporter")
33
34	12x	shiny::moduleServer(id, function(input, output, session) {
35	12x	shiny::setBookmarkExclude(c("reset_reporter"))
36
37	12x	shiny::observeEvent(reporter$get_cards(), {
38	7x	shinyjs::toggleClass(
39	7x	id = "reset_reporter", condition = length(reporter$get_cards()) == 0, class = "disabled"
40		)
41		})
42
43	12x	shiny::observeEvent(input$reset_reporter, {
44	2x	shiny::tags$div(
45	2x	class = "teal-reporter reporter-modal",
46	2x	.custom_css_dependency(),
47	2x	shiny::showModal(
48	2x	shiny::modalDialog(
49	2x	easyClose = TRUE,
50	2x	shiny::tags$h3("Reset the Report"),
51	2x	shiny::tags$hr(),
52	2x	shiny::tags$strong(
53	2x	shiny::tags$p(
54	2x	"Are you sure you want to reset the report? (This will remove ALL previously added cards)."
55		)
56		),
57	2x	footer = shiny::tagList(
58	2x	shiny::tags$button(
59	2x	type = "button",
60	2x	class = "btn btn-outline-secondary",
61	2x	`data-bs-dismiss` = "modal",
62	2x	NULL,
63	2x	"Dismiss"
64		),
65	2x	shiny::actionButton(session$ns("reset_reporter_ok"), "Reset", class = "btn btn-primary")
66		)
67		)
68		)
69		)
70		})
71
72	12x	shiny::observeEvent(reporter$get_cards(), {
73	7x	if (length(reporter$get_cards())) {
74	5x	shinyjs::enable("reset_reporter")
75		} else {
76	2x	shinyjs::disable("reset_reporter")
77		}
78		})
79
80	12x	shiny::observeEvent(input$reset_reporter_ok, {
81	2x	reporter$reset()
82	2x	shiny::removeModal()
83		})
84		})
85		}

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	1x	ns <- shiny::NS(id)
39	1x	lifecycle::deprecate_soft(
40	1x	when = "0.5.0",
41	1x	what = "reporter_previewer_ui()",
42	1x	details = paste(
43	1x	"Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n",
44	1x	"Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,",
45	1x	"and `preview_report_button_ui()` instead."
46		)
47		)
48	1x	bslib::page_fluid(
49	1x	shiny::tagList(
50	1x	shinyjs::useShinyjs(),
51	1x	shiny::singleton(
52	1x	shiny::tags$head(
53	1x	shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")),
54	1x	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	1x	shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")),
60	1x	shiny::tags$div(
61	1x	class = "well",
62	1x	style = "display: inline-flex; flex-direction: row; gap: 10px;",
63	1x	shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")),
64	1x	shiny::tags$span(
65	1x	id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report")
66		),
67	1x	shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report"))
68		),
69	1x	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.5.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		}

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

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	20x	new_object <- methods::callNextMethod(object = object, code = code, ...)
26	20x	if (inherits(new_object, "error")) {
27	!	return(new_object)
28		}
29	20x	new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts)
30
31	20x	teal_card(new_object) <- c(teal_card(new_object), new_blocks)
32	20x	new_object
33		}
34		)

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	!	shiny::moduleServer(id, function(input, output, session) {
20	!	blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot
21	!	blocks_queue_rv <- shiny::reactiveVal()
22
23	!	shiny::observeEvent(card_r(), { # Reset on card change
24	!	for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL
25	!	blocks_queue_rv(NULL) # Force retriggering
26	!	blocks_queue_rv(names(card_r()))
27		})
28
29	!	shiny::observeEvent(blocks_queue_rv(), {
30	!	lapply(blocks_queue_rv(), function(block_name) {
31	!	new_block_id <- shiny::NS("blocks", block_name)
32	!	block_content <- card_r()[[block_name]] %\|\|% "" # Initialize as empty string
33	!	blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content)
34
35	!	if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered
36	!	new_block_ui <- ui_editor_block(
37	!	session$ns(new_block_id),
38	!	value = block_content,
39	!	cached_html = NULL
40		)
41	!	shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui)
42		}
43		})
44		})
45
46	!	shiny::observeEvent(input$add_block, {
47	!	new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1)
48	!	blocks_queue_rv(new_name)
49		})
50
51	!	blocks_inputs_rvs
52		})
53		}

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

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

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	38x	args <- list(...)
50	!	if (is.null(teal_card)) teal_card <- teal_card()
51	38x	checkmate::assert_class(teal_card, "teal_card")
52	38x	checkmate::assert_list(args, names = "named")
53	38x	methods::callNextMethod(
54	38x	.Object,
55	38x	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		#' teal_report(x1 = iris, x2 = mtcars)
78		teal_report <- function(...,
79		teal_card = NULL,
80		code = character(0),
81		join_keys = teal.data::join_keys()) {
82	32x	if (is.null(teal_card)) teal_card <- teal_card()
83	38x	methods::new(
84	38x	"teal_report",
85	38x	.xData = list2env(list(...)),
86	38x	teal_card = teal_card,
87	38x	join_keys = join_keys,
88	38x	code = code
89		)
90		}
91
92		#' Internal function to convert `qenv` or `teal_data` to `teal_report`
93		#' @noRd
94		coerce.teal_report <- function(from, to) { # nolint: object_name.
95	3x	if (inherits(from, "teal_report")) {
96	!	return(from)
97		}
98	3x	new_x <- teal_report()
99	3x	for (slot_name in methods::slotNames(from)) {
100	12x	methods::slot(new_x, slot_name) <- methods::slot(from, slot_name)
101		}
102	3x	teal_card(new_x) <- .code_to_card(from@code)
103	3x	new_x
104		}
105
106		methods::setAs("qenv", "teal_report", coerce.teal_report)
107		methods::setAs("teal_data", "teal_report", coerce.teal_report)
108
109		#' @rdname teal_report
110		#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`.
111		#' @export
112		as.teal_report <- function(x) { # nolint: object_name.
113	2x	checkmate::assert_class(x, "qenv")
114	2x	methods::as(x, "teal_report")
115		}

1		#' @rdname srv_editor_block
2		#' @export
3		ui_editor_block <- function(id, value, cached_html) {
4	!	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		#' @param id (`character(1)`) A unique identifier for the module.
40		#' @param value The content of the block to be edited. It can be a character string or other types.
41		#' @param cached_html (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI.
42		#' @export
43		srv_editor_block <- function(id, value) {
44	!	UseMethod("srv_editor_block", value)
45		}
46
47		#' @export
48		ui_editor_block.default <- function(id, value, cached_html) {
49	!	.ui_editor_block(id, value, cached_html)
50		}
51
52		#' @export
53		srv_editor_block.default <- function(id, value) {
54	!	.srv_editor_block(id, value)
55		}
56
57		#' @keywords internal
58		.ui_editor_block <- function(id, value, cached_html) {
59	!	UseMethod(".ui_editor_block", value)
60		}
61
62		#' @keywords internal
63		.srv_editor_block <- function(id, value) {
64	!	UseMethod(".srv_editor_block", value)
65		}
66
67		#' @method .ui_editor_block default
68		.ui_editor_block.default <- function(id, value, cached_html) {
69	!	shiny::tags$div(
70	!	shiny::tags$h6(
71	!	shiny::tags$span(
72	!	class = "fa-stack small text-muted",
73		# style = "width: 2em;", # necessary to avoid extra space after icon
74	!	shiny::icon("pencil", class = "fa-stack-1x"),
75	!	shiny::icon("ban", class = "fa-stack-2x fa-inverse text-black-50")
76		),
77	!	"Non-editable block"
78		),
79	!	if (is.null(cached_html)) {
80	!	tools::toHTML(value)
81		} else {
82	!	cached_html
83		}
84		)
85		}
86
87		#' @method .srv_editor_block default
88		.srv_editor_block.default <- function(id, value) {
89	!	shiny::moduleServer(id, function(input, output, session) NULL) # No input being changed, skipping update
90		}
91
92		#' @method .ui_editor_block character
93		.ui_editor_block.character <- function(id, value, cached_html) {
94	!	ns <- shiny::NS(id)
95	!	shiny::tagList(
96	!	shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"),
97	!	shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%")
98		)
99		}
100
101		#' @method .srv_editor_block character
102		.srv_editor_block.character <- function(id, value) {
103	!	shiny::moduleServer(id, function(input, output, session) shiny::reactive(input$content))
104		}

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	!	shiny::moduleServer(id, function(input, output, session) {
32	!	output$title <- shiny::renderUI({
33	!	title <- metadata(shiny::req(card_r()), "title")
34	!	if (is.null(title) \|\| isFALSE(nzchar(title))) {
35	!	title <- shiny::tags$span("(Empty title)", class = "text-muted")
36		}
37	!	title
38		})
39	!	output$card_content <- shiny::renderUI({
40	!	result <- reporter$get_cached_html(card_id)
41	!	shiny::removeUI(sprintf("#%s", session$ns(paste0("loading_placeholder_", card_id))))
42	!	result
43		})
44
45	!	srv_previewer_card_actions("actions", card_r, card_id, reporter)
46		})
47		}

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