teal.reporter coverage - 77.86%

Files
Source

#' 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 `card` parameter allows for specifying a custom or default `ReportCard` instance.
#' - Use the `comment` parameter to add a comment to the card via `card$append_text()` - if `card_fun` does not
#' have the `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the
#' card.
#' - The `label` parameter enables customization of the card's name and its content through `card$append_text()`-
#' if `card_fun` does not have the `label` parameter, then card name will be set to the name passed in
#' `Add Card UI` module, but no text will be added to the content of the `card`.
#'
#' This module supports using a subclass of [`ReportCard`] for added flexibility.
#' A subclass instance should be passed as the default value of
#' the `card` argument in the `card_fun` function.
#' See below:
#' ```{r}
#' CustomReportCard <- R6::R6Class(
#'   classname = "CustomReportCard",
#'   inherit = teal.reporter::ReportCard
#' )
#'
#' custom_function <- function(card = CustomReportCard$new()) {
#'   card
#' }
#' ```
#' @name add_card_button
#'
#' @param id (`character(1)`) this `shiny` module's id.
#' @param reporter (`Reporter`) instance.
#' @param 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(
                "
                $('#shiny-modal').on('shown.bs.modal', () => {
                  $('#%s').focus()
                })
                ",
                ns("label")
              )
            )
          ),
          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))
      }

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

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

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

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

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

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

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

    shiny::observeEvent(reporter$get_reactive_add_card(), {
      shinyjs::toggleClass(
        id = "download_button", condition = reporter$get_reactive_add_card() == 0, class = "disabled"
      )
    })

    output$download_data <- shiny::downloadHandler(
      filename = function() {
        paste0(
          "report_",
          if (reporter$get_id() == "") NULL else paste0(reporter$get_id(), "_"),
          format(Sys.time(), "%y%m%d%H%M%S"),
          ".zip"
        )
      },
      content = function(file) {
        shiny::showNotification("Rendering and Downloading the document.")
        shinybusy::block(id = ns("download_data"), text = "", type = "dots")
        input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
        names(input_list) <- names(rmd_yaml_args)
        if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
        report_render_and_compress(reporter, input_list, global_knitr, file)
        shinybusy::unblock(id = ns("download_data"))
      },
      contentType = "application/zip"
    )
  })
}

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

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

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

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

  output_dir <- renderer$get_output_dir()

  tryCatch(
    archiver_dir <- reporter$to_jsondir(output_dir),
    warning = function(cond) {
      print(cond)
      shiny::showNotification(
        ui = "Archive document warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      print(cond)
      shiny::showNotification(
        ui = "Archive document error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

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

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

  rm(renderer)
  invisible(file)
}

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

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

#' @title `ReportCard`: An `R6` class for building report elements
#' @docType class
#'
#' @description
#'
#' 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.
#'
#' For more information about the various blocks, refer to the vignette:
#' `vignette("teal-reporter-blocks-overview", "teal.reporter")`.
#'
#' @export
#'
ReportCard <- R6::R6Class( # nolint: object_name_linter.
  classname = "ReportCard",
  public = list(
    #' @description Initialize a `ReportCard` object.
    #'
    #' @return Object of class `ReportCard`, invisibly.
    #' @examples
    #' card <- ReportCard$new()
    #'
    initialize = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Appends a table to this `ReportCard`.
    #'
    #' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
    #' that can be coerced into a table.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_table(iris)
    #'
    append_table = function(table) {
      self$append_content(TableBlock$new(table))
      invisible(self)
    },
    #' @description Appends a 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(HTMLBlock$new(content))
      invisible(self)
    },
    #' @description Appends a plot to this `ReportCard`.
    #'
    #' @param plot (`ggplot` or `grob` or `trellis`) plot object.
    #' @param dim (`numeric(2)`) width and height in pixels.
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    append_plot = function(plot, dim = NULL) {
      pb <- PictureBlock$new()
      if (!is.null(dim) && length(dim) == 2) {
        pb$set_dim(dim)
      }
      pb$set_content(plot)
      self$append_content(pb)
      invisible(self)
    },
    #' @description Appends a text paragraph to this `ReportCard`.
    #'
    #' @param text (`character`) The text content to add.
    #' @param style (`character(1)`) the style of the paragraph. One of: `r TextBlock$new()$get_available_styles()`.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_text("A paragraph of default text")
    #'
    append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
      self$append_content(TextBlock$new(text, style))
      invisible(self)
    },
    #' @description Appends an `R` code chunk to `ReportCard`.
    #'
    #' @param text (`character`) The `R` code to include.
    #' @param ... Additional  `rmarkdown` parameters for formatting the `R` code chunk.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
    #'
    append_rcode = function(text, ...) {
      self$append_content(RcodeBlock$new(text, ...))
      invisible(self)
    },
    #' @description Appends a generic `ContentBlock` to this `ReportCard`.
    #'
    #' @param content (`ContentBlock`) object.
    #' @return `self`, invisibly.
    #' @examples
    #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
    #' card <- ReportCard$new()$append_content(NewpageBlock$new())
    #'
    append_content = function(content) {
      checkmate::assert_class(content, "ContentBlock")
      private$content <- append(private$content, content)
      invisible(self)
    },
    #' @description Get all content blocks from this `ReportCard`.
    #'
    #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_content()
    #'
    #'
    get_content = function() {
      private$content
    },
    #' @description Clears all content and metadata from `ReportCard`.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Get the metadata associated with `ReportCard`.
    #'
    #' @return `named list` list of elements.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `ReportCard`.
    #'
    #' @param key (`character(1)`) string specifying the metadata key.
    #' @param value value associated with the metadata key.
    #' @return `self`, invisibly.
    #' @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(private$metadata))
      meta_list <- list()
      meta_list[[key]] <- value
      private$metadata <- append(private$metadata, meta_list)
      invisible(self)
    },
    #' @description Get the name of the `ReportCard`.
    #'
    #' @return `character` a card name.
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    get_name = function() {
      private$name
    },
    #' @description Set the name of the `ReportCard`.
    #'
    #' @param name (`character(1)`) a card name.
    #' @return `self`, invisibly.
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    set_name = function(name) {
      checkmate::assert_character(name)
      private$name <- name
      invisible(self)
    },
    #' @description Convert the `ReportCard` to a list, including content and metadata.
    #' @param output_dir (`character`) with a path to the directory where files will be copied.
    #' @return (`named list`) a `ReportCard` representation.
    #' @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) {
      new_blocks <- list()
      for (block in self$get_content()) {
        block_class <- class(block)[1]
        formal_args <- formalArgs(block$to_list)
        cblock <- if ("output_dir" %in% formal_args) {
          block$to_list(output_dir)
        } else {
          block$to_list()
        }
        new_block <- list()
        new_block[[block_class]] <- cblock
        new_blocks <- c(new_blocks, new_block)
      }
      new_card <- list()
      new_card[["blocks"]] <- new_blocks
      new_card[["metadata"]] <- self$get_metadata()
      new_card[["name"]] <- self$get_name()
      new_card
    },
    #' @description Reconstructs the `ReportCard` from a list representation.
    #' @param card (`named list`) a `ReportCard` representation.
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #' @return `self`, invisibly.
    #' @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) {
      self$reset()
      blocks <- card$blocks
      metadata <- card$metadata
      name <- card$name
      if (length(name) == 0) name <- character(0)
      blocks_names <- names(blocks)
      blocks_names <- gsub("[.][0-9]*$", "", blocks_names)
      for (iter_b in seq_along(blocks)) {
        block_class <- blocks_names[iter_b]
        block <- blocks[[iter_b]]
        instance <- private$dispatch_block(block_class)
        formal_args <- formalArgs(instance$new()$from_list)
        cblock <- if (all(c("x", "output_dir") %in% formal_args)) {
          instance$new()$from_list(block, output_dir)
        } else if ("x" %in% formal_args) {
          instance$new()$from_list(block)
        } else {
          instance$new()$from_list()
        }
        self$append_content(cblock)
      }
      for (meta in names(metadata)) {
        self$append_metadata(meta, metadata[[meta]])
      }
      self$set_name(name)
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    metadata = list(),
    name = character(0),
    dispatch_block = function(block_class) {
      eval(str2lang(block_class))
    },
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "content") {
        lapply(value, function(content_block) {
          if (inherits(content_block, "R6")) {
            content_block$clone(deep = TRUE)
          } else {
            content_block
          }
        })
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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

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

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


  shiny::tags$div(.renderHook = function(res_tag) {
    res_tag$children <- list(
      shiny::tags$div(
        class = "card",
        style = "margin: 0.5rem 0;",
        shiny::tags$div(
          class = "card-header",
          shiny::tags$div(
            class = ifelse(collapsed, "collapsed", ""),
            `data-bs-toggle` = "collapse",
            href = paste0("#", panel_id),
            `aria-expanded` = ifelse(collapsed, "false", "true"),
            shiny::icon("angle-down", class = "dropdown-icon"),
            shiny::tags$label(
              style = "display: inline;",
              title,
            )
          )
        ),
        shiny::tags$div(
          id = panel_id,
          class = paste("collapse", ifelse(collapsed, "", "show")),
          shiny::tags$div(
            class = "card-body",
            ...
          )
        )
      )
    )

    res_tag
  })
}

#' Convert content into a `flextable`
#'
#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
#'
#' Function merges cells with `colspan` > 1,
#' aligns columns to the center and row names to the left,
#' indents the row names by 10 times indentation.
#'
#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
#'
#' @return `flextable`.
#'
#' @keywords internal
to_flextable <- function(content) {
  if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
    ft <- rtables.officer::tt_to_flextable(content)
  } else if (inherits(content, "listing_df")) {
    mf <- rlistings::matrix_form(content)
    nr_header <- attr(mf, "nrow_header")
    df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
    header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])

    ft <- rtables::df_to_tt(df)
    if (length(mf$main_title) != 0) {
      rtables::main_title(ft) <- mf$main_title
    }
    rtables::subtitles(ft) <- mf$subtitles
    rtables::main_footer(ft) <- mf$main_footer
    rtables::prov_footer(ft) <- mf$prov_footer
    rtables::header_section_div(ft) <- mf$header_section_div
    ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1))
  } else if (inherits(content, "data.frame")) {
    ft <- rtables.officer::tt_to_flextable(
      rtables::df_to_tt(content)
    )
  } else {
    stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
  }

  ft
}

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

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

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

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

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

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


#' @keywords internal
.outline_button <- function(id, label, icon = NULL, class = "primary") {
  shiny::tagList(
    shinyjs::useShinyjs(),
    .custom_css_dependency(),
    htmltools::htmlDependency(
      name = "teal-reporter-busy-disable",
      version = utils::packageVersion("teal.reporter"),
      package = "teal.reporter",
      src = "js",
      script = "busy-disable.js"
    ),
    shiny::tags$button(
      id = id,
      class = sprintf("teal-reporter action-button teal-reporter-busy-disable outline-button %s", class),
      role = "button",
      style = "text-decoration: none;",
      if (!is.null(icon)) {
        margin_style <- ifelse(is.null(label), "margin: 0 10px 0 10px;", "")
        shiny::tags$span(
          style = margin_style,
          bsicons::bs_icon(icon, class = sprintf("text-%s", class))
        )
      },
      label
    )
  )
}

#' @keywords internal
.custom_css_dependency <- function() {
  htmltools::htmlDependency(
    name = "teal-reporter",
    version = utils::packageVersion("teal.reporter"),
    package = "teal.reporter",
    src = "css",
    stylesheet = "custom.css"
  )
}

#' @title `Reporter`: An `R6` class for managing report cards
#' @docType class
#' @description
#'
#' This `R6` class is designed to store and manage report cards,
#' facilitating the creation, manipulation, and serialization of report-related data.
#'
#' @export
#'
Reporter <- R6::R6Class( # nolint: object_name_linter.
  classname = "Reporter",
  public = list(
    #' @description Initialize a `Reporter` object.
    #'
    #' @return Object of class `Reporter`, invisibly.
    #' @examples
    #' reporter <- Reporter$new()
    #'
    initialize = function() {
      private$cards <- list()
      private$reactive_add_card <- shiny::reactiveVal(0)
      invisible(self)
    },
    #' @description Append one or more `ReportCard` objects to the `Reporter`.
    #'
    #' @param cards (`ReportCard`) or a list of such objects
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    append_cards = function(cards) {
      checkmate::assert_list(cards, "ReportCard")
      # Set up unique id for each card
      names(cards) <- vapply(cards, function(card) {
        sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8))
      }, character(1L))

      for (card_id in names(cards)) {
        private$cards[[card_id]] <- cards[[card_id]]
        private$cards_order <- c(private$cards_order, card_id)
      }
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description Retrieves all `ReportCard` objects contained in the `Reporter`.
    #'
    #' @return A (`list`) of [`ReportCard`] objects.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      private$cards[private$cards_order]
    },
    #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`.
    #'
    #' @param sep An optional separator to insert between each content block.
    #' Default is a `NewpageBlock$new()`object.
    #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`.
    #' @examplesIf require("ggplot2")
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_blocks()
    #'
    get_blocks = function(sep = NewpageBlock$new()) {
      blocks <- list()
      if (length(private$cards) > 0) {
        for (card_idx in head(seq_along(private$cards), -1)) {
          blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
        }
        blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
      }
      blocks
    },
    #' @description Resets the `Reporter`, removing all [`ReportCard`] objects and metadata.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$cards <- list()
      private$metadata <- list()
      private$reactive_add_card(0)
      private$cards_order <- c()
      invisible(self)
    },
    #' @description Removes specific `ReportCard` objects from the `Reporter` by their indices.
    #'
    #' @param ids (`character`) the ids of the cards to be removed.
    #' @return `self`, invisibly.
    remove_cards = function(ids) {
      if (!is.null(ids)) {
        private$cards <- private$cards[!names(private$cards) %in% ids]
        private$cards_order <- private$cards_order[!private$cards_order %in% ids]
      }
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description Reorders `ReportCard` or `ReportDocument` objects in `Reporter`.
    #' @param new_order `character` vector with card ids in the desired order.
    #' @return `self`, invisibly.
    reorder_cards = function(new_order) {
      private$cards_order <- new_order
      invisible(self)
    },
    #' @description Gets the current value of the reactive variable for adding cards.
    #'
    #' @return `reactive_add_card` current `numeric` value of the reactive variable.
    #' @note The function has to be used in the shiny reactive context.
    #' @examples
    #' library(shiny)
    #'
    #' isolate(Reporter$new()$get_reactive_add_card())
    get_reactive_add_card = function() {
      private$reactive_add_card()
    },
    #' @description Get the metadata associated with this `Reporter`.
    #'
    #' @return `named list` of metadata to be appended.
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `Reporter`.
    #'
    #' @param meta (`named list`) of metadata to be appended.
    #' @return `self`, invisibly.
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    append_metadata = function(meta) {
      checkmate::assert_list(meta, names = "unique")
      checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata)))
      private$metadata <- append(private$metadata, meta)
      invisible(self)
    },
    #' @description
    #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
    #' @param reporter (`Reporter`) instance to copy from.
    #' @return invisibly self
    #' @examples
    #' reporter <- Reporter$new()
    #' reporter$from_reporter(reporter)
    from_reporter = function(reporter) {
      checkmate::assert_class(reporter, "Reporter")
      self$reset()
      self$append_cards(reporter$get_cards())
      self$append_metadata(reporter$get_metadata())
      invisible(self)
    },
    #' @description Convert a `Reporter` to a list and transfer 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()
      for (card in self$get_cards()) {
        # we want to have list names being a class names to indicate the class for $from_list
        card_class <- class(card)[1]
        u_card <- list()
        u_card[[card_class]] <- card$to_list(output_dir)
        rlist$cards <- c(rlist$cards, u_card)
      }
      rlist
    },
    #' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory.
    #' @param rlist (`named list`) representing a `Reporter` instance.
    #' @param output_dir (`character(1)`) a path to the directory from which files will be copied.
    #' @return `self`, invisibly.
    #' @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]]
          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 the `Reporter` id
    #' @return `character(1)` the `Reporter` id.
    get_id = function() {
      private$id
    }
  ),
  private = list(
    id = "",
    cards = list(),
    metadata = list(),
    reactive_add_card = NULL,
    cards_order = c(),
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "cards") {
        lapply(value, function(card) card$clone(deep = TRUE))
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `TableBlock`
#' @docType class
#' @description
#' Specialized `FileBlock` for managing table content in reports.
#' It's designed to handle various table formats, converting them into a consistent,
#' document-ready format (e.g., `flextable`) for inclusion in reports.
#'
#' @keywords internal
TableBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TableBlock",
  inherit = FileBlock,
  public = list(
    #' @description Initialize a `TableBlock` object.
    #'
    #' @param table (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) a table assigned to
    #'   this `TableBlock`
    #'
    #' @return Object of class `TableBlock`, invisibly.
    initialize = function(table) {
      if (!missing(table)) {
        self$set_content(table)
      }
      invisible(self)
    },
    #' @description Sets content of this `TableBlock`.
    #'
    #' @details Raises error if argument is not a table-like object.
    #'
    #' @param content (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
    #' a table assigned to this `TableBlock`
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' TableBlock <- getFromNamespace("TableBlock", "teal.reporter")
    #' block <- TableBlock$new()
    #' block$set_content(iris)
    #'
    set_content = function(content) {
      checkmate::assert_multi_class(content, private$supported_tables)
      content <- to_flextable(content)
      path <- tempfile(fileext = ".rds")
      saveRDS(content, file = path)
      super$set_content(path)
      invisible(self)
    }
  ),
  private = list(
    supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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

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

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

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

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

    # @description Finalizes a `Renderer` object.
    finalize = function() {
      unlink(private$output_dir, recursive = TRUE)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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

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

#' 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)
  .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_reactive_add_card(), {
      shinyjs::toggleClass(
        id = "preview_button", condition = reporter$get_reactive_add_card() == 0, class = "disabled"
      )
    })

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

    preview_modal <- function() {
      shiny::tags$div(
        class = "teal-reporter reporter-previewer-modal",
        .custom_css_dependency(),
        shiny::modalDialog(
          easyClose = TRUE,
          size = "xl",
          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",
              NULL,
              "Dismiss"
            )
          )
        )
      )
    }

    shiny::observeEvent(input$preview_button, {
      shiny::showModal(preview_modal())
    })
    reporter_previewer_content_srv(id = "preview_content", reporter = reporter)
  })
}


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


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

#' @keywords internal
reporter_previewer_content_ui <- function(id) {
  shiny::uiOutput(shiny::NS(id, "pcards"))
}

#' @keywords internal
reporter_previewer_content_srv <- function(id, reporter) {
  shiny::moduleServer(id, function(input, output, session) {
    shiny::setBookmarkExclude("card_remove_id")
    report_cards <- shiny::reactive({
      shiny::req(reporter$get_reactive_add_card())
      input$reporter_cards_order
      reporter$get_cards()
    })
    output$pcards <- shiny::renderUI({
      cards <- report_cards()

      if (length(cards)) {
        shiny::tags$div(
          .custom_css_dependency(),
          bslib::accordion(
            id = session$ns("reporter_cards"),
            class = "teal-reporter report-previewer-accordion",
            lapply(names(cards), function(card_id) {
              htmltools::tagAppendChildren(
                tag = shiny::tags$div(
                  id = card_id,
                  `data-rank-id` = card_id,
                  bslib::accordion_panel(
                    title = cards[[card_id]]$get_name(),
                    icon = bslib::tooltip(
                      bsicons::bs_icon("arrows-move"),
                      "Move card"
                    ),
                    shiny::tags$div(
                      id = paste0("card", card_id),
                      lapply(
                        cards[[card_id]]$get_content(),
                        function(b) {
                          block_to_html(b)
                        }
                      )
                    )
                  )
                ),
                .cssSelector = ".accordion-button",
                bslib::tooltip(
                  shiny::tags$a(
                    class = "action-button",
                    role = "button",
                    style = "text-decoration: none;",
                    onclick = sprintf(
                      "Shiny.setInputValue('%s', '%s', {priority: 'event'});",
                      session$ns("card_remove_id"),
                      card_id
                    ),
                    bsicons::bs_icon("x-circle", class = "text-danger")
                  ),
                  "Remove card"
                )
              )
            })
          ),
          sortable::sortable_js(
            css_id = session$ns("reporter_cards"),
            options = sortable::sortable_options(
              onSort = sortable::sortable_js_capture_input(session$ns("reporter_cards_order")),
              handle = ".accordion-icon"
            )
          )
        )
      } else {
        shiny::tags$div(
          shiny::tags$br(),
          shiny::tags$p(
            class = "text-danger",
            shiny::tags$strong("No Cards added")
          )
        )
      }
    })

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

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

#' @title `ContentBlock`: A building block for report content
#' @docType class
#' @description This class represents a basic content unit in a report,
#' such as text, images, or other multimedia elements.
#' It serves as a foundation for constructing complex report structures.
#'
#' @keywords internal
ContentBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "ContentBlock",
  public = list(
    #' @description Sets content of this `ContentBlock`.
    #'
    #' @param content (`any`) R object
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' block <- ContentBlock$new()
    #' block$set_content("Base64 encoded picture")
    #'
    set_content = function(content) {
      private$content <- content
      invisible(self)
    },
    #' @description Retrieves the content assigned to this block.
    #'
    #' @return object stored in a `private$content` field
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' block <- ContentBlock$new()
    #' block$get_content()
    #'
    get_content = function() {
      private$content
    },
    #' @description Create the `ContentBlock` from a list.
    #'
    #' @param x (`named list`) with two fields `text` and `style`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return `self`, invisibly.
    from_list = function(x) {
      invisible(self)
    },
    #' @description Convert the `ContentBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    to_list = function() {
      list()
    }
  ),
  private = list(
    content = NULL, # this can be any R object
    # @description The copy constructor.
    #
    # @param name (`character(1)`) the name of the field
    # @param value the value assigned to the field
    #
    # @return the value of the copied field
    deep_clone = function(name, value) {
      if (name == "content" && checkmate::test_file_exists(value)) {
        extension <- ""
        split <- strsplit(basename(value), split = "\\.")
        # The below ensures no extension is found for files such as this: .gitignore but is found for files like
        # .gitignore.txt
        if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") {
          extension <- split[[1]][length(split[[1]])]
          extension <- paste0(".", extension)
        }
        copied_file <- tempfile(fileext = extension)
        file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE)
        copied_file
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `HTMLBlock`
#' @docType class
#' @description
#' Specialized `FileBlock` for managing HTML content in reports.
#' It's designed to handle various HTML content, and render the report as HTML,
#' however `htmlwidgets` objects can also be rendered to static document-ready format.
#'
#' @keywords internal
HTMLBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "HTMLBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Initialize a `HTMLBlock` object.
    #'
    #' @param content An object that can be rendered as a HTML content assigned to
    #'   this `HTMLBlock`
    #'
    #' @return Object of class `HTMLBlock`, invisibly.
    initialize = function(content) {
      if (!missing(content)) {
        checkmate::assert_multi_class(content, private$supported_types)
        self$set_content(content)
      }
      invisible(self)
    },

    #' @description Create the `HTMLBlock` from a list.
    #'
    #' @param x (`named list`) with a single field `content` containing `shiny.tag`,
    #' `shiny.tag.list` or `htmlwidget`.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter")
    #' block <- HTMLBlock$new()
    #' block$from_list(list(content = shiny::tags$div("test")))
    #'
    from_list = function(x) {
      checkmate::assert_list(x, types = private$supported_types)
      checkmate::assert_names(names(x), must.include = "content")
      self$set_content(x$content)
      invisible(self)
    },

    #' @description Convert the `HTMLBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    #' @examples
    #' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter")
    #' block <- HTMLBlock$new(shiny::tags$div("test"))
    #' block$to_list()
    #'
    to_list = function() {
      list(content = self$get_content())
    }
  ),
  private = list(
    supported_types = c("shiny.tag", "shiny.tag.list", "htmlwidget")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `TextBlock`
#' @docType class
#' @description
#' Specialized `ContentBlock` for embedding styled text within reports.
#' It supports multiple styling options to accommodate various text roles,
#' such as headers or verbatim text, in the report content.
#'
#' @keywords internal
TextBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TextBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Initialize a `TextBlock` object.
    #'
    #' @details Constructs a `TextBlock` object with no content and the default style.
    #'
    #' @param content (`character`) a string assigned to this `TextBlock`
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return Object of class `TextBlock`, invisibly.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #'
    initialize = function(content = character(0), style = private$styles[1]) {
      super$set_content(content)
      self$set_style(style)
      invisible(self)
    },
    #' @description Sets content of this `TextBlock`.
    #'
    #' @param content (`any`) R object
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter")
    #' block <- ContentBlock$new()
    #' block$set_content("Base64 encoded picture")
    #'
    set_content = function(content) {
      checkmate::assert_string(content)
      super$set_content(content)
    },
    #' @description Sets the style of this `TextBlock`.
    #'
    #' @details The style has bearing on the rendering of this block.
    #'
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$set_style("header2")
    #'
    set_style = function(style) {
      private$style <- match.arg(style, private$styles)
      invisible(self)
    },
    #' @description Get the style of this `TextBlock`.
    #'
    #' @return `character(1)` the style of this `TextBlock`.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$get_style()
    #'
    get_style = function() {
      private$style
    },
    #' @description Get available an array of styles available to this `TextBlock`.
    #'
    #' @return A `character` array of styles.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$get_available_styles()
    #'
    get_available_styles = function() {
      private$styles
    },
    #' @description Create the `TextBlock` from a list.
    #'
    #' @param x (`named list`) with two fields `text` and `style`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$from_list(list(text = "sth", style = "default"))
    #'
    from_list = function(x) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = c("text", "style"))
      self$set_content(x$text)
      self$set_style(x$style)
      invisible(self)
    },
    #' @description Convert the `TextBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    #' @examples
    #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
    #' block <- TextBlock$new()
    #' block$to_list()
    #'
    to_list = function() {
      list(text = self$get_content(), style = self$get_style())
    }
  ),
  private = list(
    content = character(0),
    style = character(0),
    styles = c("default", "header2", "header3", "verbatim")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `PictureBlock`
#' @docType class
#' @description
#' Specialized `FileBlock` for managing picture content in reports.
#' It's designed to handle plots from packages such as `ggplot2`, `grid`, or `lattice`.
#' It can save plots to files, set titles and specify dimensions.
#'
#' @keywords internal
PictureBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "PictureBlock",
  inherit = FileBlock,
  public = list(
    #' @description Initialize a `PictureBlock` object.
    #'
    #' @param plot (`ggplot` or `grid`) a picture in this `PictureBlock`
    #'
    #' @return Object of class `PictureBlock`, invisibly.
    initialize = function(plot) {
      if (!missing(plot)) {
        self$set_content(plot)
      }
      invisible(self)
    },
    #' @description Sets the content of this `PictureBlock`.
    #'
    #' @details Raises error if argument is not a `ggplot`, `grob` or `trellis` plot.
    #'
    #' @param content (`ggplot` or `grob` or `trellis`) a picture in this `PictureBlock`
    #'
    #' @return `self`, invisibly.
    #' @examplesIf require("ggplot2") && require("lattice")
    #' library(ggplot2)
    #' library(lattice)
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplot(iris))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(bwplot(1))
    #'
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_content(ggplotGrob(ggplot(iris)))
    set_content = function(content) {
      checkmate::assert_multi_class(content, private$supported_plots)
      path <- tempfile(fileext = ".png")
      grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
      tryCatch(
        expr = {
          if (inherits(content, "grob")) {
            grid::grid.newpage()
            grid::grid.draw(content)
          } else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
            print(content)
          } else if (inherits(content, "trellis")) {
            grid::grid.newpage()
            grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
          }
          super$set_content(path)
        },
        finally = grDevices::dev.off()
      )
      invisible(self)
    },
    #' @description Sets the title of this `PictureBlock`.
    #'
    #' @details Raises error if argument is not `character(1)`.
    #'
    #' @param title (`character(1)`) a string assigned to this `PictureBlock`
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_title("Title")
    #'
    set_title = function(title) {
      checkmate::assert_string(title)
      private$title <- title
      invisible(self)
    },
    #' @description Get the title of this `PictureBlock`.
    #'
    #' @return The content of this `PictureBlock`.
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$get_title()
    #'
    get_title = function() {
      private$title
    },
    #' @description Sets the dimensions of this `PictureBlock`.
    #'
    #' @param dim (`numeric(2)`) figure dimensions (width and height) in pixels.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$set_dim(c(800, 600))
    #'
    set_dim = function(dim) {
      checkmate::assert_numeric(dim, len = 2)
      private$dim <- dim
      invisible(self)
    },
    #' @description Get `PictureBlock` dimensions as a numeric vector.
    #'
    #' @return `numeric` the array of 2 numeric values representing width and height in pixels.
    #' @examples
    #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter")
    #' block <- PictureBlock$new()
    #' block$get_dim()
    get_dim = function() {
      private$dim
    }
  ),
  private = list(
    supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
    type = character(0),
    title = "",
    dim = c(800, 600)
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' 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 it is empty.
#' @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"))

    ns <- session$ns
    nr_cards <- length(reporter$get_cards())

    shiny::observeEvent(reporter$get_reactive_add_card(), {
      shinyjs::toggleClass(
        id = "reset_reporter", condition = reporter$get_reactive_add_card() == 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(ns("reset_reporter_ok"), "Reset", class = "btn btn-primary")
            )
          )
        )
      )
    })

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

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

  invisible()
}

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

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

#' @title `FileBlock`
#' @docType class
#' @description
#' `FileBlock` manages file-based content in a report,
#'  ensuring appropriate handling of content files.
#'
#' @keywords internal
FileBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Create the `FileBlock` from a list.
    #' The list should contain one named field, `"basename"`.
    #'
    #' @param x (`named list`) with one field `"basename"`, a name of the file.
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' file_path <- tempfile(fileext = ".png")
    #' saveRDS(iris, file_path)
    #' block$from_list(list(basename = basename(file_path)), dirname(file_path))
    #'
    from_list = function(x, output_dir) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = "basename")
      path <- file.path(output_dir, x$basename)
      file_type <- paste0(".", tools::file_ext(path))
      checkmate::assert_file_exists(path, extension = file_type)
      new_file_path <- tempfile(fileext = file_type)
      file.copy(path, new_file_path)
      super$set_content(new_file_path)
      invisible(self)
    },
    #' @description Convert the `FileBlock` to a list.
    #'
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #'
    #' @return `named list` with a `basename` of the file.
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' block$to_list(tempdir())
    #'
    to_list = function(output_dir) {
      base_name <- basename(super$get_content())
      file.copy(super$get_content(), file.path(output_dir, base_name))
      list(basename = base_name)
    }
  ),
  private = list(
    content = character(0L),

    # @description Finalize the `FileBlock`.
    #
    # @details Removes the temporary file created in the constructor.
    finalize = function() {
      try(unlink(super$get_content()))
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' 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 (`function`) which returns a [`ReportCard`] instance,
#' the function has a `card` argument and an optional `comment` argument.
#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
#'
#' @examples
#' 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 = c(
      "html" = "html_document", "pdf" = "pdf_document",
      "powerpoint" = "powerpoint_presentation", "word" = "word_document"
    ),
    rmd_yaml_args = list(
      author = "NEST", title = "Report",
      date = as.character(Sys.Date()), output = "html_document",
      toc = FALSE
    )) {
  shiny::moduleServer(
    id,
    function(input, output, session) {
      add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
      download_report_button_srv(
        "download_button_simple",
        reporter = reporter,
        global_knitr = global_knitr,
        rmd_output = rmd_output,
        rmd_yaml_args = rmd_yaml_args
      )
      report_load_srv("archive_load_simple", reporter = reporter)
      reset_report_button_srv("reset_button_simple", reporter = reporter)
    }
  )
}

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

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
29		#' @rdname load_report_button
30		#' @return `shiny::moduleServer`
31		#' @export
32		report_load_srv <- function(id, reporter) {
33	9x	checkmate::assert_class(reporter, "Reporter")
34
35	9x	shiny::moduleServer(
36	9x	id,
37	9x	function(input, output, session) {
38	9x	shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load"))
39	9x	ns <- session$ns
40
41	9x	archiver_modal <- function() {
42	2x	nr_cards <- length(reporter$get_cards())
43	2x	shiny::div(
44	2x	class = "teal-reporter reporter-modal",
45	2x	.custom_css_dependency(),
46	2x	shiny::modalDialog(
47	2x	easyClose = TRUE,
48	2x	shiny::tags$h3("Load the Report"),
49	2x	shiny::tags$hr(),
50	2x	shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)",
51	2x	multiple = FALSE,
52	2x	accept = c(".zip")
53		),
54	2x	footer = shiny::div(
55	2x	shiny::tags$button(
56	2x	type = "button",
57	2x	class = "btn btn-outline-secondary",
58	2x	`data-bs-dismiss` = "modal",
59	2x	NULL,
60	2x	"Dismiss"
61		),
62	2x	shinyjs::disabled(
63	2x	shiny::tags$button(
64	2x	id = ns("reporter_load_main"),
65	2x	type = "button",
66	2x	class = "btn btn-primary action-button",
67	2x	NULL,
68	2x	"Load"
69		)
70		)
71		)
72		)
73		)
74		}
75
76	9x	shiny::observeEvent(input$archiver_zip, {
77	2x	shinyjs::enable(id = "reporter_load_main")
78		})
79
80	9x	shiny::observeEvent(input$reporter_load, {
81	2x	shiny::showModal(archiver_modal())
82		})
83
84	9x	shiny::observeEvent(input$reporter_load_main, {
85	2x	load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]])
86	2x	shiny::removeModal()
87		})
88		}
89		)
90		}
91
92		#' @keywords internal
93		load_json_report <- function(reporter, zip_path, filename) {
94	2x	tmp_dir <- tempdir()
95	2x	output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
96	2x	dir.create(path = output_dir)
97	2x	if (!is.null(zip_path) && grepl("report_", filename)) {
98	2x	tryCatch(
99	2x	expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE),
100	2x	warning = function(cond) {
101	!	print(cond)
102	!	shiny::showNotification(
103	!	ui = "Unzipping folder warning!",
104	!	action = "Please contact app developer",
105	!	type = "warning"
106		)
107		},
108	2x	error = function(cond) {
109	!	print(cond)
110	!	shiny::showNotification(
111	!	ui = "Unzipping folder error!",
112	!	action = "Please contact app developer",
113	!	type = "error"
114		)
115		}
116		)
117	2x	tryCatch(
118	2x	reporter$from_jsondir(output_dir),
119	2x	warning = function(cond) {
120	!	print(cond)
121	!	shiny::showNotification(
122	!	ui = "Loading reporter warning!",
123	!	action = "Please contact app developer",
124	!	type = "warning"
125		)
126		},
127	2x	error = function(cond) {
128	1x	print(cond)
129	1x	shiny::showNotification(
130	1x	ui = "Loading reporter error!",
131	1x	action = "Please contact app developer",
132	1x	type = "error"
133		)
134		}
135		)
136		} else {
137	!	shiny::showNotification(
138	!	paste(
139	!	"Failed to load the Reporter file.",
140	!	"Please make sure that the filename starts with `report_`."
141		),
142	!	type = "error"
143		)
144		}
145		}

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

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

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 (`function`) which returns a [`ReportCard`] instance,
18		#' the function has a `card` argument and an optional `comment` argument.
19		#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
20		#' @inheritParams reporter_download_inputs
21		#'
22		#' @return `NULL`.
23		#'
24		#' @examples
25		#' if (interactive()) {
26		#' library(shiny)
27		#'
28		#' shinyApp(
29		#' ui = fluidPage(simple_reporter_ui("simple")),
30		#' server = function(input, output, session) {
31		#' simple_reporter_srv("simple", Reporter$new(), function(card) card)
32		#' }
33		#' )
34		#' }
35		NULL
36
37		#' @rdname simple_reporter
38		#' @export
39		simple_reporter_ui <- function(id) {
40	1x	ns <- shiny::NS(id)
41	1x	shiny::tagList(
42	1x	.custom_css_dependency(),
43	1x	shiny::tags$div(
44	1x	shiny::tags$label(class = "text-primary", shiny::tags$strong("Reporter")),
45	1x	shiny::tags$div(
46	1x	class = "simple_reporter_container",
47	1x	add_card_button_ui(ns("add_report_card_simple")),
48	1x	download_report_button_ui(ns("download_button_simple")),
49	1x	report_load_ui(ns("archive_load_simple")),
50	1x	reset_report_button_ui(ns("reset_button_simple"))
51		),
52	1x	shiny::tags$br()
53		)
54		)
55		}
56
57		#' @rdname simple_reporter
58		#' @export
59		simple_reporter_srv <- function(
60		id,
61		reporter,
62		card_fun,
63		global_knitr = getOption("teal.reporter.global_knitr"),
64		rmd_output = c(
65		"html" = "html_document", "pdf" = "pdf_document",
66		"powerpoint" = "powerpoint_presentation", "word" = "word_document"
67		),
68		rmd_yaml_args = list(
69		author = "NEST", title = "Report",
70		date = as.character(Sys.Date()), output = "html_document",
71		toc = FALSE
72		)) {
73	2x	shiny::moduleServer(
74	2x	id,
75	2x	function(input, output, session) {
76	2x	add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
77	2x	download_report_button_srv(
78	2x	"download_button_simple",
79	2x	reporter = reporter,
80	2x	global_knitr = global_knitr,
81	2x	rmd_output = rmd_output,
82	2x	rmd_yaml_args = rmd_yaml_args
83		)
84	2x	report_load_srv("archive_load_simple", reporter = reporter)
85	2x	reset_report_button_srv("reset_button_simple", reporter = reporter)
86		}
87		)
88		}

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

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

1		#' Mark strings for quotation in `yaml` serialization
2		#'
3		#' This function is designed for use with the `yaml` package to explicitly,
4		#' It adds an attribute to character strings, indicating that they should be serialized with double quotes.
5		#'
6		#' @param x (`character`)
7		#' @keywords internal
8		#' @examples
9		#' library(yaml)
10		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
11		#' yaml <- list(
12		#' author = yaml_quoted("NEST"),
13		#' title = yaml_quoted("Report"),
14		#' date = yaml_quoted("07/04/2019"),
15		#' output = list(pdf_document = list(keep_tex = TRUE))
16		#' )
17		#' as.yaml(yaml)
18		yaml_quoted <- function(x) {
19	2x	attr(x, "quoted") <- TRUE
20	2x	x
21		}
22
23		#' Create `markdown` header from `yaml` string
24		#'
25		#' This function wraps a `yaml`-formatted string in Markdown header delimiters.
26		#'
27		#' @param x (`character`) `yaml` formatted string.
28		#' @keywords internal
29		#' @examples
30		#' library(yaml)
31		#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter")
32		#' yaml <- list(
33		#' author = yaml_quoted("NEST"),
34		#' title = yaml_quoted("Report"),
35		#' date = yaml_quoted("07/04/2019"),
36		#' output = list(pdf_document = list(keep_tex = TRUE))
37		#' )
38		#' md_header <- getFromNamespace("md_header", "teal.reporter")
39		#' md_header(as.yaml(yaml))
40		md_header <- function(x) {
41	14x	paste0("---\n", x, "---\n")
42		}
43
44		#' Convert `yaml` representation of a boolean strings to logical Values
45		#'
46		#' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`.
47		#'
48		#' @param input (`character(1)`)
49		#' @param name (`charcter(1)`)
50		#' @param pos_logi (`character`) vector of `yaml` values which should be treated as `TRUE`.
51		#' @param neg_logi (`character`) vector of `yaml` values which should be treated as `FALSE`.
52		#' @param silent (`logical(1)`) if to suppress the messages and warnings.
53		#' @return `input` argument or the appropriate `logical` value.
54		#' @keywords internal
55		#' @examples
56		#' 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	17x	rmarkdown_namespace <- asNamespace("rmarkdown")
99	17x	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	16x	checkmate::assert_string(output_name)
116	16x	checkmate::assert_subset(output_name, rmd_outputs())
117
118	15x	rmarkdown_namespace <- asNamespace("rmarkdown")
119	15x	if (default_values) {
120	13x	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	16x	checkmate::assert_logical(as_header)
198	16x	checkmate::assert_logical(convert_logi)
199	16x	checkmate::assert_logical(silent)
200	16x	checkmate::assert_logical(multi_output)
201
202	16x	if (multi_output) {
203	1x	checkmate::assert_list(input_list, names = "named")
204		} else {
205	15x	checkmate::assert_list(input_list, names = "unique")
206		}
207
208	13x	is_nested <- function(x) any(unlist(lapply(x, is.list)))
209	13x	if (is_nested(input_list)) {
210	2x	result <- input_list
211		} else {
212	11x	result <- list()
213	11x	input_nams <- names(input_list)
214
215		# top fields
216	11x	top_fields <- c(
217	11x	"author", "date", "title", "subtitle", "abstract",
218	11x	"keywords", "subject", "description", "category", "lang"
219		)
220	11x	for (itop in top_fields) {
221	110x	if (itop %in% input_nams) {
222	20x	result[[itop]] <- switch(itop,
223	20x	date = as.character(input_list[[itop]]),
224	20x	input_list[[itop]]
225		)
226		}
227		}
228
229		# output field
230	11x	doc_types <- unlist(input_list[input_nams == "output"])
231	11x	if (length(doc_types)) {
232	10x	for (dtype in doc_types) {
233	11x	doc_type_args <- rmd_output_arguments(dtype, TRUE)
234	11x	doc_type_args_nams <- names(doc_type_args)
235	11x	any_output_arg <- any(input_nams %in% doc_type_args_nams)
236
237	11x	not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
238	11x	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	11x	if (any_output_arg) {
243	10x	doc_list <- list()
244	10x	doc_list[[dtype]] <- list()
245	10x	for (e in intersect(input_nams, doc_type_args_nams)) {
246	16x	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	16x	doc_list[[dtype]][[e]] <- input_list[[e]]
259		}
260	10x	result[["output"]] <- append(result[["output"]], doc_list)
261		} else {
262	1x	result[["output"]] <- append(result[["output"]], input_list[["output"]])
263		}
264		}
265		}
266		}
267
268	13x	result <- yaml::as.yaml(result)
269	13x	if (as_header) {
270	12x	result <- md_header(result)
271		}
272	13x	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	8x	checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
304	8x	checkmate::assert_string(field_name)
305
306	8x	yaml_obj <- yaml::yaml.load(yaml_text)
307
308	8x	result <- yaml_obj[[field_name]]
309	8x	if (is.list(result)) {
310	4x	result <- names(result)
311		}
312	8x	result
313		}

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

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

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

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

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

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	!	.outline_button(
23	!	ns("preview_button"),
24	!	label = shiny::tags$span(
25	!	label,
26	!	shiny::uiOutput(ns("preview_button_counter"))
27		),
28	!	icon = "file-earmark-text"
29		)
30		}
31
32		#' @rdname reporter_previewer
33		#' @export
34		preview_report_button_srv <- function(id, reporter) {
35	!	checkmate::assert_class(reporter, "Reporter")
36
37	!	shiny::moduleServer(id, function(input, output, session) {
38	!	shiny::setBookmarkExclude(c("preview_button"))
39
40	!	shiny::observeEvent(reporter$get_reactive_add_card(), {
41	!	shinyjs::toggleClass(
42	!	id = "preview_button", condition = reporter$get_reactive_add_card() == 0, class = "disabled"
43		)
44		})
45
46	!	output$preview_button_counter <- shiny::renderUI({
47	!	shiny::tags$span(
48	!	class = "position-absolute badge rounded-pill bg-primary",
49	!	reporter$get_reactive_add_card()
50		)
51		})
52
53	!	preview_modal <- function() {
54	!	shiny::tags$div(
55	!	class = "teal-reporter reporter-previewer-modal",
56	!	.custom_css_dependency(),
57	!	shiny::modalDialog(
58	!	easyClose = TRUE,
59	!	size = "xl",
60	!	reporter_previewer_content_ui(session$ns("preview_content")),
61	!	footer = shiny::tagList(
62	!	shiny::tags$button(
63	!	type = "button",
64	!	class = "btn btn-outline-secondary",
65	!	`data-bs-dismiss` = "modal",
66	!	NULL,
67	!	"Dismiss"
68		)
69		)
70		)
71		)
72		}
73
74	!	shiny::observeEvent(input$preview_button, {
75	!	shiny::showModal(preview_modal())
76		})
77	!	reporter_previewer_content_srv(id = "preview_content", reporter = reporter)
78		})
79		}
80
81
82		# deprecated ------------------------------------------------------------------------------------------------------
83
84
85		#' Report previewer module
86		#'
87		#' @description `r lifecycle::badge("deprecated")`
88		#'
89		#' Module offers functionalities to visualize, manipulate,
90		#' and interact with report cards that have been added to a report.
91		#' It includes a previewer interface to see the cards and options to modify the report before downloading.
92		#'
93		#' Cards are saved by the `shiny` bookmarking mechanism.
94		#'
95		#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
96		#'
97		#' This function is deprecated and will be removed in the next release.
98		#' Please use `preview_report_button_ui()` and `preview_report_button_srv()`
99		#' to create a preview button that opens a modal with the report preview.
100		#'
101		#' @details `r global_knitr_details()`
102		#'
103		#' @name reporter_previewer_deprecated
104		#'
105		#' @param id (`character(1)`) `shiny` module instance id.
106		#' @param reporter (`Reporter`) instance.
107		#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
108		#' for customizing the rendering process.
109		#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible
110		#' values and `"download"` is required.
111		#' Default `c("download", "load", "reset")`
112		#' @inheritParams reporter_download_inputs
113		#'
114		#' @return `NULL`.
115		NULL
116
117		#' @rdname reporter_previewer_deprecated
118		#' @export
119		reporter_previewer_ui <- function(id) {
120	1x	ns <- shiny::NS(id)
121	1x	lifecycle::deprecate_soft(
122	1x	when = "0.5.0",
123	1x	what = "reporter_previewer_ui()",
124	1x	details = paste(
125	1x	"Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n",
126	1x	"Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,",
127	1x	"and `preview_report_button_ui()` instead."
128		)
129		)
130	1x	bslib::page_fluid(
131	1x	shiny::tagList(
132	1x	shinyjs::useShinyjs(),
133	1x	shiny::tags$div(
134	1x	class = "well",
135	1x	style = "display: inline-flex; flex-direction: row; gap: 10px;",
136	1x	shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")),
137	1x	shiny::tags$span(
138	1x	id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report")
139		),
140	1x	shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report"))
141		),
142	1x	shiny::tags$div(
143	1x	reporter_previewer_content_ui(ns("previewer"))
144		)
145		)
146		)
147		}
148
149		#' @rdname reporter_previewer_deprecated
150		#' @export
151		reporter_previewer_srv <- function(id,
152		reporter,
153		global_knitr = getOption("teal.reporter.global_knitr"),
154		rmd_output = getOption("teal.reporter.rmd_output"),
155		rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"),
156		previewer_buttons = c("download", "load", "reset")) {
157	8x	lifecycle::deprecate_soft(
158	8x	when = "0.5.0",
159	8x	what = "reporter_previewer_srv()",
160	8x	details = paste(
161	8x	"Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n",
162	8x	"Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,",
163	8x	"and `preview_report_button_srv()` instead."
164		)
165		)
166	8x	checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE)
167	8x	checkmate::assert_true("download" %in% previewer_buttons)
168	8x	checkmate::assert_class(reporter, "Reporter")
169	8x	checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
170	8x	checkmate::assert_subset(
171	8x	rmd_output,
172	8x	c("html_document", "pdf_document", "powerpoint_presentation", "word_document"),
173	8x	empty.ok = FALSE
174		)
175	8x	checkmate::assert_list(rmd_yaml_args, names = "named")
176	8x	checkmate::assert_names(
177	8x	names(rmd_yaml_args),
178	8x	subset.of = c("author", "title", "date", "output", "toc"),
179	8x	must.include = "output"
180		)
181	6x	checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
182
183	5x	shiny::moduleServer(id, function(input, output, session) {
184	5x	if (!"load" %in% previewer_buttons) {
185	!	shinyjs::hide(id = "load_span")
186		}
187	5x	if (!"download" %in% previewer_buttons) {
188	!	shinyjs::hide(id = "download_span")
189		}
190	5x	if (!"reset" %in% previewer_buttons) {
191	!	shinyjs::hide(id = "reset_span")
192		}
193	5x	report_load_srv("load", reporter = reporter)
194	5x	download_report_button_srv(
195	5x	"download",
196	5x	reporter = reporter,
197	5x	global_knitr = global_knitr,
198	5x	rmd_output = rmd_output,
199	5x	rmd_yaml_args = rmd_yaml_args
200		)
201	5x	reset_report_button_srv("reset", reporter = reporter)
202	5x	reporter_previewer_content_srv("previewer", reporter = reporter)
203		})
204		}
205
206
207		# reporter_previewer_content --------------------------------------------------------------------------------------
208
209		#' @keywords internal
210		reporter_previewer_content_ui <- function(id) {
211	1x	shiny::uiOutput(shiny::NS(id, "pcards"))
212		}
213
214		#' @keywords internal
215		reporter_previewer_content_srv <- function(id, reporter) {
216	5x	shiny::moduleServer(id, function(input, output, session) {
217	5x	shiny::setBookmarkExclude("card_remove_id")
218	5x	report_cards <- shiny::reactive({
219	2x	shiny::req(reporter$get_reactive_add_card())
220	2x	input$reporter_cards_order
221	2x	reporter$get_cards()
222		})
223	5x	output$pcards <- shiny::renderUI({
224	2x	cards <- report_cards()
225
226	2x	if (length(cards)) {
227	2x	shiny::tags$div(
228	2x	.custom_css_dependency(),
229	2x	bslib::accordion(
230	2x	id = session$ns("reporter_cards"),
231	2x	class = "teal-reporter report-previewer-accordion",
232	2x	lapply(names(cards), function(card_id) {
233	2x	htmltools::tagAppendChildren(
234	2x	tag = shiny::tags$div(
235	2x	id = card_id,
236	2x	`data-rank-id` = card_id,
237	2x	bslib::accordion_panel(
238	2x	title = cards[[card_id]]$get_name(),
239	2x	icon = bslib::tooltip(
240	2x	bsicons::bs_icon("arrows-move"),
241	2x	"Move card"
242		),
243	2x	shiny::tags$div(
244	2x	id = paste0("card", card_id),
245	2x	lapply(
246	2x	cards[[card_id]]$get_content(),
247	2x	function(b) {
248	!	block_to_html(b)
249		}
250		)
251		)
252		)
253		),
254	2x	.cssSelector = ".accordion-button",
255	2x	bslib::tooltip(
256	2x	shiny::tags$a(
257	2x	class = "action-button",
258	2x	role = "button",
259	2x	style = "text-decoration: none;",
260	2x	onclick = sprintf(
261	2x	"Shiny.setInputValue('%s', '%s', {priority: 'event'});",
262	2x	session$ns("card_remove_id"),
263	2x	card_id
264		),
265	2x	bsicons::bs_icon("x-circle", class = "text-danger")
266		),
267	2x	"Remove card"
268		)
269		)
270		})
271		),
272	2x	sortable::sortable_js(
273	2x	css_id = session$ns("reporter_cards"),
274	2x	options = sortable::sortable_options(
275	2x	onSort = sortable::sortable_js_capture_input(session$ns("reporter_cards_order")),
276	2x	handle = ".accordion-icon"
277		)
278		)
279		)
280		} else {
281	!	shiny::tags$div(
282	!	shiny::tags$br(),
283	!	shiny::tags$p(
284	!	class = "text-danger",
285	!	shiny::tags$strong("No Cards added")
286		)
287		)
288		}
289		})
290
291	5x	shiny::observeEvent(input$card_remove_id, {
292	!	reporter$remove_cards(ids = input$card_remove_id)
293		})
294
295	5x	shiny::observeEvent(input$reporter_cards_order, {
296	!	reporter$reorder_cards(input$reporter_cards_order)
297		})
298		})
299		}
300
301		#' @noRd
302		#' @keywords internal
303		block_to_html <- function(b) {
304	!	b_content <- b$get_content()
305	!	if (inherits(b, "TextBlock")) {
306	!	switch(b$get_style(),
307	!	header1 = shiny::tags$h1(b_content),
308	!	header2 = shiny::tags$h2(b_content),
309	!	header3 = shiny::tags$h3(b_content),
310	!	header4 = shiny::tags$h4(b_content),
311	!	verbatim = shiny::tags$pre(b_content),
312	!	shiny::tags$pre(b_content)
313		)
314	!	} else if (inherits(b, "RcodeBlock")) {
315	!	panel_item("R Code", shiny::tags$pre(b_content))
316	!	} else if (inherits(b, "PictureBlock")) {
317	!	shiny::tags$img(src = knitr::image_uri(b_content))
318	!	} else if (inherits(b, "TableBlock")) {
319	!	b_table <- readRDS(b_content)
320	!	shiny::tags$pre(
321	!	flextable::htmltools_value(b_table)
322		)
323	!	} else if (inherits(b, "NewpageBlock")) {
324	!	shiny::tags$br()
325	!	} else if (inherits(b, "HTMLBlock")) {
326	!	b_content
327		} else {
328	!	stop("Unknown block class")
329		}
330		}

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

1		#' @title `HTMLBlock`
2		#' @docType class
3		#' @description
4		#' Specialized `FileBlock` for managing HTML content in reports.
5		#' It's designed to handle various HTML content, and render the report as HTML,
6		#' however `htmlwidgets` objects can also be rendered to static document-ready format.
7		#'
8		#' @keywords internal
9		HTMLBlock <- R6::R6Class( # nolint: object_name_linter.
10		classname = "HTMLBlock",
11		inherit = ContentBlock,
12		public = list(
13		#' @description Initialize a `HTMLBlock` object.
14		#'
15		#' @param content An object that can be rendered as a HTML content assigned to
16		#' this `HTMLBlock`
17		#'
18		#' @return Object of class `HTMLBlock`, invisibly.
19		initialize = function(content) {
20	12x	if (!missing(content)) {
21	7x	checkmate::assert_multi_class(content, private$supported_types)
22	6x	self$set_content(content)
23		}
24	11x	invisible(self)
25		},
26
27		#' @description Create the `HTMLBlock` from a list.
28		#'
29		#' @param x (`named list`) with a single field `content` containing `shiny.tag`,
30		#' `shiny.tag.list` or `htmlwidget`.
31		#'
32		#' @return `self`, invisibly.
33		#' @examples
34		#' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter")
35		#' block <- HTMLBlock$new()
36		#' block$from_list(list(content = shiny::tags$div("test")))
37		#'
38		from_list = function(x) {
39	2x	checkmate::assert_list(x, types = private$supported_types)
40	2x	checkmate::assert_names(names(x), must.include = "content")
41	2x	self$set_content(x$content)
42	2x	invisible(self)
43		},
44
45		#' @description Convert the `HTMLBlock` to a list.
46		#'
47		#' @return `named list` with a text and style.
48		#' @examples
49		#' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter")
50		#' block <- HTMLBlock$new(shiny::tags$div("test"))
51		#' block$to_list()
52		#'
53		to_list = function() {
54	2x	list(content = self$get_content())
55		}
56		),
57		private = list(
58		supported_types = c("shiny.tag", "shiny.tag.list", "htmlwidget")
59		),
60		lock_objects = TRUE,
61		lock_class = TRUE
62		)

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

1		.onLoad <- function(libname, pkgname) {
2	!	op <- options()
3	!	teal_reporter_default_options <- list(
4	!	teal.reporter.global_knitr = list(
5	!	echo = TRUE,
6	!	tidy.opts = list(width.cutoff = 60),
7	!	tidy = requireNamespace("formatR", quietly = TRUE)
8		),
9	!	teal.reporter.rmd_output = c(
10	!	"html" = "html_document", "pdf" = "pdf_document",
11	!	"powerpoint" = "powerpoint_presentation",
12	!	"word" = "word_document"
13		),
14	!	teal.reporter.rmd_yaml_args = list(
15	!	author = "NEST", title = "Report",
16	!	date = as.character(Sys.Date()), output = "html_document",
17	!	toc = FALSE
18		)
19		)
20
21	!	toset <- !(names(teal_reporter_default_options) %in% names(op))
22	!	if (any(toset)) options(teal_reporter_default_options[toset])
23
24	!	invisible()
25		}
26
27		.onAttach <- function(libname, pkgname) {
28	2x	if (!requireNamespace("formatR", quietly = TRUE)) {
29	!	packageStartupMessage(
30	!	"For better code formatting, consider installing the formatR package."
31		)
32		}
33		}

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

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